+TITLE. GARFIELD 7.44 /00 010203 00.00 * * GARFIELD, A drift-chamber simulation program. * * This is Garfield version 7.44, updated until 24/ 3/12. Comments and * reports are most welcome. A copy of any note, thesis or publication * for which Garfield has been used, will be highly appreciated. * * The author can not be held responsible for any error in this program, * in any of the associated files, nor in the documentation. * * Documentation relative to this program, as well as recent copies of * the program files can be obtained at the URLs: * * CNL articles: http://cern.ch/garfield/cnl * Some examples: http://cern.ch/garfield/examples * Files: http://cern.ch/garfield/files * Command format: http://cern.ch/garfield/help * * Author: Rob Veenhof Rob Veenhof * CERN PH department 2, Rue du Reculet * CH-1211 Geneve 23 or F 01630 St Genis Pouilly * Switzerland / Suisse France * tel: + 41 22 7673222 tel: + 33 4 50421784 * email: Rob.Veenhof@cern.ch email: Rob.Veenhof@gmail.com * * Garfield calls neBEM, developed by Supratik Mukhopadhyay and Nayana * Majumdar, Saha Institute of Nuclear Physics, Kolkata, WB, India. * Source files and information: http://cern.ch/nebem * * Ionisation patterns are usually computed by the Heed program, which * is linked with Garfield, and which has been written by Igor Smirnov. * This program is described in NIM A 554 (2005) 474. * * Electron transport tables are computed by the Magboltz program, * linked with Garfield, and written by Steve Biagi. * * Contributions: * G.A. Erskine (retired, DD division CERN). * Carlo Mekenkamp (Rijks Universiteit Leiden). * * CERN program library reference: W5050 * * Copyright: Rob Veenhof, 2011. +PATCH,*APOLLO. Pilot patch for Apollo SR10 +IMI,APOLLO. +IMI,SAVE. +IMI,GTSGRAL. +PATCH,*BOINC. Pilot patch for Unix BOINC +IMI,BOINC. +IMI,UNIX. +IMI,SAVE. +IMI,HIGZ. +PATCH,*WBOINC. Pilot patch for Windows BOINC +IMI,BOINC. +IMI,CYGWIN. +IMI,SAVE. +IMI,HIGZ. +PATCH,*IBMVM. Pilot patch for VM/CMS (Miguel) +USE,*CMS. +PATCH,*CMS. Pilot patch for VM/CMS systems +IMI,CMS. +IMI,NAG,IF=CERN,IF=-HIGZ. +IMI,GTSGRAL. +IMI,ESSL. +PATCH,*CRAY. Pilot patch for Cray UNICOS +IMI,CRAY. +IMI,GTSGRAL. +IMI,VECTOR. +IMI,UNIX. +IMI,SAVE. +PATCH,*IBMAIX. Various specific Unix systems +USE,*UNIX. +IMI,IBMAIX. +PATCH,*DECS. Dec station +USE,*UNIX. +IMI,DECS. +PATCH,*HPUX. HP +USE,*UNIX. +IMI,HPUX. +PATCH,*IBMRT. IBM RT, also used for SP2. +USE,*UNIX. +IMI,ESSL. +IMI,IBMRT. +PATCH,*SGI. Silicon graphics +USE,*UNIX. +IMI,SGI. +PATCH,*SUN. Sun +USE,*UNIX. +IMI,SUN. +PATCH,*UNIX. Pilot patch for generic Unix +IMI,UNIX. +IMI,SAVE. +IMI,HIGZ. +PATCH,*LINUX. Pilot patch for Linux +IMI,LINUX. +IMI,UNIX. +IMI,SAVE. +IMI,HIGZ. +PATCH,*MACOSX. Pilot patch for Mac OSX +IMI,MACOSX. +IMI,UNIX. +IMI,SAVE. +IMI,HIGZ. +PATCH,*MVS. Pilot patch for IBM MVS systems +IMI,MVS. +IMI,GTSGRAL. +PATCH,*VAX. Pilot patch for Vax VMS +IMI,VAX. +IMI,NAG,IF=CERN. +IMI,AST,IF=-QMALPH. +IMI,GTSGRAL. +IMI,SAVE. +PATCH,*CYGWIN. Pilot patch for Cygwin +IMI,CYGWIN. +IMI,SAVE. +IMI,HIGZ. +PATCH,*INTERFACE. Isolate user interface +USE,P=COMMONS. +USE,P=GRAPHICS. +USE,P=GKSHIGZ,IF=HIGZ. +USE,P=PROJECTION. +USE,P=INPUT. +USE,P=DATASET. +USE,P=ALGEBRA. +USE,P=HELP,T=INHIBIT. +USE,P=HISTOGRAM. +USE,P=MATRIX. +USE,P=ROUTINES. +USE,P=ROUTINES,D=VMCMS,T=INHIBIT. +USE,P=ROUTINES,D=SUBSET,T=INHIBIT. +PATCH,*PATCHES. For backwards compatibility. +USE,*GARFIELD. +PATCH,*GARFIELD. Main routine selection patch. +USE,P=COMMONS. +USE,P=MAIN. +USE,P=GRAPHICS. +USE,P=GKSHIGZ,IF=HIGZ. +USE,P=PROJECTION. +USE,P=INPUT. +USE,P=DATASET. +USE,P=ALGEBRA. +USE,P=ROUTINES. +USE,P=ROUTINES,D=VMCMS,T=INHIBIT. +USE,P=ROUTINES,D=SUBSET,T=INHIBIT. +USE,P=VAXAST,IF=VAX,IF=AST. +USE,P=HISTOGRAM. +USE,P=MATRIX. +USE,P=HELP. +USE,P=CELL. +USE,P=NEBEM. +USE,P=GAS. +USE,P=SRIMREAD. +USE,P=TRIMREAD. +USE,P=OPTIMISE,IF=CELL. +USE,P=FIELD,IF=CELL. +USE,P=FIELDCAL,IF=CELL,FIELD,OPTIMISE,DRIFT,SIGNAL. +USE,P=ZERO,IF=FIELD. +USE,P=DRIFT,IF=CELL,IF=GAS. +USE,P=SIGNAL,IF=CELL,IF=GAS. +USE,P=DRIFTCAL,IF=DRIFT,SIGNAL. +USE,P=AUXILIARY,D=CLD,IF=VAX. +USE,P=AUXILIARY,D=MAINHELP. +PATCH,*GARFRUN. Front end program. +USE,P=FRONTEND. +USE,P=AUXILIARY,D=CLD,IF=VAX. +USE,P=AUXILIARY,D=LSE,IF=VAX. +USE,P=AUXILIARY,D=GARFRUNMSG,IF=VAX. +USE,P=AUXILIARY,D=HELPVAX,IF=VAX. +USE,P=AUXILIARY,D=HELPCMS,IF=CMS. +USE,P=AUXILIARY,D=MANPAGE,IF=UNIX. +USE,P=AUXILIARY,D=PANEL,IF=CMS. +USE,P=AUXILIARY,D=MINIEXEC,IF=CMS. +PATCH,COMMONS. +KEEP,XDIMENSIONS,IF=NEVER. *----------------------------------------------------------------------- * Parameter block containing the dimensions of the arrays. * Changing the parameters in this block influences the entire * program, but it should be used to save space on the one * hand and to accomodate many wires on the other hand. * PARAMETER : MXWIRE : Maximum number of wires that can be stored. * MXSW : Maximum number of sense wires. * MXPSTR : Maximum number of strips per plane. * MXMATT : Maximum number of x and y dielectrica. * MX3D : Maximum number of 3 dimensional charges. * MXPOLE : Maximum number of multipole terms. * MXLIST : Maximum number of points in lists eg in the * gas tables or on the drift lines etc. * MXGRID : Maximum number of grid points. * MXNAME : Maximum number of characters in dsnames. * MXLUN : Highest input LUN allowed to be open. * MXCLUS : Maximum number of clusters along the track. * MXPAIR : Maximum number of ion pairs in one cluster * MXLINE : Maximum number of drift lines (equal time). * MXEQUT : Maximum number of equal time contours. * MXFOUR : Maximum number of Fourier terms (ion tail). * MXRECL : Maximum lrecl of a direct access file. * MXINCH : Maximum number of characters / input line. * MXWORD : Maximum number of words a line may contain. * MXCHAR : Maximum number of characters in each word. * MXINS : Maximum number of instructions in a list. * MXREG : Maximum number of varying numbers. * MXCONS : Maximum number of constants. * MXVAR : Maximum number of variables to be passed. * MXZERO : Maximum number of zeros to be handled. * MXCHA : Maximum number of channels in a histogram. * MXPART : Maximum number of particles on a track. * MXSTCK : Maximum stack level for integrations. * MXFPAR : Maximum number of fitting parameters. * MXFPNT : Maximum number of fitting data-points. * MXWKLS : Maximum number of active workstations. * MXHLRL : Record length for the help file. * MXSUBT : Maximum sublevel depth during help. * MXHLEV : Maximum number of levels in the help file. * MXFRAC : Maximum number of gas components. * MXBANG : Maximum number of E-B angles in tables. * MXBTAB : Maximum number of B fields in the tables. * MXEXG : Maximum number of excitation states * MXIOG : Maximum number of ionisation states * MXORIA : Maximum number of ion origin angles. * MXMAT : Maximum number of matrices. * MXEMAT : Total matrix storage area. * MXMDIM : Maximum number of matrix dimensions. * MXEPS : Maximum number of media in a field map. * MXMAP : Maximum number of triangles in a field map. * MXWMAP : Maximum number of weighting field maps. * MXSOLI : Maximum number of conductors. * MXPLAN : Maximum number of planes in buffer. * MXPOIN : Maximum number of points in buffer. * MXEDGE : Maximum number of edges per polygon. * MXMCA : Maximum avalanche size * (Last changed on 13/ 1/09.) *----------------------------------------------------------------------- +KEEP,DIMWIRE,IF=MANYWIRE. PARAMETER (MXWIRE= 2000,MXSW = 200) +KEEP,DIMWIRE,IF=-MANYWIRE. PARAMETER (MXWIRE= 300,MXSW = 50) +KEEP,DIMLIST,IF=LONGLIST. PARAMETER (MXLIST= 1000) +KEEP,DIMLIST,IF=-LONGLIST. PARAMETER (MXLIST= 200) +KEEP,DIMMAP,IF=HUGEMAP. PARAMETER (MXMAP =350000,MXEPS = 10) +KEEP,DIMMAP,IF=BIGMAP. PARAMETER (MXMAP = 30000,MXEPS = 10) +KEEP,DIMMAP,IF=-BIGMAP,IF=-HUGEMAP. PARAMETER (MXMAP = 5000,MXEPS = 10) +KEEP,DIMENSIONS. INTEGER MXWIRE,MXSW,MXLIST,MXCHA,MXGRID,MXMATT,MXPOLE,MX3D, - MXPSTR, - MXPAIR,MXPART,MXFOUR,MXCLUS, - MXLINE,MXEQUT, - MXRECL,MXINCH,MXWORD,MXCHAR,MXNAME,MXLUN, - MXINS,MXREG,MXARG,MXCONS,MXVAR,MXALGE, - MXZERO,MXSTCK,MXFPNT,MXFPAR,MXWKLS, - MXHLEV,MXHLRL,MXSUBT, - MXDLVL,MXILVL,MXDLIN, - MXHIST,MXFRAC,MXBANG,MXBTAB, - MXEXG,MXIOG,MXCSG, - MXORIA, - MXMAT,MXEMAT,MXMDIM, - MXSHOT,MXZPAR, - MXMAP,MXEPS,MXWMAP,MXSOLI,MXSBUF, - MXPLAN,MXPOIN,MXEDGE, - MXMCA +SEQ,DIMWIRE. PARAMETER (MXMATT= 10) PARAMETER (MX3D = 100) PARAMETER (MXPOLE= 10) PARAMETER (MXPSTR= 100) +SEQ,DIMLIST. PARAMETER (MXHIST= 200, MXCHA = MXLIST/2) PARAMETER (MXGRID= 50) PARAMETER (MXNAME= 200, MXLUN = 30) PARAMETER (MXCLUS= 500, MXPAIR= 2000, MXPART= 10000) PARAMETER (MXLINE= 150, MXEQUT= 50) PARAMETER (MXFOUR= 16) PARAMETER (MXRECL= 10000) PARAMETER (MXINCH= 2000, MXWORD= 200, MXCHAR=MXINCH) PARAMETER (MXINS = 1000, MXREG = 500, MXCONS= -500, - MXVAR = 500, MXALGE= 500, MXARG = 100) PARAMETER (MXMAT = 500, MXEMAT=100000, MXMDIM= 10) PARAMETER (MXZERO=MXWIRE) PARAMETER (MXSTCK= 5) PARAMETER (MXFPNT= 1000, MXFPAR= 10) PARAMETER (MXWKLS= 10) PARAMETER (MXHLEV= 9, MXSUBT= 200, MXHLRL= 860) PARAMETER (MXDLVL= 10, MXILVL= 20, MXDLIN= 2500) PARAMETER (MXFRAC= 13) PARAMETER (MXBANG= 20, MXBTAB= 25) PARAMETER (MXEXG = 50, MXIOG = 10, MXCSG = 200) PARAMETER (MXORIA= 1000) PARAMETER (MXSHOT= 10, MXZPAR=4*MXSHOT+2) +SEQ,DIMMAP. PARAMETER (MXWMAP= 5) PARAMETER (MXSOLI= 1000) PARAMETER (MXPLAN= 50000, MXPOIN=100000,MXEDGE=100) PARAMETER (MXSBUF= 20000) PARAMETER (MXMCA = 50000) * The parameter MXNBMC must equal MXGNAM (sequence MAGBPARM) ! INTEGER MXNBMC PARAMETER(MXNBMC=60) +KEEP,XPARAMETERS,IF=NEVER. *----------------------------------------------------------------------- * PARMS - Common block containing quantities of interest for plotting * and numerical calculations. * VARIABLES : NGRIDX, Y : Number of x resp y devisions of a grid. * NLINED : Number of tracks starting at each edge of * of the drift area or at each wire. * NINORD : Drift line interpolation order. * LINCAL : Compute lines which can't be interpolated. * PXMIN,PXMAX: x-range of field plot area. * PYMIN,PYMAX: y-range of field plot area. * PZMIN,PZMAX: z-range of field plot area. * GXMIN,GXMAX: x-range of graphics plot area. * GYMIN,GYMAX: y-range of graphics plot area. * GZMIN,GZMAX: z-range of graphics plot area. * G[X/Y/Z]BOX: Enclosing area box in screen coordinates. * NGBOX : Entries in G[X/Y/Z]BOX. * FPROJ : Viewing plane for field plots. * FPRMAT : Matrix used for projections. * IPRMAT : Row interchanges for solving FPRMAT. * EPSG[X/Y/Z]: Tolerances for point comparisons. * LEPSG : Tolerances set or not. * PXLAB : x-Axis label, length is NCXLAB * PYLAB : y-Axis label, length is NCYLAB * PROLAB : Projection label, length is NCFPRO * PROROT : Axis rotation. * PRVIEW : Projection type. * PRFREF : Sharing Reflected vs Diffuse scattering * PRFABS : Visible vs Absorbed light fraction * PRFMIN/MAX : Light shading range in use * WLMIN/MAX : Minimum and maximum wave length * NPRCOL : Number of shades of each colour * ICOLBX : Start of box and tickmarks colour table. * ICOLPL : Start of plans and tube colour table. * ICOLST : Start of strips colour table. * ICOLW1 : Start of conductor 1 colour table. * ICOLW2 : Start of conductor 2 colour table. * ICOLW3 : Start of conductor 3 colour table. * ICOLD1 : Start of dielectricum 1 colour table. * ICOLD2 : Start of dielectricum 2 colour table. * ICOLD3 : Start of dielectricum 3 colour table. * ICOLRB : Start of rainbow colour table. * XT0,YT0,...: Defines a track (always in Cart. coord.) * LTRMS : Take multiple scattering into account. * LTRDEL : Generate delta electrons. * LTRINT : Use track interpolation to save time. * LTREXB : Request tracing through E and B fields * LTRCUT : Cut when deposits exceed track energy * ITRTYP : Type of track generation requested: * 1 = fixed number of lines over track, * 2 = equal cluster spacing, d=1/n_mean, * 3 = exponential cluster spacing, * 4 = HEED cluster generation. * 5 = weighted distribution * 6 = single cluster * 7 = equal flux intervals * 8 = constant flux intervals * 9 = SRIM cluster generation * 10 = TRIM cluster generation * NTRLIN : Number of lines for ITRTYP=1. * TRFLAG : Track status flags: * 1 = geometry set * 2 = energy, mass and charge set * 3 = number of points set * 4 = weighting function set * 5 = number of samples set * 6 = number of flux lines set * TRENER : Track kinetic energy [MeV] * TRCHAR : Track charge [proton charges] * TRMASS : Track particle mass [MeV] * TRELEC : Limit for delta approximation of e- * TRNSRM : Target cluster size for SRIM * > 0: a size * -1: automatic * -2: single step * ITFSRM : SRIM fluctuation model: * 0 = no fluctuations * 1 = Landau * 2 = Vavilov * 3 = Gaussian * 4 = Combined * NTRERR : Error count for track generation * LTRVVL : true: precise, false: fast Vavilov * LDLSRM : Include longitudinal straggling * LDTSRM : Include transverse straggling * NTRFLX : Number of flux lines (model 7) * TRFLUX : Flux interval in V (model 8) * TRTH,TRPHI : Track orientation * WGT : Weighting distribution * FCNTRW : Weighting function * LGSTEP : Display one panel at the time (debug) * (Last changed on 5/12/08.) *----------------------------------------------------------------------- +KEEP,PARAMETERS. DOUBLE PRECISION WGT,FPRMAT, - FPROJ,FPROJA,FPROJB,FPROJC,FPROJD,FPROJN, - EPSGX,EPSGY,EPSGZ, - GXMIN,GYMIN,GZMIN,GXMAX,GYMAX,GZMAX, - GXBOX,GYBOX,GZBOX REAL PXMIN,PYMIN,PZMIN,PXMAX,PYMAX,PZMAX, - PRTHL,PRPHIL,PRAL,PRBL,PRCL,PROROT, - PRFABS,PRFREF,PRFMIN,PRFMAX,PRFCAL,WLMIN,WLMAX, - XT0,YT0,ZT0,XT1,YT1,ZT1, - TRMASS,TRENER,TRCHAR,TRXDIR,TRYDIR,TRZDIR,TRTH,TRPHI,TRDIST, - TRFLUX,TRELEC,TRNSRM INTEGER NLINED,NGRIDX,NGRIDY,ITRTYP,NTRLIN,NTRSAM,INDPOS,NCTRW, - NTRFLX,NINORD, - NCPNAM,NCXLAB,NCYLAB,NCFPRO,IPRMAT, - NPRCOL,ICOL0,ICOLBX,ICOLPL,ICOLST,ICOLW1,ICOLW2,ICOLW3, - ICOLD1,ICOLD2,ICOLD3,ICOLRB,NGBOX,ITFSRM,NTRERR LOGICAL LTRMS,LTRDEL,LTRINT,LTREXB,LTRCUT,TRFLAG,LINCAL, - LFULLB,LFULLP,LFULLT,LSPLIT,LSORT,LOUTL,LEPSG,LGSTEP, - LDLSRM,LDTSRM,LTRVVL COMMON /PARMS / WGT(MXLIST),FPRMAT(3,3), - FPROJ(3,3),FPROJA,FPROJB,FPROJC,FPROJD,FPROJN, - EPSGX,EPSGY,EPSGZ, - GXMIN,GYMIN,GZMIN,GXMAX,GYMAX,GZMAX, - GXBOX(12),GYBOX(12),GZBOX(12), - PXMIN,PYMIN,PZMIN,PXMAX,PYMAX,PZMAX, - PRTHL,PRPHIL,PRAL,PRBL,PRCL,PROROT, - PRFABS,PRFREF,PRFMIN,PRFMAX,PRFCAL,WLMIN,WLMAX, - XT0,YT0,ZT0,XT1,YT1,ZT1, - TRMASS,TRENER,TRCHAR,TRXDIR,TRYDIR,TRZDIR,TRTH,TRPHI,TRDIST, - TRFLUX,TRELEC,TRNSRM, - INDPOS(11000),IPRMAT(3),NCTRW,NCPNAM, - ITRTYP,NTRLIN,NTRSAM,NTRFLX,ITFSRM,NTRERR(10), - NLINED,NINORD,NGRIDX,NGRIDY,NCXLAB,NCYLAB,NCFPRO, - NPRCOL,ICOL0,ICOLBX,ICOLPL,ICOLST,ICOLW1,ICOLW2,ICOLW3, - ICOLD1,ICOLD2,ICOLD3,ICOLRB,NGBOX, - LTRMS,LTRDEL,LTRINT,LTREXB,LTRCUT,TRFLAG(10),LINCAL, - LFULLB,LFULLP,LFULLT,LSPLIT,LSORT,LOUTL,LEPSG,LGSTEP, - LDLSRM,LDTSRM,LTRVVL CHARACTER*80 PARTID,PXLAB,PYLAB,PROLAB CHARACTER*10 PNAME CHARACTER*5 PRVIEW CHARACTER*(MXCHAR) FCNTRW COMMON /PARCHR/ PARTID,FCNTRW,PNAME,PXLAB,PYLAB,PROLAB,PRVIEW +KEEP,XLSQFITPAR. *----------------------------------------------------------------------- * CONSTANTS - Parameter block containing some common constants. * VARIABLES: DA : Covariance matrix * (Last changed on 23/ 5/11.) *----------------------------------------------------------------------- +KEEP,LSQFITPAR. DOUBLE PRECISION DA INTEGER NDA COMMON /LSQPAR/ DA(MXFPAR,MXFPAR),NDA +KEEP,XCONSTANTS,IF=NEVER. *----------------------------------------------------------------------- * CONSTANTS - Parameter block containing some common constants. * PARAMETERS: PI : 3.141592653589793238 * CLOG2 : Log(2) [Natural logarithm of course !] * ICONS : ICONS**2=-1. * EPS0 : Vacuum dielectric constant [F/cm]. * ECHARG : Charge of the electron [C]. * EMASS : Mass of the electron [kg]. * GRAV : Gravitational constant [m/sec**2]. * BOLTZ : Boltzmann constant [J/K]. * CLIGHT : Speed of light [cm/microsec]. * (Last changed on 10/ 2/97.) *----------------------------------------------------------------------- +KEEP,CONSTANTS. COMPLEX ICONS REAL PI,CLOG2,EPS0,ECHARG,EMASS,CLIGHT,BOLTZ,GRAV PARAMETER (PI=3.141592653589793238, - CLOG2=0.693147180559945309417, - ICONS=(0.0,1.0), - EPS0=8.854187817E-14, - ECHARG=1.60217733E-19, - EMASS=9.1093897E-31, - GRAV=9.80665, - CLIGHT=2.99792458E4, - BOLTZ=1.380658E-23) +KEEP,XPRINTPLOT,IF=NEVER. *----------------------------------------------------------------------- * PRTPLT - Common block specifying what should and what should not be * printed/plotted. It also contains the debug options. * VARIABLES : LINPUT : yes/no printing of the input, * LDEBUG : yes/no debuging output, * LIDENT : yes/no routine identification, * LKEYPL : yes/no plotting of contour keys (NAG), * LCELPR : yes/no printing of cell data, * LCELPL : yes/no plotting of cell layout, * LDRPLT : yes/no drift lines plotted, * LDRPRT : yes/no printing of drift line data, * LCLPRT : yes/no printing of cluster history, * LCLPLT : yes/no printing of plotting of cluster etc, * LPROPR : yes/no printing of progress. * LPROF : yes/no reading of profile * LMAPCH : yes/no check of field map indexing * LSYNCH : Synchronisation prompt format. * LUNOUT : unit to be used for output. * JFAIL : Action in case of an error (1=carry on with * defaults, 2=skip the line, 3=stop program). * JEXMEM : Action in case a member already exists * (1=delete old copy, 2=write+warn, 3=warn) * LGSTOP : Dump and stop after graphics fault (debug) * LGSIG : Signal top dump and stop. * (Last changed on 15/12/98.) *----------------------------------------------------------------------- +KEEP,PRINTPLOT. LOGICAL LINPUT,LCELPR,LCELPL,LWRMRK,LISOCL,LCHGCH, - LDRPLT,LDRPRT,LCLPRT,LCLPLT,LMAPCH,LCNTAM, - LDEBUG,LIDENT,LKEYPL,LRNDMI,LPROPR,LPROF,LGSTOP,LGSIG, - LSYNCH INTEGER LUNOUT,JFAIL,JEXMEM COMMON /PRTPLT/ LINPUT,LCELPR,LCELPL,LWRMRK,LISOCL,LCHGCH, - LDRPLT,LDRPRT,LCLPRT,LCLPLT,LMAPCH,LCNTAM, - LDEBUG,LIDENT,LKEYPL,LRNDMI,LPROPR,LPROF,LGSTOP,LGSIG, - LSYNCH,LUNOUT,JFAIL,JEXMEM +KEEP,XCELLDATA,IF=NEVER. *----------------------------------------------------------------------- * CELDAT - Common block containing all information on the cell, such * CELCHR as the wire data, planes, constants etc. * VARIABLES : X(I),Y(I) : Position of wire I [cm]. * WMAP(I) : Mapped wire positions [cm]. * D(I) : Diameter of wire I [cm]. * E(I),V(I) : Charge on wire i, potential of wire I. * W(I) : Stretching weight of the wire [grams]. * U(I) : Length of the wire [cm]. * DENS(I) : Density of the wire [g/cm3]. * WIRTYP(I) : Type of wire of wire I. * SINPH2(I),COSPH2(I) : Dipole orientation of wire I * AMP2(I) : Dipole amplitude of wire I * NWIRE : Number of wires present in the cell. * N3D : Number of three-dimensional charges. * X3D,Y3D,Z3D: Positions of the three-dimensional charges. * E3D : Charge of the three-dimensional charges. * NTERMB/D : Number of terms for 3D B2 potentials. * XMIN, XMAX : x-range of the cell comsidered [cm]. * YMIN, YMAX : y-range of the cell considered [cm]. * ZMIN, ZMAX : z-range of the cell considered [cm]. * YNPLAN(I) : Plane I exist if .TRUE. * COPLAN(I) : Relevant coordinate of plane I * VTPLAN(I) : Potential of plane I. * PLATYP(I) : Label of plane I. * YNPLAX,YNPLAY: Yes/no plane in x or y (reduce CPU time). * COPLAX,COPLAY: Coordinates of planes (reduce CPU time). * INDPLA : Conductor group number for plane I, * the tube has number 5. * PLSTR1(I,J,K): x/y-strip J for plane I, K=1: lower * limit, K=2: upper limit, K=3: gap. * PLSTR2(I,J,K): z-strip J for plane I, K=1: lower limit, * K=2: upper limit, K=3: gap. * PSLAB1/2 : Labels of strips. * NPSTR1/2(I): Number of x/y and z strips in plane I. * INDST1/2 : Conductor group numbers for strips. * XMATT(I,.) : x-start, x-end, eps of x-dielectricum I. * YMATT(I,.) : y-start, y-end, eps of y-dielectricum I. * NXMATT : Number of x-dielectrica. * NYMATT : Number of y-dielectrica. * V0 : Voltage added to obtain: sum charges =0. * PERX/Y/Z : Yes/no x, y, z periodicity. * PERMX/Y/Z : Yes/no x, y, z mirror periodicity. * PERAX/Y/Z : Yes/no x, y, z axial periodicity. * PERRX/Y/Z : Yes/no x, y, z rotation symmetry * TYPE : Cell type. * ICTYPE : Integer cell type (is more efficient). * SX, SY, SZ : Periodicity in x, y, z (if relevant). * INDSW(I) : Gives the sense wire number for wire I. * NSW : Number of sense wires. * YNMATX,YNMATY: Yes/no dielectricum in x or y (idem). * COMATX,COMATY: Coordinates of dielectricum (idem). * B2SIN : Vector of sinuses for B2 (reduce CPU time). * CORVTA,B,C : CORVTA*X + CORVTB*Y + CORVTC = * potential due to the planes only. * VMIN,VNAX : Range of voltages in the cell. * DOWN : Chamber orientation * POLAR : The cell has cylindrical/polar symmetry. * TUBE : Geometry with wires inside a tube. * VTTUBE : Voltage of the tube. * COTUBE : Radius of the tube. * NTUBE : Number of edges of the tube. * MTUBE : Periodicity in the tube. * KAPPA : Constant used for mappings. * CNALSO : Flag to select only mirror images of a wire * IENBGF : Entry for the background field. * LBGFMP : Background field uses field map. * LDIPOL : Yes/no include dipole terms * BEMSET : neBEM structures available * (Last changed on 20/ 2/09.) *----------------------------------------------------------------------- +KEEP,CELLDATA. CHARACTER*80 CELLID CHARACTER*3 TYPE CHARACTER WIRTYP(MXWIRE),PLATYP(5), - PSLAB1(5,MXPSTR),PSLAB2(5,MXPSTR) LOGICAL YNPLAN(4),PERX,PERY,PERZ,YNPLAX,YNPLAY,YNMATX,YNMATY, - POLAR,TUBE,PERMX,PERMY,PERMZ,PERAX,PERAY,PERAZ, - PERRX,PERRY,PERRZ,CNALSO(MXWIRE),LBGFMP,CELSET,LDIPOL, - BEMSET INTEGER INDSW(MXWIRE),NWIRE,NSW,ICTYPE,MODE,NTUBE,MTUBE, - NXMATT,NYMATT,N3D,NTERMB,NTERMP,IENBGF, - INDPLA(5),NPSTR1(5),NPSTR2(5), - INDST1(5,MXPSTR),INDST2(5,MXPSTR) REAL X(MXWIRE),Y(MXWIRE),V(MXWIRE),E(MXWIRE),D(MXWIRE),W(MXWIRE), - U(MXWIRE),DENS(MXWIRE), - COSPH2(MXWIRE),SINPH2(MXWIRE),AMP2(MXWIRE), - COPLAN(4),VTPLAN(4),XMATT(MXMATT,5),YMATT(MXMATT,5), - X3D(MX3D),Y3D(MX3D),Z3D(MX3D),E3D(MX3D), - DOWN(3),PLSTR1(5,MXPSTR,3),PLSTR2(5,MXPSTR,3), - COTUBE,VTTUBE,B2SIN(MXWIRE),P1,P2,C1, - XMIN,YMIN,ZMIN,XMAX,YMAX,ZMAX,VMIN,VMAX, - COPLAX,COPLAY,COMATX,COMATY, - CORVTA,CORVTB,CORVTC,V0,SX,SY,SZ, - KAPPA COMPLEX ZMULT,WMAP(MXWIRE) COMMON /CELDAT/ ZMULT,WMAP,X,Y,V,E,D,W,U,DENS, - COSPH2,SINPH2,AMP2, - B2SIN,COPLAN,VTPLAN,XMATT,YMATT,X3D,Y3D,Z3D,E3D,DOWN, - PLSTR1,PLSTR2, - XMIN,YMIN,ZMIN,XMAX,YMAX,ZMAX,VMIN,VMAX, - COPLAX,COPLAY,COMATX,COMATY,COTUBE,VTTUBE, - CORVTA,CORVTB,CORVTC,V0,SX,SY,SZ,P1,P2,C1,KAPPA, - INDSW,NWIRE,NSW,ICTYPE,MODE,NXMATT,NYMATT,NTUBE,MTUBE, - N3D,NTERMB,NTERMP,IENBGF, - INDPLA,NPSTR1,NPSTR2,INDST1,INDST2, - YNPLAN,YNPLAX,YNPLAY,YNMATX,YNMATY,PERX,PERY,PERZ, - POLAR,TUBE,PERMX,PERMY,PERMZ,PERAX,PERAY,PERAZ,CNALSO, - PERRX,PERRY,PERRZ,LBGFMP,CELSET,LDIPOL,BEMSET COMMON /CELCHR/ CELLID,WIRTYP,PLATYP,TYPE,PSLAB1,PSLAB2 +KEEP,XSOLIDS,IF=NEVER. *----------------------------------------------------------------------- * SOLIDS - Contains the solids present in the field map, with * reference information for making plots. * PARAMETER : CBUF : Volume descriptions * NSOLID : Number of solids * ISOLTP : Types of solids * ISOLMT : Material of the solid * ICCURR : Location in CBUF to add new elements * IQ, NQ : Lookup information for plot panels * INDSOL(I) : Read-out electrode group for solid I * IWFBEM(I) : BEM pointer for weighting field I * (Last changed on 3/ 4/10.) *----------------------------------------------------------------------- +KEEP,SOLIDS. DOUBLE PRECISION CBUF(MXSBUF) CHARACTER SOLTYP(MXSOLI) INTEGER NSOLID,ISTART(MXSOLI),ISOLTP(MXSOLI),INDSOL(MXSOLI), - ICCURR,IQ(MXPLAN),NQ,ISOLMT(MXSOLI),IWFBEM(MXSW) COMMON /SOLIDS/ CBUF,ISTART,INDSOL,IWFBEM,ISOLTP,NSOLID,ICCURR, - IQ,NQ,ISOLMT COMMON /SOLCHR/ SOLTYP +KEEP,XBEMDATA,IF=NEVER. *----------------------------------------------------------------------- * BEMDAT - Contains reference data for neBEM. * PARAMETER : NBEM : Number of existing panels * IREFB1 : lookup numbers on PLABU1 * BEMSLV : Matrix inversion method, 0 = LU, 1 = SVD * See CELBEM for other descriptions. * (Last changed on 15/ 4/12.) *----------------------------------------------------------------------- +KEEP,BEMDATA. INTEGER NBEM,IREFB1(MXPLAN),NBEMMN,NBEMMX,NBEMPX,NBEMPY,NBEMPZ, - BEMNEW,BEMINV,BEMSLV DOUBLE PRECISION BEMQTH,BEMSTH,BEMSSC,BEMTGT,BEMEPA,BEMEPD LOGICAL LBDUMP COMMON /BEMDAT/ BEMQTH,BEMSSC,BEMSTH,BEMTGT,BEMEPA,BEMEPD, - IREFB1,NBEM,NBEMMN,NBEMMX,NBEMPX,NBEMPY,NBEMPZ,BEMNEW, - BEMINV,BEMSLV,LBDUMP +KEEP,XFIELDMAP,IF=NEVER. *----------------------------------------------------------------------- * FLDMAP - Contains field maps produced by finite element programs * and interpolated in Garfield. * PARAMETER : (XYZ)MAP : Triangles (flag 1) * E(XYZ)MAP : Electric field (flags 2, 3, 4) * VMAP : Potential (flag 5) * B(XYZ)MAP : Magnetic field (flags 6, 7, 8) * MATMAP : Material index (flag 9) * EW(XYZ)MAP : Weighting field (flags 11+, 12+, 13+) * MAPFLG : Availability of the above, 10 = D * ..MIN/MAX : Coordinate range seen in grid * NMAP : Number of elements. * EPSMAT : Dielectric constants * EPSSUR : Surface/volume covered by the medium * NEPS : Number of dielectric constants. * MAPTYP : Element type: * 0 = not yet known * 1 = triangle 1st order * 2 = triangle 2nd order * 3 = curved triangle 2nd order * 4 = 4-node quadrilateral * 5 = 8-node "serendipity" quadrilateral. * 6 = < not yet used > * 7 = tetragon 1st order * 8 = tetragon 2nd order * 9 = tetragon 3rd order * 11 = tetrahedron 1st order * 12 = straight tetrahedron 2nd order * 13 = curved tetrahedron 2nd order * 14 = hexahedron 1st order * 15 = hexahedron 2nd order * 16 = hexahedron 3rd order * MAPORD : Field map interpolation order. * IDRMAT : Drift medium, index into EPSMAT. * NWMAP : Current number of weighting maps. * INDEWS : Conductor group number for the field map. * MATSRC : Origin of the material properties. * ELMDGN : Degenerate elements * LSFDER : Compute Ex, Ey and Ez by derivatives of V * (XYZ)FMOFF : Field map offsets * (Last changed on 9/ 1/09.) *----------------------------------------------------------------------- +KEEP,FIELDMAP. REAL EXMAP,EYMAP,EZMAP,VMAP,EWXMAP,EWYMAP,EWZMAP,VWMAP, - BXMAP,BYMAP,BZMAP, - XMAP,YMAP,ZMAP,XMMIN,XMMAX,YMMIN,YMMAX,ZMMIN,ZMMAX, - XAMIN,XAMAX,YAMIN,YAMAX,ZAMIN,ZAMAX, - VMMIN,VMMAX,EPSMAT,EPSSUR,XFMOFF,YFMOFF,ZFMOFF INTEGER MATMAP,NMAP,NEPS,MAPORD,MAPTYP,IDRMAT,INDEWS, - NWMAP LOGICAL MAPFLG,LMAPPL,SETAX,SETAY,SETAZ,ELMDGN,LSFDER CHARACTER EWSTYP CHARACTER*10 MATSRC COMMON /FLDMAP/ VMAP(MXMAP,10),VWMAP(MXMAP,10,MXWMAP), - EXMAP(MXMAP,10),EYMAP(MXMAP,10),EZMAP(MXMAP,10), - EWXMAP(MXMAP,10,MXWMAP),EWYMAP(MXMAP,10,MXWMAP), - EWZMAP(MXMAP,10,MXWMAP), - BXMAP(MXMAP,10),BYMAP(MXMAP,10),BZMAP(MXMAP,10), - XMAP(MXMAP,10),YMAP(MXMAP,10),ZMAP(MXMAP,10), - XMMIN,XMMAX,YMMIN,YMMAX,ZMMIN,ZMMAX, - XAMIN,XAMAX,YAMIN,YAMAX,ZAMIN,ZAMAX,VMMIN,VMMAX, - XFMOFF,YFMOFF,ZFMOFF, - EPSMAT(MXEPS),EPSSUR(MXEPS),MATMAP(MXMAP), - NMAP,NEPS,MAPORD,MAPTYP,IDRMAT,INDEWS(MXWMAP),NWMAP, - MAPFLG(10+4*MXWMAP),ELMDGN(MXMAP), - LMAPPL,SETAX,SETAY,SETAZ,LSFDER COMMON /FLDCHR/ EWSTYP(MXWMAP),MATSRC +KEEP,XGASDATA,IF=NEVER. *----------------------------------------------------------------------- * GASDAT - Common block containing information on the drift speed * GASCHR in the gas.. * VARIABLES : EGAS[2] : E/p values [V/cm.Torr]. * VGAS[2] : Drift velocity || E [cm/microsec]. * XGAS[2] : Drift velocity || Btrans [cm/microsec]. * YGAS[2] : Drift velocity || ExB [cm/microsec]. * DGAS[2] : Longitudinal diffusion [sqrt(cm*Torr)] * OGAS[2] : Transverse diffusion [sqrt(cm*Torr)]. * AGAS[2] : Townsend coefficient [log(1/cm.Torr)]. * AORIG[2] : Original, non-Penning values of AGAS. * BGAS[2] : Attachment coefficient [log(1/cm.Torr)]. * HGAS[2] : Ion dissociation [log(1/cm.Torr)]. * MGAS[2] : Ion mobility [cm2/V.microsec] * WGAS[2] : Lorentz angle [radian] * SGAS[2] : Diffusion covariance tensor * E,E E,Btrans E,ExB * E,Btrans Btrans,Btrans Btrans,ExB * E,ExB Btrans,ExB ExB,ExB * EXGAS[2] : Excitation rates [THz] * IOGAS[2] : Ionisation rates [THz] * CVGAS : Spline coefficients belonging to VGAS. * CXGAS : Spline coefficients belonging to XGAS. * CYGAS : Spline coefficients belonging to YGAS. * CDGAS : Spline coefficients belonging to DGAS. * COGAS : Spline coefficients belonging to OGAS. * CAGAS : Spline coefficients belonging to AGAS. * CBGAS : Spline coefficients belonging to BGAS. * CHGAS : Spline coefficients belonging to HGAS. * CMGAS : Spline coefficients belonging to MGAS. * CWGAS : Spline coefficients belonging to WGAS. * CSGAS : Spline coefficients belonging to SGAS. * CEXGAS : Spline coefficients belonging to EXGAS. * CIOGAS : Spline coefficients belonging to IOGAS. * NGAS : Number of points in EGAS, VGAS etc. * NEXGAS : Number of excitation rates. * NIOGAS : Number of ionisation rates. * NCSGAS : Number of elastic rates. * DSCEXG : Identification string of excitations. * DSCIOG : Identification string of ionisations. * DSCCSG : Identification string of cross sections. * ICSTYP : Type of cross section, * 1=elastic, 2=ionisation, * 3=attachment, 4=excitation, * 5=super-elastic, 6=inelastic but not exc * PENPRB : Probability an excitation transfers. * PENRMS : Sigma of Penning conversion distance [cm] * PENDT : Time delay of Penning transfer [microsec] * ENIOG : Energy of ionisation state [eV] * ENEXG : Energy of excitation state [eV] * PGAS : Pressure of the gas [Torr]. * TGAS : Temperature of the gas [K]. * Z : 'Nuclear' charge of the gas. * A : 'Atomic' number of the gas. * RHO : Specific weight of the gas. * CMEAN : Average number of clusters per cm. * EMPROB : Most probable energy loss / cm in the gas. * EPAIR : Energy needed to form one ion pair in the * cluster [eV] * GASOK(I) : .TRUE. if present * (1) electron drift velocity || E * (2) ion mobility, * (3) longitudinal diffusion || E * (4) Townsend coefficient, * (5) cluster size distribution. * (6) attachment coefficient, * (7) Lorentz angle, * (8) transverse diffusion || ExB and Bt * (9) electron drift velocity || Bt * (10) electron drift velocity || ExB * (11) diffusion tensor * (12) ion dissociation * (13) allocated for SRIM data (not used) * (14) allocated for HEED data (not used) * (15) excitation rates * (16) ionisation rates * CLSTYP : Cluster size distribution origin. * function, 2 from a table, 3 from A, Z etc. * VEXTR1...4 : Used for drift velocity extrapolation. * XEXTR1...4 : Used for drift velocity extrapolation. * YEXTR1...4 : Used for drift velocity extrapolation. * DEXTR1...4 : Used for diffusion extrapolation. * AEXTR1...4 : Used for Townsend extrapolation. * BEXTR1...4 : Used for attachment coeff. extrapolation. * HEXTR1...4 : Used for ion dissociation extrapolation. * MEXTR1...4 : Used for mobility coeff. extrapolation. * WEXTR1...4 : Used for Lorentz angle extrapolation. * OEXTR1...4 : Used for transverse diff. extrapolation. * SEXTR1...4 : Used for diffusion tensor extrapolation. * EEXTR1...4 : Used for excitation extrapolation * ZEXTR1...4 : Used for ionisation extrapolation * I/JVEXTR : Extrapolate V 0: const, 1: linear, 2:exp. * I/JXEXTR : Extrapolate V 0: const, 1: linear, 2:exp. * I/JYEXTR : Extrapolate V 0: const, 1: linear, 2:exp. * I/JDEXTR : Ex. diffusion 0: const, 1: linear, 2:exp. * I/JAEXTR : Ex. Townsend 0: const, 1: linear, 2:exp. * I/JBEXTR : Ex. attachm. 0: const, 1: linear, 2:exp. * I/JHEXTR : Ex. diss. 0: const, 1: linear, 2:exp. * I/JMEXTR : Ex. mobility 0: const, 1: linear, 2:exp. * I/JWEXTR : Lorentz angle 0: const, 1: linear, 2:exp. * I/JOEXTR : Transv. diff. 0: const, 1: linear, 2:exp. * I/JSEXTR : Diff. tensor 0: const, 1: linear, 2:exp. * I/JEEXTR : Excitations 0: const, 1: linear, 2:exp. * I/JZEXTR : Ionisations 0: const, 1: linear, 2:exp. * I(V/D/A/B/M/W/O/S)METH : Interpolation method: 0=spline, * higher: DIVDIF with order I(...)METH * HEEDOK : Tells whether HEED has been run. * SRIMOK : Tells whether SRIM has been run. * TRIMOK : Tells whether TRIM has been run * GASDEN : Density of the gas in g/l for HEED. * GASFRM : Magboltz gas composition * (Last changed on 3/ 8/10.) *----------------------------------------------------------------------- +KEEP,GASDATA. DOUBLE PRECISION CLSDIS,CLSAVE REAL EGAS,VGAS,XGAS,YGAS,DGAS,AGAS,BGAS,HGAS,MGAS,WGAS,OGAS,SGAS, - EXGAS,IOGAS, - CVGAS,CXGAS,CYGAS,CDGAS,CAGAS,CBGAS,CHGAS,CMGAS,CWGAS,COGAS, - CSGAS,CEXGAS,CIOGAS, - VGAS2,XGAS2,YGAS2,DGAS2,AGAS2,BGAS2,HGAS2,MGAS2,WGAS2,OGAS2, - SGAS2,EXGAS2,IOGAS2, - AORIG,AORIG2,PENPRB,PENRMS,PENDT,ENIOG,ENEXG, - BANG,BTAB, - VEXTR1,VEXTR2,VEXTR3,VEXTR4, - XEXTR1,XEXTR2,XEXTR3,XEXTR4, - YEXTR1,YEXTR2,YEXTR3,YEXTR4, - DEXTR1,DEXTR2,DEXTR3,DEXTR4, - AEXTR1,AEXTR2,AEXTR3,AEXTR4, - BEXTR1,BEXTR2,BEXTR3,BEXTR4, - HEXTR1,HEXTR2,HEXTR3,HEXTR4, - MEXTR1,MEXTR2,MEXTR3,MEXTR4, - WEXTR1,WEXTR2,WEXTR3,WEXTR4, - OEXTR1,OEXTR2,OEXTR3,OEXTR4, - SEXTR1,SEXTR2,SEXTR3,SEXTR4, - EEXTR1,EEXTR2,EEXTR3,EEXTR4, - ZEXTR1,ZEXTR2,ZEXTR3,ZEXTR4, - GASRNG, - Z,A,RHO,CMEAN,EMPROB,EPAIR,PGAS,TGAS,GASDEN, - DTION,DLION,GASFRM,ELOSCS LOGICAL GASOK,TAB2D,GASOPT,HEEDOK,SRIMOK,TRIMOK,GASSET INTEGER NGAS,NCLS,NBANG,NBTAB,NFTAB,NFCLS, - IVMETH,IXMETH,IYMETH,IDMETH,IAMETH,IBMETH,IHMETH,IMMETH, - IWMETH,IOMETH,ISMETH,IEMETH,IZMETH, - IVEXTR,IXEXTR,IYEXTR,IDEXTR,IAEXTR,IBEXTR,IHEXTR,IMEXTR, - IWEXTR,IOEXTR,ISEXTR,IEEXTR,IZEXTR, - JVEXTR,JXEXTR,JYEXTR,JDEXTR,JAEXTR,JBEXTR,JHEXTR,JMEXTR, - JWEXTR,JOEXTR,JSEXTR,JEEXTR,JZEXTR, - IATHR,IBTHR,IHTHR, - NEXGAS,NIOGAS,NCSGAS,ICSTYP CHARACTER*80 GASID CHARACTER*(MXCHAR) FCNTAB,FCNCLS CHARACTER*10 CLSTYP CHARACTER*45 DSCEXG(MXEXG),DSCIOG(MXIOG),DSCCSG(MXCSG) COMMON /GASDAT/ CLSDIS(MXPAIR),CLSAVE, - EGAS(MXLIST), - VGAS(MXLIST),XGAS(MXLIST),YGAS(MXLIST),WGAS(MXLIST), - DGAS(MXLIST),OGAS(MXLIST),AGAS(MXLIST),BGAS(MXLIST), - HGAS(MXLIST),MGAS(MXLIST),SGAS(MXLIST,6), - EXGAS(MXLIST,MXEXG),IOGAS(MXLIST,MXIOG), - CVGAS(MXLIST),CXGAS(MXLIST),CYGAS(MXLIST),CWGAS(MXLIST), - CDGAS(MXLIST),COGAS(MXLIST),CAGAS(MXLIST),CBGAS(MXLIST), - CHGAS(MXLIST),CMGAS(MXLIST),CSGAS(MXLIST,6), - CEXGAS(MXLIST,MXEXG),CIOGAS(MXLIST,MXIOG), - VGAS2(MXLIST,MXBANG,MXBTAB),WGAS2(MXLIST,MXBANG,MXBTAB), - XGAS2(MXLIST,MXBANG,MXBTAB),YGAS2(MXLIST,MXBANG,MXBTAB), - AGAS2(MXLIST,MXBANG,MXBTAB),BGAS2(MXLIST,MXBANG,MXBTAB), - DGAS2(MXLIST,MXBANG,MXBTAB),OGAS2(MXLIST,MXBANG,MXBTAB), - HGAS2(MXLIST,MXBANG,MXBTAB),MGAS2(MXLIST,MXBANG,MXBTAB), - SGAS2(MXLIST,MXBANG,MXBTAB,6), - EXGAS2(MXLIST,MXBANG,MXBTAB,MXEXG), - IOGAS2(MXLIST,MXBANG,MXBTAB,MXIOG), - AORIG(MXLIST),AORIG2(MXLIST,MXBANG,MXBTAB), - PENPRB(MXEXG),PENRMS(MXEXG),PENDT(MXEXG), - ENIOG(MXIOG),ENEXG(MXEXG), - BANG(MXBANG),BTAB(MXBTAB), - GASRNG(20,2),GASFRM(MXNBMC),ELOSCS(MXCSG), - Z,A,RHO,CMEAN,EMPROB,EPAIR,PGAS,TGAS,GASDEN, - DTION,DLION, - VEXTR1,VEXTR2,VEXTR3,VEXTR4, - XEXTR1,XEXTR2,XEXTR3,XEXTR4, - YEXTR1,YEXTR2,YEXTR3,YEXTR4, - DEXTR1,DEXTR2,DEXTR3,DEXTR4, - AEXTR1,AEXTR2,AEXTR3,AEXTR4, - BEXTR1,BEXTR2,BEXTR3,BEXTR4, - HEXTR1,HEXTR2,HEXTR3,HEXTR4, - MEXTR1,MEXTR2,MEXTR3,MEXTR4, - WEXTR1,WEXTR2,WEXTR3,WEXTR4, - OEXTR1,OEXTR2,OEXTR3,OEXTR4, - SEXTR1(6),SEXTR2(6),SEXTR3(6),SEXTR4(6), - EEXTR1(MXEXG),EEXTR2(MXEXG),EEXTR3(MXEXG),EEXTR4(MXEXG), - ZEXTR1(MXIOG),ZEXTR2(MXIOG),ZEXTR3(MXIOG),ZEXTR4(MXIOG), - IVMETH,IXMETH,IYMETH,IDMETH,IAMETH,IBMETH,IHMETH,IMMETH, - IWMETH,IOMETH,ISMETH,IEMETH,IZMETH, - IVEXTR,IXEXTR,IYEXTR,IDEXTR,IAEXTR,IBEXTR,IHEXTR,IMEXTR, - IWEXTR,IOEXTR,ISEXTR,IEEXTR,IZEXTR, - JVEXTR,JXEXTR,JYEXTR,JDEXTR,JAEXTR,JBEXTR,JHEXTR,JMEXTR, - JWEXTR,JOEXTR,JSEXTR,JEEXTR,JZEXTR, - NGAS,NCLS,NBANG,NBTAB,NFTAB,NFCLS, - IATHR,IBTHR,IHTHR, - NEXGAS,NIOGAS,NCSGAS,ICSTYP(MXCSG), - GASOK(20),GASOPT(20,4), - TAB2D,HEEDOK,SRIMOK,TRIMOK,GASSET COMMON /GASCHR/ FCNTAB,FCNCLS,CLSTYP,GASID,DSCEXG,DSCIOG,DSCCSG +KEEP,GASMIXDATA. *----------------------------------------------------------------------- * GMXDAT - Common block for gas mixing. * (Last changed on 20/ 2/97.) *----------------------------------------------------------------------- REAL BREAK,FRAC,XLOSCH,EFLD,ESTEP,ECRIT INTEGER NBREAK COMMON /GMXDAT/ BREAK(MXLIST),FRAC(MXFRAC),XLOSCH, - EFLD,ESTEP,ECRIT,NBREAK +KEEP,XSRIMDATA,IF=NEVER. *----------------------------------------------------------------------- * SRMDAT - Data for SRIM generation of clusters * PARAMETER : NSRIM : Number of points in dE/dx tables * ESRIM : Energy in energy loss table [MeV] * SRMEM : EM energy loss [MeV cm2/g] * SRMHD : Hadronic energy loss [MeV cm2/g] * SRMDEN : Density of material [g/cm3] * Maintained equal to /GASDAT/ RHO * SRMRNG : Range [cm] * SRMDL : Longitudinal straggling [cm] * SRMDT : Transverse straggling [cm] * WSRIM : Work needed for 1 e- [eV] * FSRIM : Fano factor * NCSRIM : Number of clusters produced * [X/Y/Z]SRIM: Cluster locations * ECSRIM: : CLuster energies * NESRIM : Cluster size * EKSRIM : Current kinetic energy * (Last changed on 27/ 6/07.) *----------------------------------------------------------------------- +KEEP,SRIMDATA. REAL SRMDEN,ESRIM,SRMEM,SRMHD,SRMRNG,SRMDT,SRMDL,WSRIM,FSRIM, - XSRIM,YSRIM,ZSRIM,ECSRIM,EKSRIM INTEGER NSRIM,NCSRIM,NESRIM COMMON /SRMDAT/ - ESRIM(MXLIST),SRMEM(MXLIST), - SRMHD(MXLIST),SRMRNG(MXLIST),SRMDT(MXLIST),SRMDL(MXLIST), - XSRIM(MXCLUS),YSRIM(MXCLUS),ZSRIM(MXCLUS),ECSRIM(MXCLUS), - EKSRIM(MXCLUS),SRMDEN,WSRIM,FSRIM, - NSRIM,NCSRIM,NESRIM(MXCLUS) +KEEP,XTRIMDATA,IF=NEVER. *----------------------------------------------------------------------- * TRMDAT - Data for TRIM generation of clusters. Part of the TRIMCAT * Module. * PARAMETER : NTRIM : The number of records for the ion read in * WTRIM : The work function * FTRIM : The Fano-factor * ITRIM : The number of the ion * NCTRIM : The number of clusters * LTRIM : The layer number of the gas volume * TRMLMN : The minimum x-coordinate of the gas volume * layer * TRMLMX : The maximum x-coordinate of the gas volume * layer * TRMDEN : The density of the gas from TRIM * TRMEMI : EM energy loss * TRMHDI : HD energy loss * TRMTGD : TRIM target depth * TRMIOE : TRIM ion energy * TRMY : Corresponding Y location of the ion * TRMZ : Corresponding Z location of the ion * [X/Y/Z]TRIM: Cluster locations * ECTRIM: : CLuster energies * NETRIM : Cluster size * EKTRIM : Current kinetic energy * AUTHOR: James Butterworth (York) * (Last changed on 12/09/08.) *----------------------------------------------------------------------- +KEEP,TRIMDATA. REAL WTRIM, FTRIM, TRMLMN, TRMLMX, TRMDEN, TRMEMI, - TRMTGD, TRMIOE, ECTRIM, EKTRIM, XTRIM, YTRIM, ZTRIM, NETRIM, - TRMHDI, TRMY, TRMZ INTEGER NTRIM, NCTRIM, LTRIM, ITRIM COMMON /TRMDAT/ - NTRIM, NCTRIM, WTRIM, FTRIM, LTRIM, TRMLMN, TRMLMX, TRMDEN, - TRMEMI(MXLIST), TRMHDI(MXLIST), TRMTGD(MXLIST), - TRMIOE(MXLIST), TRMY(MXLIST), TRMZ(MXLIST), - XTRIM(MXCLUS), YTRIM(MXCLUS), ZTRIM(MXCLUS), ECTRIM(MXCLUS), - EKTRIM(MXCLUS), NETRIM(MXCLUS), ITRIM +KEEP,XCAPACMATRIX,IF=NEVER. *----------------------------------------------------------------------- * MATRIX - Common block storing various large double precision arrays * such as the capacitance matrices, a drift time tabel etc. * VARIABLES : A : The elements I=1,NWIRE J=1,NWIRE form the * capacitance matrix, the row and colom at * NWIRE+1 are used to make sure the total * charge is zero, the last colom is working * space for routine DEQINV. (Valid for the * capacitance matrices only). *----------------------------------------------------------------------- +KEEP,CAPACMATRIX. DOUBLE PRECISION A COMMON /MATRIX/ A(MXWIRE+1,MXWIRE+3) +KEEP,XBFIELD,IF=NEVER. *----------------------------------------------------------------------- * MAGDAT - Common block storing the information on the magnetic field. * VARIABLES : SUSWIR : Magn. permeability of wire material. * SUSGAS : " " " gas. * ALFA : (SUSWIR-SUSGAS)/(SUSWIR+SUSGAS). * B0X,B0Y,B0Z: Magnetic field components. * MAGOK : Indicates that a magnetic field is present. * MAGSRC : 0 = no field, 1 = above, 2 = field map * IB[XYZ]TYP : 0 = not set, 1 = fixed value, 2 = formula, * 3 = matrix interpolation. * (Last changed on 29/ 2/00.) *----------------------------------------------------------------------- +KEEP,BFIELD. LOGICAL MAGOK REAL ALFA,B0X,B0Y,B0Z,SUSWIR,SUSGAS,BSCALE,BFMIN,BFMAX, - BFXMIN,BFYMIN,BFZMIN,BFXMAX,BFYMAX,BFZMAX INTEGER MAGSRC, - IBXTYP,IBYTYP,IBZTYP, - IRB0X,IRB0Y,IRB0Z,IRV0X,IRV0Y,IRV0Z, - IENB0X,IENB0Y,IENB0Z,IBXDIR,IBYDIR,IBZDIR, - NCB0X,NCB0Y,NCB0Z CHARACTER*(MXCHAR) FUNB0X,FUNB0Y,FUNB0Z COMMON /MAGDAT/ ALFA,SUSWIR,SUSGAS, - B0X,B0Y,B0Z,BSCALE,BFMIN,BFMAX, - BFXMIN,BFYMIN,BFZMIN,BFXMAX,BFYMAX,BFZMAX, - MAGSRC,IBXTYP,IBYTYP,IBZTYP, - IRB0X,IRB0Y,IRB0Z,IRV0X,IRV0Y,IRV0Z, - IENB0X,IENB0Y,IENB0Z,IBXDIR,IBYDIR,IBZDIR, - NCB0X,NCB0Y,NCB0Z, - MAGOK COMMON /MAGCHR/ FUNB0X,FUNB0Y,FUNB0Z +KEEP,XDRIFTLINE,IF=NEVER. *----------------------------------------------------------------------- * DRFDAT - Common block giving full information on one drift line * this common block is used for the communication between the * routine calculating drift lines (DLCALC) and others needing * this information (such as : DRFWIR, DRFEDG, DRFTRA etc). * VARIABLES : XU : x-coordinates of the drift line * YU : y-coordinates of the drift line * TU : t-coordinates of the drift line * NU : number of points on the drift line * ISTAT : way the particle ends its life: * ISTAT= 0 calculation still in progress * -1 left the drift area * -2 needed more than MXLIST steps * -3 stopped, returned, abandonned etc. * -4 hit a plane * n ( 0MXWIRE ) hit replica wire n * ISTAT1-6 : ISTAT's for leaving via various edges * IPTYPE : Particle type 0=unknown, 1=electron, 2=ion * IPTECH : Technique 1=RKF, 2=MC, 3=vacuum, 4=micro * QPCHAR : Particle charge * DXMIN,DXMAX: x-range of drift area, * DYMIN,DYMAX: y-range of drift area. * MXDIFS, MXTWNS, MXATTS: Maximum stack depths. * LREPSK : Check only attracting wires. * RDF2 : Distance to switch L+T diff integration * MDF2 : L+T integration method when reaching wire * MDF2 = 0 no special treatment * = 1 full integration of the cloud * = 2 integration with constant velocity * = 3 project longitudinal dimension * = 4 project largest dimension * TMC : MC drift line step time. * DMC : MC drift line step distance. * NMC : Number of collisions to be skipped. * MCMETH : MC integration method, * = 0 constant time steps * = 1 constant distance steps * = 2 collision time based steps * EPSDIF : Maximum error made while solving diff. eq. * RTRAP : A particle found within RTRAP wire radii * is considered to be trapped. * STMAX : Maximum step length. * EPSDFI : Accuracy diffusion integration. * MXDIFS : Maximum stack depth diffusion integration. * EPSTWI : Accuracy Townsend integration. * MXTWNS : Maximum stack depth Townsend integration. * LAVPRO : Avalanche over projected drift path. * EPSATI : Accuracy attachment integration. * MXATTS : Maximum stack depth attachment integration. * EQTTHR : Maximum relative distance between equal * time contour points to be joined. * EQTASP : Aspect ratio threshold to classify an * isochron as circle or straight line * EQTCLS : Maximum relative distance for an isochron * to be closed * LEQSRT : Sort isochrons * LEQCRS : Check for drift line - isochron crossings * LEQMRK : Mark rather than draw isochrons * DSCMIN : Smallest allowed diffusion scaling * DSCMAX : Largest allowed diffusion scaling * (Last changed on 31/ 1/02.) *----------------------------------------------------------------------- +KEEP,DRIFTLINE. DOUBLE PRECISION XU,YU,ZU,TU,XTARG,YTARG,TMC,DMC REAL DXMIN,DYMIN,DZMIN,DXMAX,DYMAX,DZMAX,DTARG,EPSDFI,EPSTWI, - EPSATI,RDF2,DSCMIN,DSCMAX, - DDXMIN,DDXMAX,DDYMIN,DDYMAX,DDZMIN,DDZMAX,EPSDIF,RTRAP, - STMAX,EQTTHR,EQTASP,EQTCLS,QPCHAR INTEGER NU,ISTAT,ITARG,MXDIFS,MXTWNS,MXATTS,MDF2, - ISTAT1,ISTAT2,ISTAT3,ISTAT4,ISTAT5,ISTAT6,NMC,MCMETH, - IPTYPE,IPTECH LOGICAL LREPSK,LKINK,LSTMAX,LEQSRT,LEQCRS,LEQMRK,LAVPRO COMMON /DRFDAT/ XU(MXLIST),YU(MXLIST),ZU(MXLIST),TU(MXLIST), - XTARG,YTARG,TMC,DMC,DTARG, - DXMIN,DYMIN,DZMIN,DXMAX,DYMAX,DZMAX, - DDXMIN,DDXMAX,DDYMIN,DDYMAX,DDZMIN,DDZMAX, - EQTTHR,EQTASP,EQTCLS,QPCHAR, - RTRAP,STMAX,EPSDIF,EPSDFI,EPSTWI,EPSATI,RDF2,DSCMIN,DSCMAX, - MDF2, - MXDIFS,MXTWNS,MXATTS, - NU,ISTAT,ITARG, - ISTAT1,ISTAT2,ISTAT3,ISTAT4,ISTAT5,ISTAT6,NMC,MCMETH,IPTYPE, - IPTECH,LREPSK,LKINK,LSTMAX,LEQSRT,LEQCRS,LEQMRK,LAVPRO +KEEP,XMCAMAT,IF=NEVER. *----------------------------------------------------------------------- * MCAMAT - Common block containing avalanche data. * and numerical calculations. * VARIABLES : X/Y/ZLIST : Starting points of electrons * TLIST : Starting times of electrons * ELIST : Starting energy of the electrons * NLIST : Number of electrons at this point * X/Y/ZELIST : End points of electrons * TELIST : End times of electrons * ISLIST : Status code * NMCA : Number of entries in the list * (Last changed on 29/ 5/08.) *----------------------------------------------------------------------- +KEEP,MCAMAT. REAL XLIST(MXMCA),YLIST(MXMCA),ZLIST(MXMCA),TLIST(MXMCA), - ELIST(MXMCA), - XELIST(MXMCA),YELIST(MXMCA),ZELIST(MXMCA),TELIST(MXMCA) INTEGER NLIST(MXMCA),ISLIST(MXMCA),NMCA COMMON /MCAMAT/ XLIST,YLIST,ZLIST,TLIST,ELIST, - XELIST,YELIST,ZELIST,TELIST,NLIST,ISLIST,NMCA +KEEP,XSIGNALDATA,IF=NEVER. *----------------------------------------------------------------------- * SIGDAT - Common block containing details on the track of the charged * SIGCHR particle through the chamber as well as on the clusters it * produced. It stores the signal induced on the sense wires. * VARIABLES : TPAIR : Arrival time of an electron in a cluster. * QPAIR : Multiplication caused by an electron. * IPAIR(I) : First electron from cluster I * ICLUST(I) : ISTAT code for cluster I * TSTART : First time in signal simulation * TDEV : Time resolution in signal simulation * NTIME : Number of signal time points * NORIA : Number of ion angles * AVALAN : Multiplication factor for avalanches and * its relative standard deviation * AVATYP : Avalanche model. * SIGNAL(I,J,K):Signal at TSTART+I*TDEV on sense wire J * (direct if K=1, indirect if K=2) * FPERX : yes/no x-convolution for ion tails * FPERY : yes/no y-convolution for ion tails * FCELTP : type of the cell stripped of periodicity * MFEXP,NFOUR: 2**MFEXP = NFOUR (# Fourier terms) * MXMIN,MXMAX: Lowest, highest Fourier term in x * MYMIN,MYMAX: Lowest, highest Fourier term in y * LCROSS : .TRUE. if cross induced signals are present * LITAIL : Simple ion tail (angular sampling) * LRTAIL : Simple ion tail (no angular sampling) * LDTAIL : Detailed ion tail * LEPULS : Electron pulse * LIPULS : Signal due to primary ions * SIGSET : Ready for signal calculations. * RESSET : Time resolution has been set. * JIORD : Signal interpolation order * NISIMP : Signal Simpson integration points * NMQUAD : Microscopic tracking weighting field * intergration (0 = mean, 1 = 6-point Gauss) * (Last changed on 28/ 7/08.) *----------------------------------------------------------------------- +KEEP,SIGNALDATA. LOGICAL FPERX,FPERY,LCROSS,TRASET,TRAFLG,LITAIL,LDTAIL,LRTAIL, - LEPULS,LIPULS,SIGSET,RESSET INTEGER NPAIR,ICLUST,NFOUR,MFEXP,MXMIN,MXMAX, - MYMIN,MYMAX,NTRBNK,ITRMAJ,NTIME,NORIA, - NASIMP,JIORD,NISIMP,NMQUAD,NCANG,IENANG REAL TIMSIG,SIGNAL,TCLUST,SCLUST,ACLUST,BCLUST,FCLUST, - AVALAN,TSTART,TDEV,PRSTHR, - TRABNK,TRAVEC CHARACTER*(MXCHAR) FCNANG CHARACTER*12 AVATYP CHARACTER*3 FCELTP COMMON /SIGDAT/ TIMSIG(MXLIST),SIGNAL(MXLIST,MXSW,2), - AVALAN(2),TRAVEC(MXLIST), - TRABNK(MXLIST,9),TSTART,TDEV,PRSTHR, - TCLUST,SCLUST,ACLUST,BCLUST,FCLUST,ICLUST,NPAIR, - NFOUR,ITRMAJ,JIORD,NISIMP,NMQUAD,IENANG,NTIME,NORIA, - MFEXP,MXMIN,MXMAX,MYMIN,MYMAX,NTRBNK,NASIMP,NCANG, - TRASET,TRAFLG(9),FPERX,FPERY,LCROSS,LITAIL,LDTAIL,LRTAIL, - LEPULS,LIPULS,SIGSET,RESSET COMMON /SIGCHR/ FCELTP,AVATYP,FCNANG +KEEP,XSIGNALMATRIX,IF=NEVER. *----------------------------------------------------------------------- * MATRIX - Signal matrix + working arrays (stored on the same place as * the capacitance matrix - similar structure). * VARIABLES : SIGMAT : A layer of wire signal matrices. * QPLANE : A layer of plane signal matrices. * WORK : Working space for matrix inversions. * DUMMY : Fills the common block. * (Last changed on 13/ 4/99.) *----------------------------------------------------------------------- +KEEP,SIGNALMATRIX. COMPLEX SIGMAT REAL QPLANE,EWXCOR,EWYCOR INTEGER IWORK,DUMMY COMMON /MATRIX/ SIGMAT(MXWIRE,MXWIRE),QPLANE(5,MXWIRE), - IWORK(MXWIRE),DUMMY(2*MXWIRE+6) COMMON /SPLDAT/ EWXCOR(5),EWYCOR(5) +KEEP,XSHAPEDATA,IF=NEVER. *----------------------------------------------------------------------- * SHPDAT - Common blocks used by the wire sag routines. * VARIABLES : FX, FY : Force as function of wire displacement * XSCAN, YSCAN: Wire displacements (abscissa of FX, FY) * NSCANX/Y : Number of points in FX, FY, XSCAN, YSCAN * JSORD : Force table interpolation order * NITMAX : Maximum # of zero search iterations * EPS : Used for building differential matrices * EPSX : Positional convergence criterion * EPSF : Function value convergence criterion * STEP : Step size used by DRKNYS * NSHOT : Number of shots * NSTEP : Number of steps per shot * IW : Wire currently studied * LFWARN : Point found outside scanning grid * LFEXTR : Permission to extrapolate force table * LFELEC : Include or not electrostatics * LFGRAV : Include or not gravity * LZROPR : Print zero search progress * LFITER : Iterate over all wires * NFITER : Maximum number of all wire iterations * (XORIG,YORIG) Nominal wire positions * (XOFF,YOFF) : Wire position offsets * (XWIRE,YWIRE) Nominal position of the current wire * (Last changed on 3/ 7/96.) *----------------------------------------------------------------------- +KEEP,SHAPEDATA. DOUBLE PRECISION FX(MXGRID,MXGRID),FY(MXGRID,MXGRID), - XSCAN(MXGRID),YSCAN(MXGRID),EPS,EPSX,EPSF,STEP REAL XORIG(MXWIRE),YORIG(MXWIRE),XOFF(MXWIRE),YOFF(MXWIRE) INTEGER NITMAX,NSHOT,NSTEP,IW,NSCANX,NSCANY,JSORD,NFITER LOGICAL LFGRAV,LFELEC,LFEXTR,LFWARN,LZROPR,LFITER COMMON /SHPDAT/ FX,FY,XSCAN,YSCAN,EPS,EPSX,EPSF,STEP, - XORIG,YORIG,XOFF,YOFF, - NITMAX,NSHOT,NSTEP,IW,NSCANX,NSCANY,JSORD,NFITER, - LFGRAV,LFELEC,LFEXTR,LFWARN,LZROPR,LFITER +KEEP,XINPUT,IF=NEVER. *----------------------------------------------------------------------- * INPCOM - Common blocks used by the input routines to store the input * INPCHR line and some related information. * VARIABLES : NCHAR(I) : Number of characters in word I. * INDWRD(I) : Index in string of word I. * ERRCDE(I) : Error code for word I. * NWORD : Number of words not > MXWORD. * STRING : The input line. * PROMPT : Prompt string (printed if LPROM is .TRUE.) * LUN : Logical unit from which input is read. * ICHSET : 0: character set ?, 1: ASCII, 2: EBCDIC * LINREC : Input recording on/off. * ARGSTR : String with input file arguments. * EOFSTR : EOF marker string. * LUNSTR : Input reference, 1=file, 2=EOF, 3=args * FNINP : Alternate input file, length: NCFNI * FNOUT : Alternate output file, length: NCFNO * (Last changed on 28/ 1/06.) *----------------------------------------------------------------------- +KEEP,INPUT. CHARACTER*(MXINCH+1) STRING CHARACTER*(MXINCH) ARGSTR CHARACTER*30 ERRCDE(MXWORD) CHARACTER*(MXCHAR) WORD(MXWORD) CHARACTER*80 PROMPT,EOFSTR,SHELL CHARACTER ESCAPE CHARACTER*(MXNAME) FNINP,FNOUT INTEGER NCHAR(MXWORD),INDWRD(MXWORD),ICHSET,LUNSTR(5:MXLUN,3), - NWORD,LUN,NCPROM,NCEOF,NCSH,NCARG,NCFNI,NCFNO LOGICAL ERRPRT(MXWORD),LPROM,DOEXEC,DOREAD,LINREC COMMON /INPCOM/ NCHAR,INDWRD,LUNSTR,NWORD,LUN,ICHSET,NCPROM, - ERRPRT,LPROM,DOEXEC,DOREAD,NCEOF,LINREC,NCSH,NCARG, - NCFNI,NCFNO COMMON /INPCHR/ ERRCDE,STRING,WORD,PROMPT,EOFSTR,ESCAPE,SHELL, - ARGSTR,FNINP,FNOUT +KEEP,XALGDATA,IF=NEVER. *----------------------------------------------------------------------- * ALGDAT - Common block containing the executable statements for the * evaluation of symbolic expressions. * VARIABLES : INS(I, . ) : List of instructions, the first element is * a register address (in case of a normal * operation) or a function descriptor, the * second is the operator, the third an addres * and the fourth the address of the result. * NINS : Number of instructions in INS. * REG(I) : Contents of register I, REG(0)=0, REG(-1)=1 * and REG(-2)=2, REG(-3)=pi. * NREG : Number of registers in use. * EXEC(I) : .TRUE. if instruction I is to be executed. * NERR : Number of errors since last call to ALGPRE. * NAERR : Individual error counts. * NRES : Number of independent results. * ALGENT(I,.): Instruction list entry refernce table. * 1: reference no, 2: in use 0/1, 3: can be * executed 0/1, 4: sequential 0/1, 5: first * instruction, 6: no of instructions, 7: no * of variables, 8: first constant, 9: no of * constants, 10: no of results. * ARGREF(I,1): Modification flag for arguments, * 0: modifiable global variable, * 1: modifiable non-global variable, * 2: non-modifiable global variable, * 3: non-modifiable non-global variable. * ARGREF(I,2): Origin of each argument. * NALGE : Number of entries in use in ALGENT. * ISYNCH : 0: no check, 1: algebra, 2: procedure * LIGUND : Ignore exponential underflow * LINUND : Ignore underflow on input * EXPMAX : Threshold for exponential under/overflow * (Last changed on 27/11/10.) *----------------------------------------------------------------------- +KEEP,ALGDATA. INTEGER INS(MXINS,4),ALGENT(MXALGE,10),MODREG(MXCONS:MXREG), - ISYNCH,IINS0,ICONS0,ARGREF(MXARG,2),MODARG(MXARG), - NREG,NCONS,NINS,NERR,NRES,NALGE,IENTRL,NAERR(100) REAL REG(MXCONS:MXREG),ARG(MXARG),EXPMAX PARAMETER(EXPMAX=40.0) LOGICAL EXEC(MXINS),LIGUND,LINUND COMMON /ALGDAT/ REG,ARG,MODARG,ARGREF,INS,MODREG,ALGENT, - NREG,NCONS,NINS,NERR,NAERR, - NRES,NALGE,IENTRL,ISYNCH,IINS0,ICONS0,EXEC,LIGUND,LINUND +KEEP,XZERODATA,IF=NEVER. *----------------------------------------------------------------------- * ZRODAT - Common block containing the information about the zeros. * VARIABLES : XZ(I),YZ(I) : Location of the zeros * PZ(I) : Orientation angle (in radians) of zero I * NZ : Number of zeros * NFC : Number of function calls needed. * DAMIN, DAMAX: * DPMIN, DPMAX: * (Last changed on 8/ 9/98.) *----------------------------------------------------------------------- +KEEP,ZERODATA. LOGICAL ZROSET REAL XZ,YZ,PZ,DPMIN,DPMAX,DAMIN,DAMAX,EMIN INTEGER NZ,NFC COMMON /ZRODAT/ XZ(MXZERO),YZ(MXZERO),PZ(MXZERO),NZ,NFC, - DPMIN,DPMAX,DAMIN,DAMAX,EMIN,ZROSET +KEEP,XOPTDATA,IF=NEVER. *----------------------------------------------------------------------- * OPTDAT - Common blocks storing some optimisation data, mainly * OPTCHR shared in view of the minimisation itself. * (Last changed on 20/10/99.) *----------------------------------------------------------------------- +KEEP,OPTDATA. CHARACTER*(MXCHAR) FUNFLD,FUNPOS,FUNWGT CHARACTER*10 VALTYP,PNTTYP REAL VST(MXWIRE),VPLST(5) LOGICAL EVALT,EVALD,EVALA INTEGER NPOINT,NSWIRE,IOPT,NFLD,NPOS,NWGT,IENFLD,IENPOS,IENWGT COMMON /OPTDAT/ VST,VPLST,NPOINT,NSWIRE,IOPT,NFLD,NPOS,NWGT, - IENFLD,IENPOS,IENWGT,EVALT,EVALD,EVALA COMMON /OPTCHR/ FUNFLD,FUNPOS,FUNWGT,VALTYP,PNTTYP +KEEP,XTHRESHDATA,IF=NEVER. *----------------------------------------------------------------------- * THRDAT - Common block storing some threshold data. * VARIABLES : NCSMAX : Maximum cluster size. * NCMIN, NCMAX: Minimum resp maximum number of clusters. * CMIK(I,K) : The probability that the M'th electron is * the I'th electron from cluster K. * YTHMIN, MAX : y-Range from where particles reach a wire. * XTHR : Starting point of the drift lines. * PRCLUS(N) : Probability of having N clusters in all. * PRSIZE(N) : Probability a cluster consists of N pairs. * TMIN,TMAX : Time range of the arrivals. *----------------------------------------------------------------------- +KEEP,THRESHDATA,IF=NEVER. REAL CMIK(MXPAIR,MXCLUS),PRCLUS(0:MXCLUS),PRSIZE(0:MXPAIR) COMMON /THRDAT/ CMIK,PRCLUS,PRSIZE,YTHMIN,YTHMAX,XTHR,TMIN,TMAX, - NCMIN,NCMAX,NCSMAX +KEEP,XASTCOM,IF=NEVER. *----------------------------------------------------------------------- * ASTCOM - Stores various quantities being used for control_C * interception on a Vax. (For information, contact * Carlo Mekenkamp, MEKENKAM@HLERUL5.) *----------------------------------------------------------------------- +KEEP,ASTCOM. IMPLICIT NONE COMMON /ASTCOM/ CHAN, ASTIP, ASTCS VOLATILE CHAN, ASTIP, ASTCS INTEGER*4 CHAN LOGICAL*4 ASTIP,ASTCS +KEEP,XGRAPHICS,IF=NEVER. *----------------------------------------------------------------------- * GRADAT - Common block storing some data relevant for graphics. * VARIABLES : LGRID : Plot grid lines. * LGRALL : Complete or decades-only grid * LOGX : Plot x-axis on logarithmic scale. * LOGY : Plot y-axis on logarithmic scale. * STAMP : Stamp placed on plots when complete. * LSTAMP : Put a time stamp on the plots. * LWAITB : Wait before a plot is made. * LWAITA : Wait after a plot has been made. * LGCLRB : Clear graphics window before a plot. * LGCLRA : Clear graphics window after a plot. * LXCCH : Execute control characters. * LGLCLP : Clip lines * LGMCLP : Clip markers * LGACLP : Clip areas * LGTCLP : Clip text * WKNAME : Name of the workstations. * WKATTR : Attributes - not yet used. * WKLUN : Logical unit associated with a workstation * WKFREF : Pointer for file name used by STRBUF. * WKCON : Connection identifier of a workstation. * WKID : Workstation type of a workstation. * WKSTAT : Workstation state: 0 - not known * 1 - defined, 2 - open, 3 - active. * WKSREQ : Requested workstation state * WKMULT : Multiple-frame or single frame file. * USERXn/Yn : WC of the whole plot * FRX/YMINMAX : WC of the box * GPXN : Distance between x-axis and numbers * GPXN10 : Distance between x-axis and powers of 10 * GPYN : Distance between y-axis and numbers * GPYN10 : Distance between y-axis and powers of 10 * GPXL : Distance between x-frame and label * GPYL : Distance between y-frame and label * GPXT : Distance between x-frame and title * DISPX0 : (Like .X1, .Y0 and .Y1) viewport. * IGHIST : Sequence number of the histogram * IGBAR : Sequence number of the bar chart * ARRANG : Arrow top angle * ARRLEN : Relative arrow tip length * BARFRC : Fraction of bin width to be plotted * GKSLOG : Name of GKS error logging file * NCGKS : Length of GKS error logging file name * (Last changed on 17/ 5/08.) *----------------------------------------------------------------------- +KEEP,GRAPHICS. REAL USERX0,USERX1,USERY0,USERY1,FRXMIN,FRXMAX,FRYMIN,FRYMAX, - ARRANG,ARRLEN,BARFRC,DISPX0,DISPX1,DISPY0,DISPY1, - GPXN,GPXN10,GPYN,GPYN10,GPXL,GPYL,GPXT LOGICAL LGRID,LGRALL,LOGX,LOGY,LSTAMP,LGCLRB,LGCLRA, - LWAITA,LWAITB,LXCCH,LGLCLP,LGMCLP,LGACLP,LGTCLP, - WKMULT(MXWKLS) INTEGER NWK,WKID(MXWKLS),WKCON(MXWKLS),WKFREF(MXWKLS), - WKLUN(MXWKLS),WKSTAT(MXWKLS),WKSREQ(MXWKLS), - NCWKNM(MXWKLS),NCSTMP,IGHIST,IGBAR,NCGKS CHARACTER*20 WKNAME(MXWKLS),WKATTR(MXWKLS) CHARACTER*80 STAMP CHARACTER*(MXNAME) GKSLOG COMMON /GRADAT/ USERX0,USERX1,USERY0,USERY1,ARRANG,ARRLEN, - BARFRC, - FRXMIN,FRXMAX,FRYMIN,FRYMAX,DISPX0,DISPX1,DISPY0,DISPY1, - GPXN,GPXN10,GPYN,GPYN10,GPXL,GPYL,GPXT, - LGRID,LGRALL,LOGX,LOGY,LSTAMP,LGCLRB,LGCLRA,LWAITA,LWAITB, - LXCCH,LGLCLP,LGMCLP,LGACLP,LGTCLP, - NWK,WKID,WKCON,WKFREF,WKLUN,WKSTAT,WKSREQ,NCWKNM,NCSTMP, - IGHIST,IGBAR,NCGKS,WKMULT COMMON /GRACHR/ WKNAME,WKATTR,STAMP,GKSLOG +KEEP,XCONTDATA,IF=NEVER. *----------------------------------------------------------------------- * CONDAT - Common block for the contour routines. * Variables : XDONE, YDONE: Keeps track of grid crossings * TRANS : Yes/no conformal mapping * CLAB : Yes/no labeling of contours * GRID : Array of contour heights on the grid * EPSTRA : Epsilon for tracking a contour * EPSGRA : Epsilon for computing gradients * D(XY)GRA : Step size for computing gradients * C(XY)M(INAX): Area for which the contours are made * STINIT : * DNTHR : Grid crossing tolerance * NFC : Number of funtion calls used for contours * (Last changed on 19/ 6/98.) *----------------------------------------------------------------------- +KEEP,CONTDATA. LOGICAL XDONE(0:MXGRID,0:MXGRID),YDONE(0:MXGRID,0:MXGRID), - TRANS,CLAB REAL GRID(0:MXGRID,0:MXGRID),EPSTRA,EPSGRA,CXMIN,CXMAX,CYMIN, - CYMAX,STINIT,DNTHR,DXGRA,DYGRA INTEGER ILOCGR(0:MXGRID,0:MXGRID),NBITER,NNITER,NFC,NGCMAX COMMON /CONDAT/ GRID,XDONE,YDONE,ILOCGR, - NBITER,NNITER,EPSTRA,EPSGRA,DXGRA,DYGRA, - STINIT,DNTHR,CXMIN,CXMAX,CYMIN,CYMAX,NFC,NGCMAX,TRANS,CLAB +KEEP,XGLOBALS,IF=NEVER. *----------------------------------------------------------------------- * GLBDAT - Common blocks storing the names and values of the global * GLBCHR variables. * VARIABLES : GLBVAR : Names of the global variables. * GLBVAL : Values of the global variables. * GLBMOD : Type of the global bariables: * 0 - undefined, * 1 - string, * 2 - number, * 3 - logical, * 4 - histogram, * 5 - matrix. * NGLB : Number of global variables. *----------------------------------------------------------------------- +KEEP,GLOBALS. REAL GLBVAL(MXVAR) INTEGER NGLB,GLBMOD(MXVAR) CHARACTER*10 GLBVAR(MXVAR) COMMON /GLBDAT/ GLBVAL,GLBMOD,NGLB COMMON /GLBCHR/ GLBVAR +KEEP,XDOLOOP,IF=NEVER. *----------------------------------------------------------------------- * DODAT - Common block storing the pointers for DO loop execution. * VARIABLES : DOREF : Do loop structure information * 1 - Starting value (instruction list) * 2 - Step size (instruction list) * 3 - While condition (instruction list) * 4 - Until condition (instruction list) * 5 - Final value (instruction list) * 6 - Starting line of the loop * 7 - Last line of the loop * 8 - Nesting level (number) * 9 - Do loop variable (global number) * 10 - Condition (instruction list) * 11 - Matrix of values (instruction list) * 12 - Current pointer into the matrix * (Last changed on 1/11/01.) *----------------------------------------------------------------------- +KEEP,DOLOOP. INTEGER DOREF,IFREF,LINREF,CURLIN,CDOLVL,CIFLVL,TRACDO,TRACIF, - ISTATE,NDOLIN,NLOOP,NIF COMMON /DODAT/ LINREF(MXDLIN,8),DOREF(MXDLVL,12),IFREF(MXILVL,5), - TRACDO(0:MXDLVL),TRACIF(0:MXILVL),CURLIN,CDOLVL,CIFLVL, - NDOLIN,NLOOP,NIF,ISTATE +KEEP,XHISTDATA,IF=NEVER. *----------------------------------------------------------------------- * HISDAT - Common block storing histograms. * (Last changed on 19/11/10.) *----------------------------------------------------------------------- +KEEP,HISTDATA. DOUBLE PRECISION CONTEN(MXHIST,0:MXCHA+1) REAL XMIN(MXHIST),XMAX(MXHIST) DOUBLE PRECISION SX0(MXHIST),SX1(MXHIST),SX2(MXHIST) INTEGER NCHA(MXHIST),NENTRY(MXHIST) LOGICAL SET(MXHIST),HISUSE(MXHIST),HISLIN(MXHIST) COMMON /HISDAT/ SX0,SX1,SX2,CONTEN,XMIN,XMAX,HISUSE,HISLIN,NCHA, - NENTRY,SET +KEEP,XMATDATA,IF=NEVER. *----------------------------------------------------------------------- * MATDAT - Common block storing matrices. * VARIABLES : MSIZ(I,J) : Length of dimension J of matrix I * MDIM(I) : Number of dimensions of matrix I * MREF(I) : Reference for matrix I * MMOD(I) : Type of variables stored in matrix I * MORG(I) : Points in MVEC before 1st element * MLEN(I) : Length of matrix I (=product of MSIZ) * NREFL : Last reference number assigned * (Last changed on 8/11/95.) *----------------------------------------------------------------------- +KEEP,MATDATA. REAL MVEC(MXEMAT) INTEGER MSIZ(MXMAT,MXMDIM),MDIM(MXMAT),MREF(MXMAT+1),MMOD(MXMAT), - MORG(MXMAT+1),MLEN(MXMAT+1),NREFL COMMON /MATDAT/ MVEC,MSIZ,MDIM,MMOD,MORG,MLEN,MREF,NREFL +PATCH,MAIN. +DECK,MAIN. +SELF,IF=-CDC. PROGRAM MAIN +SELF,IF=CDC. PROGRAM MAIN(INPUT=65,OUTPUT=65,TAPE5=INPUT,TAPE6=OUTPUT) +SELF. *----------------------------------------------------------------------- * MAIN - This program reads headers from the input file and calls * the appropriate routines to carry out the requested action. * VARIABLE : STRING : serves for identifying the header. * (Last changed on 3/ 6/10.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. +SEQ,CELLDATA. +SEQ,GASDATA. +SEQ,BFIELD. LOGICAL STDSTR INTEGER NC,IFAIL,NWORD,INPCMP CHARACTER*(MXCHAR) STRING EXTERNAL STDSTR,INPCMP +SELF,IF=AST. EXTERNAL ASTCCH *** Set up ASTCCH as the condition handler and disable. CALL ASTINT CALL LIB$ESTABLISH(ASTCCH) CALL ASTDCC +SELF,IF=BOINC. call boinc_init() +SELF,IF=CMS,IF=HIGZ. *** Initialise C calls for X windows. CALL INITC +SELF,IF=CMS. *** Disable printing messages about direct access file opening. CALL ERRSET(151,0, -1,2,1) +SELF. *** Initialise variables, graphics, input and algebra. CALL INIT +SELF,IF=AST. *** After initialisation, reenable AST trapping. CALL ASTECC +SELF. *** Print the news. C PRINT *,' ------------------------------------------------------' C PRINT *,' News, including some old but important items. ' C PRINT *,' ......................................................' C PRINT *,' 28/09/92: Gas mixing a la G. Schultz & J. Gresser. ' C PRINT *,' 19/02/94: Polygons (triangle - octagon) available. ' C PRINT *,' 20/05/94: Magboltz 1 gas mixing interface. ' C PRINT *,' 04/01/97: Monte Carlo drift line integration added. ' C PRINT *,' 27/01/97: Heed clustering interface introduced. ' C PRINT *,' 21/05/97: Reading Maxwell 2D field maps. ' C PRINT *,' 28/10/97: Reading Maxwell 3D field maps. ' C PRINT *,' 30/04/99: Signals in other electrodes than wires. ' C PRINT *,' 21/05/99: New arrival time distribution format. ' C PRINT *,' 04/02/00: Magboltz 2 introduced. ' C PRINT *,' 24/09/00: Heed interface corrected for cluster losses.' C PRINT *,' 13/06/01: Merging of gas datasets added. ' C PRINT *,' 28/11/01: Photons and electrons as primary for Heed. ' C PRINT *,' 13/05/02: Introducing ion dissociation. ' C PRINT *,' ......................................................' C PRINT *,' Garfield, Heed and Magboltz documentation is at: ' C PRINT *,' http://cern.ch/garfield ' C PRINT *,' http://cern.ch/heed ' C PRINT *,' http://cern.ch/magboltz ' C PRINT *,' ------------------------------------------------------' C PRINT *,' ' C PRINT *,' ' PRINT *,' Welcome, this is Garfield - version 7.44,'// - ' updated until 24 March 2012' PRINT *,' ' PRINT *,' Documentation is in http://cern.ch/garfield' PRINT *,' ' *** Print a message when ready to start in interactive mode. C IF(STDSTR('INPUT'))THEN C PRINT *,' ================================================' C PRINT *,' ========== Ready - Enter a header ==========' C PRINT *,' ================================================' C PRINT *,' ' C ENDIF *** Start an input loop that stops at the EOF or at the STOP command. IFAIL=0 CALL INPPRM('Main','NEW-PRINT') CALL INPWRD(NWORD) *** Otherwise the line should start with an & symbol. 10 CONTINUE CALL INPNUM(NWORD) * Skip blank lines. IF(NWORD.EQ.0)THEN CALL INPWRD(NWORD) GOTO 10 ENDIF * Stay in main if requested. IF(INPCMP(1,'&MAIN')+INPCMP(2,'MAIN').NE.0)THEN CALL INPWRD(NWORD) GOTO 10 ENDIF * Make sure it starts with an ampersand. CALL INPSTR(1,1,STRING,NC) IF(INPCMP(1,'ENDDO')+INPCMP(1,'ENDIF')+INPCMP(1,'LEAVE')+ - INPCMP(1,'BREAK')+INPCMP(1,'ITERATE')+ - INPCMP(1,'CONTINUE').NE.0)THEN PRINT *,' !!!!!! MAIN WARNING : "'//STRING(1:NC)// - '" control statement out of context.' CALL INPWRD(NWORD) GOTO 10 ELSEIF(STRING(1:1).NE.'&')THEN PRINT *,' !!!!!! MAIN WARNING : Please enter a section'// - ' header, a control statement or a global command.' CALL INPWRD(NWORD) GOTO 10 ELSEIF(NC.EQ.1.AND.NWORD.EQ.1)THEN PRINT *,' !!!!!! MAIN WARNING : A section name should'// - ' be appended to the &; try again.' CALL INPWRD(NWORD) GOTO 10 ENDIF IF((NWORD.GT.2.AND.NC.EQ.1).OR.(NWORD.GT.1.AND.NC.GT.1)) - PRINT *,' !!!!!! MAIN WARNING : Keywords on the header'// - ' line are ignored in this version of the program.' IF(NC.EQ.1)CALL INPSTR(2,2,STRING,NC) +SELF,IF=CDC. *** Send message to the console, if the job is running in batch. CALL BTEXT(STRING) +SELF. *** Stop if STOP is the keyword. IF(INPCMP(1,'&ST#OP')+INPCMP(2,'ST#OP')+ - INPCMP(1,'&Q#UIT')+INPCMP(2,'Q#UIT')+ - INPCMP(1,'&EX#IT')+INPCMP(2,'EX#IT').NE.0)THEN CALL QUIT STOP +SELF,IF=TEST. *** Call the user test routine UTEST. ELSEIF(INPCMP(1,'&T#EST')+INPCMP(2,'T#EST').NE.0)THEN CALL UTEST CALL INPPRM('Main','NEW-PRINT') CALL INPWRD(NWORD) +SELF,IF=CELL. *** Call CELDEF if CELL is a keyword, ELSEIF(INPCMP(1,'&C#ELL')+INPCMP(2,'C#ELL').NE.0)THEN * Call cell reading routine. CALL CELDEF(IFAIL) IF(IFAIL.EQ.1)PRINT *,' !!!!!! MAIN WARNING : The cell'// - ' section failed ; various sections can not be'// - ' entered.' *** Call MAGINP if MAGNETIC is a keyword. ELSEIF(INPCMP(1,'&M#AGNETIC-#FIELD')+ - INPCMP(2,'M#AGNETIC-#FIELD').NE.0)THEN CALL MAGINP IF(GASSET)THEN IF((BTAB(1)-BFMIN*BSCALE)* - (BFMIN*BSCALE-BTAB(NBTAB)).LT.0.OR. - (BTAB(1)-BFMAX*BSCALE)* - (BFMAX*BSCALE-BTAB(NBTAB)).LT.0)THEN PRINT *,' ------ MAIN MESSAGE : Previous gas'// - ' data deleted.' GASSET=.FALSE. ENDIF ENDIF +SELF,IF=-CELL. *** Warn if the cell section has not been compiled. ELSEIF(INPCMP(1,'&C#ELL')+INPCMP(2,'C#ELL')+ - INPCMP(1,'&M#AGNETIC-#FIELD')+ - INPCMP(2,'M#AGNETIC-#FIELD').NE.0)THEN PRINT *,' !!!!!! MAIN WARNING : The &CELL and &MAGNETIC'// - ' sections are absent in this compilation.' CALL SKIP +SELF,IF=GAS. *** Read gas data if GAS is the first keyword, ELSEIF(INPCMP(1,'&G#AS')+INPCMP(2,'G#AS').NE.0)THEN * Call the gas data reading routine. CALL GASDEF(IFAIL) IF(IFAIL.NE.0.AND.JFAIL.EQ.1)THEN PRINT *,' !!!!!! MAIN WARNING : Gas section failed'// - ' ; CO2 will be used for the time being.' CALL XXXGAS(IFAIL) IF(IFAIL.NE.0)PRINT *,' ###### MAIN ERROR : CO2'// - ' data are not correct ; no gas data.' ELSEIF(IFAIL.NE.0)THEN PRINT *,' !!!!!! MAIN WARNING : The gas section'// - ' failed ; various sections can not be entered.' ENDIF +SELF,IF=-GAS. *** Warn if the gas section has not been compiled. ELSEIF(INPCMP(1,'&G#AS')+INPCMP(2,'G#AS').NE.0)THEN PRINT *,' !!!!!! MAIN WARNING : The &GAS'// - ' section is absent in this compilation.' CALL SKIP +SELF,IF=FIELD. *** Call FLDINP if FIELD is a keyword. ELSEIF(INPCMP(1,'&F#IELD')+INPCMP(2,'F#IELD').NE.0)THEN IF(CELSET)THEN CALL FLDINP ELSE PRINT *,' !!!!!! MAIN WARNING : No cell available'// - ' to do field calculations in ; skipped.' CALL SKIP ENDIF +SELF,IF=-FIELD. *** Warn if the field section has not been compiled. ELSEIF(INPCMP(1,'&F#IELD')+INPCMP(2,'F#IELD').NE.0)THEN PRINT *,' !!!!!! MAIN WARNING : The &FIELD'// - ' section is absent in this compilation.' CALL SKIP +SELF,IF=OPTIMISE. *** Call OPTINP if OPTIMISE is a keyword. ELSEIF(INPCMP(1,'&O#PTIMISE')+INPCMP(2,'O#PTIMISE').NE.0)THEN IF(CELSET)THEN CALL OPTINP ELSE PRINT *,' !!!!!! MAIN WARNING : No cell available'// - ' to optimise ; the section is skipped.' CALL SKIP ENDIF +SELF,IF=-OPTIMISE. *** Warn if the optimisation section has not been compiled. ELSEIF(INPCMP(1,'&O#PTIMISE')+INPCMP(2,'O#PTIMISE').NE.0)THEN PRINT *,' !!!!!! MAIN WARNING : The &OPTIMISE'// - ' section is absent in this compilation.' CALL SKIP +SELF,IF=DRIFT. *** Call DRFINP if DRIFT is the keyword. ELSEIF(INPCMP(1,'&D#RIFT')+INPCMP(2,'D#RIFT').NE.0)THEN IF((.NOT.GASSET).AND.JFAIL.EQ.1)THEN PRINT *,' !!!!!! MAIN WARNING : No gas data found'// - ' so far ; CO2 will be used for the time being.' CALL XXXGAS(IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' ###### MAIN ERROR : The CO2 data'// - ' are not correct ; no gas data.' CALL SKIP GOTO 10 ENDIF ELSEIF(.NOT.GASSET)THEN PRINT *,' !!!!!! MAIN WARNING : No valid gas data'// - ' found so far ; drift section not executed.' CALL SKIP GOTO 10 ENDIF IF(CELSET)THEN CALL DRFINP ELSE PRINT *,' !!!!!! MAIN WARNING : No valid cell data'// - ' found so far ; drift section not executed.' CALL SKIP ENDIF +SELF,IF=-DRIFT. *** Warn if the drift section has not been compiled. ELSEIF(INPCMP(1,'&D#RIFT')+INPCMP(2,'D#RIFT').NE.0)THEN PRINT *,' !!!!!! MAIN WARNING : The &DRIFT'// - ' section is absent in this compilation.' CALL SKIP +SELF,IF=SIGNAL. *** Call SIGINP if SIGNAL is the keyword. ELSEIF(INPCMP(1,'&SI#GNAL')+INPCMP(2,'SI#GNAL').NE.0)THEN IF((.NOT.GASSET).AND.JFAIL.EQ.1)THEN PRINT *,' !!!!!! MAIN WARNING : No gas data found'// - ' so far ; CO2 will be used for the time being.' CALL XXXGAS(IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' ###### MAIN ERROR : The CO2 data'// - ' are not correct ; no gas data.' CALL SKIP GOTO 10 ENDIF ELSEIF(.NOT.GASSET)THEN PRINT *,' !!!!!! MAIN WARNING : No valid gas data'// - ' found so far ; signal section not executed.' CALL SKIP GOTO 10 ENDIF IF(CELSET)THEN CALL SIGINP ELSE PRINT *,' !!!!!! MAIN WARNING : No valid cell data'// - ' found so far ; signal section not executed.' CALL SKIP ENDIF +SELF,IF=-SIGNAL. *** Warn if the signal section has not been compiled. ELSEIF(INPCMP(1,'&SI#GNAL')+INPCMP(2,'SI#GNAL').NE.0)THEN PRINT *,' !!!!!! MAIN WARNING : The &SIGNAL'// - ' section is absent in this compilation.' CALL SKIP +SELF. *** Header is recognised. ELSE PRINT *,' !!!!!! MAIN WARNING : ',STRING(1:NC),' is'// - ' not a valid header.' CALL SKIP ENDIF *** Read a new header. CALL INPPRM('Main','NEW-PRINT') GOTO 10 END +DECK,INIT. SUBROUTINE INIT *----------------------------------------------------------------------- * INIT - Subroutine initialising most common blocks. * (Last changed on 19/ 1/11.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PARAMETERS. +SEQ,CONSTANTS. +SEQ,CELLDATA. +SEQ,PRINTPLOT. +SEQ,INPUT. +SEQ,GASDATA. +SEQ,GASMIXDATA. +SEQ,DRIFTLINE. +SEQ,MCAMAT. +SEQ,BFIELD. +SEQ,OPTDATA,IF=OPTIMISE. +SEQ,SIGNALDATA,IF=SIGNAL. +SEQ,CONTDATA. +SEQ,GLOBALS. +SEQ,DOLOOP. +SEQ,SOLIDS. +SEQ,GRAPHICS. EXTERNAL STDSTR,RNDM,RANFL LOGICAL STDSTR REAL DUMMY CHARACTER*8 DATE,TIME INTEGER IFAIL,J,IREF,IRNDM,JRNDM,KRNDM +SELF,IF=BOINC. INTEGER I +SELF,IF=VAX. external cli$present,cli$_present,cli$_absent,cli$_negated, - cli$_defaulted,lib$get_foreign,garfcld,lib$get_input character*256 comlin integer cli$present,status,lib$get_foreign,cli$dcl_parse, - lib$get_input,nccom include '($fordef)' include '($ssdef)' +SELF,IF=APOLLO. %include '/sys/ins/base.ins.ftn' %include '/sys/ins/pgm.ins.ftn' integer*2 iarg,nargs,arg_length integer pointer(128),inpcmx,inext,istat character*128 args external inpcmx +SELF,IF=UNIX,CYGWIN. integer inpcmx,arg_length,iarg,nargs,inext character*128 args external inpcmx +SELF,IF=UNIX,CYGWIN,IF=G77. integer iargc external iargc +SELF,IF=CMS. INTEGER IRC CHARACTER*80 OPTFLG +SELF,IF=CMS,IF=VECTOR. DOUBLE PRECISION VDUMMY(4) +SELF. *** Output unit. LUNOUT =6 *** Write a record to the log file of the program. +SELF,IF=VECTOR. CALL JOBLOG('Version V7.44, C=24/3/12 COMSOL') +SELF,IF=-VECTOR. CALL JOBLOG('Version S7.44, C=24/3/12 COMSOL') +SELF. +SELF,IF=VAX. *** Decode the command line. status=lib$get_foreign(comlin,,nccom,) if(.not.status)then print *,' ###### INIT ERROR : Unable to fetch the'// - ' command line ; Vax reason follows, program quit.' call lib$signal(%val(status)) call quit endif status=cli$dcl_parse('garfield '//comlin(1:max(1,nccom)), - garfcld,lib$get_input) if(.not.status)then print *,' !!!!!! INIT WARNING : Unable to decode the'// - ' command line, see above; program quit.' call quit endif +SELF. +SELF,IF=CMS. *** Start the clock, set the time limit very high. CALL TIMEST(1.0E10) +SELF,IF=-CMS,-VECTOR. CALL TIMED(DUMMY) +SELF,IF=CMS,IF=VECTOR. CALL VCLOC(VDUMMY) +SELF. *** Initial data for the /PARMS/ common block. NLINED=20 NINORD=2 LINCAL=.TRUE. NGRIDX=25 NGRIDY=25 LEPSG=.FALSE. EPSGX=0 EPSGY=0 EPSGZ=0 CALL PLAINT *** Track initialisation. CALL TRAINT *** Parameters for contour plotting in /CONDAT/. NBITER=10 NNITER=10 EPSTRA=1.0E-3 EPSGRA=1.0E-3 STINIT=0.174123 DNTHR=0.1 NGCMAX=500 *** Initial data for the /DRIFTL/ common block. MXDIFS =MIN(2,MXSTCK) MXTWNS =MIN(2,MXSTCK) MXATTS =MIN(2,MXSTCK) LREPSK =.TRUE. LKINK =.TRUE. EPSDFI =1.0E-4 EPSTWI =1.0E-4 EPSATI =1.0E-4 RDF2 =5 MDF2 =2 TMC =0.00002 DMC =0.001 NMC =100 MCMETH =0 RTRAP =2.0 EPSDIF =1.0E-8 STMAX =0.0 LSTMAX =.FALSE. IPTYPE =0 IPTECH =0 QPCHAR =0.0 NU =0 EQTTHR =0.2 EQTASP =3 EQTCLS =0.2 LEQSRT =.TRUE. LEQCRS =.TRUE. LEQMRK =.FALSE. LAVPRO =.FALSE. DSCMIN =0.95 DSCMAX =1.05 *** Initial data for the /CELDAT/ common block. CALL CELINT * Memory allocation. CALL BOOK('INITIALISE','MATRIX',' ',IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' ###### INIT ERROR : Unable to declare the'// - ' capacitance matrix; cell computations may fail.' ENDIF *** Background field. IENBGF =0 LBGFMP =.FALSE. *** Initialise the field map. CALL MAPINT *** Solids. NSOLID =0 ICCURR =0 *** Initialise neBEM. CALL BEMINI(IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! INIT WARNING : neBEM initialisation'// - ' failed; neBEM calculations are likely to fail.' ENDIF *** Initial data statements for the /PRTPLT/ common block. JFAIL =1 JEXMEM =2 LINPUT =.NOT.STDSTR('INPUT') LCELPR =.FALSE. LCELPL =.FALSE. LWRMRK =.FALSE. LISOCL =.FALSE. LCHGCH =.FALSE. LDRPLT =.FALSE. LDRPRT =.FALSE. LCLPRT =.TRUE. LCLPLT =.TRUE. LIDENT =.FALSE. LDEBUG =.FALSE. LRNDMI =.TRUE. LPROPR =STDSTR('INPUT') LPROF =.TRUE. LMAPCH =.FALSE. LCNTAM =.TRUE. LINREC =STDSTR('INPUT') LGSTOP =.FALSE. LSYNCH =.FALSE. *** GKS error logging file name. GKSLOG ='GKS_error.log' NCGKS =13 *** Input and output files FNINP =' ' NCFNI =0 FNOUT =' ' NCFNO =0 *** Read the command line options, first preset the optional arguments. NCARG=1 ARGSTR=' ' +SELF,IF=VAX. * Check the command line for the /DEBUG qualifier on Vax computers. IF(CLI$PRESENT('DEBUG').EQ.%loc(CLI$_PRESENT).OR. - CLI$PRESENT('DEBUG').EQ.%loc(CLI$_DEFAULTED))THEN LDEBUG=.TRUE. ELSEIF(CLI$PRESENT('DEBUG').EQ.%loc(CLI$_ABSENT).OR. - CLI$PRESENT('DEBUG').EQ.%loc(CLI$_NEGATED))THEN LDEBUG=.FALSE. ENDIF * Check the command line for the /IDENT qualifier on Vax computers. IF(CLI$PRESENT('IDENTIFICATION').EQ.%loc(CLI$_PRESENT).OR. - CLI$PRESENT('IDENTIFICATION').EQ.%loc(CLI$_DEFAULTED))THEN LIDENT=.TRUE. ELSEIF(CLI$PRESENT('IDENTIFICATION').EQ.%loc(CLI$_ABSENT).OR. - CLI$PRESENT('IDENTIFICATION').EQ.%loc(CLI$_NEGATED))THEN LIDENT=.FALSE. ENDIF * Check the command line for the /INPUT qualifier on Vax computers. IF(CLI$PRESENT('INPUT_LISTING').EQ.%loc(CLI$_PRESENT).OR. - CLI$PRESENT('INPUT_LISTING').EQ.%loc(CLI$_DEFAULTED))THEN LINPUT=.TRUE. ELSEIF(CLI$PRESENT('INPUT_LISTING').EQ.%loc(CLI$_ABSENT).OR. - CLI$PRESENT('INPUT_LISTING').EQ.%loc(CLI$_NEGATED))THEN LINPUT=.FALSE. ENDIF * Check the command line for the /RNDM_INIT qualifier on Vax computers. IF(CLI$PRESENT('RNDM_INITIALISATION').EQ.%loc(CLI$_PRESENT).OR. - CLI$PRESENT('RNDM_INITIALISATION').EQ. - %loc(CLI$_DEFAULTED))THEN LRNDMI=.TRUE. ELSEIF(CLI$PRESENT('RNDM_INITIALISATION').EQ. - %loc(CLI$_ABSENT).OR. - CLI$PRESENT('RNDM_INITIALISATION').EQ. - %loc(CLI$_NEGATED))THEN LRNDMI=.FALSE. ENDIF * Check the command line for the /PROGRESS_PRINT qualifier on Vax. IF(CLI$PRESENT('PROGRESS_PRINT').EQ.%loc(CLI$_PRESENT).OR. - CLI$PRESENT('PROGRESS_PRINT').EQ. - %loc(CLI$_DEFAULTED))THEN LPROPR=.TRUE. ELSEIF(CLI$PRESENT('PROGRESS_PRINT').EQ. - %loc(CLI$_ABSENT).OR. - CLI$PRESENT('PROGRESS_PRINT').EQ. - %loc(CLI$_NEGATED))THEN LPROPR=.FALSE. ENDIF * Check the command line for the /RECORDING qualifier on Vax. IF(.NOT.STDSTR('INPUT'))THEN LINREC=.FALSE. ELSEIF(CLI$PRESENT('RECORDING').EQ.%loc(CLI$_PRESENT).OR. - CLI$PRESENT('RECORDING').EQ.%loc(CLI$_DEFAULTED))THEN LINREC=.TRUE. ELSEIF(CLI$PRESENT('RECORDING').EQ.%loc(CLI$_ABSENT).OR. - CLI$PRESENT('RECORDING').EQ.%loc(CLI$_NEGATED))THEN LINREC=.FALSE. ENDIF * Check the command line for the /PROFILE qualifier on Vax. IF(CLI$PRESENT('PROFILE').EQ.%loc(CLI$_PRESENT).OR. - CLI$PRESENT('PROFILE').EQ.%loc(CLI$_DEFAULTED))THEN LPROF=.TRUE. ELSEIF(CLI$PRESENT('PROFILE').EQ.%loc(CLI$_ABSENT).OR. - CLI$PRESENT('PROFILE').EQ.%loc(CLI$_NEGATED))THEN LPROF=.FALSE. ENDIF * Check the command line for the /SYNCHRONISE qualifier on Vax. IF(CLI$PRESENT('SYNCHRONISE').EQ.%loc(CLI$_PRESENT).OR. - CLI$PRESENT('SYNCHRONISE').EQ.%loc(CLI$_DEFAULTED))THEN LSYNCH=.TRUE. ELSEIF(CLI$PRESENT('SYNCHRONISE').EQ.%loc(CLI$_ABSENT).OR. - CLI$PRESENT('SYNCHRONISE').EQ.%loc(CLI$_NEGATED))THEN LSYNCH=.FALSE. ENDIF +SELF,IF=CMS. * Check the command line for the DEBUG option under VM/CMS. CALL VMREXX('F','DEBUG',OPTFLG,IRC) IF(IRC.NE.0)THEN PRINT *,' !!!!!! INIT WARNING : Unable to read the value', - ' of the DEBUG option via VMREXX; set to .FALSE.' * Enable or disable printing of error messages. ELSEIF(OPTFLG.EQ.'YES')THEN LDEBUG=.TRUE. CALL ERRSET(207,0,256,2,1) CALL ERRSET(208,0,256,2,1) CALL ERRSET(209,0,256,2,1) CALL ERRSET(213,0,256,2,1) ELSEIF(OPTFLG.EQ.'NO')THEN LDEBUG=.FALSE. CALL ERRSET(207,0, -1,2,1) CALL ERRSET(208,0, -1,2,1) CALL ERRSET(209,0, -1,2,1) CALL ERRSET(213,0, -1,2,1) ELSE PRINT *,' !!!!!! INIT WARNING : Invalid DEBUG option'// - ' received from VMREXX: ',OPTFLG ENDIF * Check the command line for the IDENT option under VM/CMS. CALL VMREXX('F','IDENTIFICATION',OPTFLG,IRC) IF(IRC.NE.0)THEN PRINT *,' !!!!!! INIT WARNING : Unable to read the value', - ' of the IDENT option via VMREXX; set to .FALSE.' ELSEIF(OPTFLG.EQ.'YES')THEN LIDENT=.TRUE. ELSEIF(OPTFLG.EQ.'NO')THEN LIDENT=.FALSE. ELSE PRINT *,' !!!!!! INIT WARNING : Invalid IDENT option'// - ' received from VMREXX: ',OPTFLG ENDIF * Check the command line for the INPUT option under VM/CMS. CALL VMREXX('F','INPUT_LISTING',OPTFLG,IRC) IF(IRC.NE.0)THEN PRINT *,' !!!!!! INIT WARNING : Unable to read the value', - ' of the INPUT option via VMREXX; set to .FALSE.' ELSEIF(OPTFLG.EQ.'YES')THEN LINPUT=.TRUE. ELSEIF(OPTFLG.EQ.'NO')THEN LINPUT=.FALSE. ELSEIF(OPTFLG.NE.'*')THEN PRINT *,' !!!!!! INIT WARNING : Invalid INPUT option'// - ' received from VMREXX: ',OPTFLG ENDIF * Check the command line for the RNDM_INIT option under VM/CMS. CALL VMREXX('F','RNDM_INITIALISATION',OPTFLG,IRC) IF(IRC.NE.0)THEN PRINT *,' !!!!!! INIT WARNING : Unable to read the value', - ' of the RNDM_INIT option via VMREXX; set to .TRUE.' ELSEIF(OPTFLG.EQ.'YES')THEN LRNDMI=.TRUE. ELSEIF(OPTFLG.EQ.'NO')THEN LRNDMI=.FALSE. ELSE PRINT *,' !!!!!! INIT WARNING : Invalid RNDM_INIT'// - ' option received from VMREXX: ',OPTFLG ENDIF * Check the command line for the PROGRESS_PRINT option under VM/CMS. CALL VMREXX('F','PROGRESS_PRINT',OPTFLG,IRC) IF(IRC.NE.0)THEN PRINT *,' !!!!!! INIT WARNING : Unable to read the value', - ' of the PROGRESS option via VMREXX; set to .TRUE.' ELSEIF(OPTFLG.EQ.'YES')THEN LPROPR=.TRUE. ELSEIF(OPTFLG.EQ.'NO')THEN LPROPR=.FALSE. ELSE PRINT *,' !!!!!! INIT WARNING : Invalid PROGRESS_PRINT'// - ' option received from VMREXX: ',OPTFLG ENDIF * Check the command line for the RECORDING option under VM/CMS. CALL VMREXX('F','RECORDING',OPTFLG,IRC) IF(IRC.NE.0)THEN PRINT *,' !!!!!! INIT WARNING : Unable to read the value', - ' of the RECORDING option via VMREXX; set to .TRUE.' ELSEIF(.NOT.STDSTR('INPUT'))THEN LINREC=.FALSE. ELSEIF(OPTFLG.EQ.'YES')THEN LINREC=.TRUE. ELSEIF(OPTFLG.EQ.'NO')THEN LINREC=.FALSE. ELSE PRINT *,' !!!!!! INIT WARNING : Invalid RECORDING'// - ' option received from VMREXX: ',OPTFLG ENDIF * Check the command line for the PROFILE option under VM/CMS. CALL VMREXX('F','PROFILE',OPTFLG,IRC) IF(IRC.NE.0)THEN PRINT *,' !!!!!! INIT WARNING : Unable to read the value', - ' of the PROFILE option via VMREXX; set to .TRUE.' ELSEIF(OPTFLG.EQ.'YES')THEN LPROF=.TRUE. ELSEIF(OPTFLG.EQ.'NO')THEN LPROF=.FALSE. ELSE PRINT *,' !!!!!! INIT WARNING : Invalid PROFILE'// - ' option received from VMREXX: ',OPTFLG ENDIF * Check the command line for the SYNCHRONISE option under VM/CMS. CALL VMREXX('F','SYNCHRONISE',OPTFLG,IRC) IF(IRC.NE.0)THEN PRINT *,' !!!!!! INIT WARNING : Unable to read the value', - ' of the PROFILE option via VMREXX; set to .TRUE.' ELSEIF(OPTFLG.EQ.'YES')THEN LSYNCH=.TRUE. ELSEIF(OPTFLG.EQ.'NO')THEN LSYNCH=.FALSE. ELSE PRINT *,' !!!!!! INIT WARNING : Invalid SYNCHRONISE'// - ' option received from VMREXX: ',OPTFLG ENDIF +SELF,IF=APOLLO. * Count the number of arguments, pointer vector will not be used. call pgm_$get_args(nargs,pointer) * Loop over arguments, deleting those we recognise. inext=1 do 30 iarg=1,nargs-1 if(iarg.lt.inext)goto 30 arg_length=pgm_$get_arg(iarg,args,istat) if(istat.ne.status_$ok)print *,' !!!!!! INIT WARNING : Error'// - ' fetching an argument.' istat=status_$ok * Debugging options. if(inpcmx(args(1:arg_length),'-deb#ug').ne.0)then ldebug=.true. elseif(inpcmx(args(1:arg_length),'-nodeb#ug').ne.0)then ldebug=.false. * Tracing options. elseif(inpcmx(args(1:arg_length),'-id#entification').ne.0)then lident=.true. elseif(inpcmx(args(1:arg_length),'-noid#entification').ne.0)then lident=.false. * Input listing. elseif(inpcmx(args(1:arg_length),'-in#put_listing').ne.0)then linput=.true. elseif(inpcmx(args(1:arg_length),'-noin#put_listing').ne.0)then linput=.false. * Random number initialisation. elseif(inpcmx(args(1:arg_length), - '-RNDM#_initialisation').ne.0)then lrndmi=.true. elseif(inpcmx(args(1:arg_length), - '-noRNDM#_initialisation').ne.0)then lrndmi=.false. * Progress printing. elseif(inpcmx(args(1:arg_length),'-pro#gress_print').ne.0)then lpropr=.true. elseif(inpcmx(args(1:arg_length),'-nopro#gress_print').ne.0)then lpropr=.false. * Input recording. elseif(inpcmx(args(1:arg_length),'-rec#ording').ne.0)then if(stdstr('INPUT'))then linrec=.true. else PRINT *,' !!!!!! INIT WARNING : The -recording'// - ' option is for interactive use only; ignored.' endif elseif(inpcmx(args(1:arg_length),'-norec#ording').ne.0)then linrec=.false. * Reading of profile file. elseif(inpcmx(args(1:arg_length),'-pr#ofile').ne.0)then lprof=.true. elseif(inpcmx(args(1:arg_length),'-nopr#ofile').ne.0)then lprof=.false. * Synchronisation prompt. elseif(inpcmx(args(1:arg_length),'-synch#ronise').ne.0)then lsynch=.true. elseif(inpcmx(args(1:arg_length),'-nosynch#ronise').ne.0)then lsynch=.false. * Terminal and metafile type. elseif(inpcmx(args(1:arg_length),'-term#inal')+ - inpcmx(args(1:arg_length),'-meta#file').ne.0)then do 50 j=iarg+1,nargs arg_length=pgm_$get_arg(j,args,istat) if(istat.ne.status_$ok)print *,' !!!!!! INIT WARNING :'// - ' Error fetching an argument.' istat=status_$ok if(args(1:1).eq.'-'.and.arg_length.gt.1)then inext=j goto 30 endif 50 continue inext=nargs+1 * Anything else is not valid. elseif(inpcmx(args(1:arg_length),'-noterm#inal')+ - inpcmx(args(1:arg_length),'-nometa#file')+ - inpcmx(args(1:arg_length),'-interact#ive')+ - inpcmx(args(1:arg_length),'-batch').eq.0)then print *,' !!!!!! INIT WARNING : Unrecognised option "'// - args(1:arg_length)//'" found on the command line.' endif 30 continue +SELF,IF=UNIX,CYGWIN. * Count the number of arguments, pointer vector will not be used. nargs=iargc() * Loop over arguments, deleting those we recognise. inext=1 do 30 iarg=1,nargs if(iarg.lt.inext)goto 30 call argget(iarg,args,arg_length) * Debugging options. if(inpcmx(args(1:arg_length),'-deb#ug').ne.0)then ldebug=.true. elseif(inpcmx(args(1:arg_length),'-nodeb#ug').ne.0)then ldebug=.false. * Tracing options. elseif(inpcmx(args(1:arg_length),'-id#entification').ne.0)then lident=.true. elseif(inpcmx(args(1:arg_length),'-noid#entification').ne.0)then lident=.false. * Input listing. elseif(inpcmx(args(1:arg_length),'-in#put_listing').ne.0)then linput=.true. elseif(inpcmx(args(1:arg_length),'-noin#put_listing').ne.0)then linput=.false. * Random number initialisation. elseif(inpcmx(args(1:arg_length), - '-RNDM#_initialisation').ne.0)then lrndmi=.true. elseif(inpcmx(args(1:arg_length), - '-noRNDM#_initialisation').ne.0)then lrndmi=.false. * Progress printing. elseif(inpcmx(args(1:arg_length),'-pro#gress_print').ne.0)then lpropr=.true. elseif(inpcmx(args(1:arg_length),'-nopro#gress_print').ne.0)then lpropr=.false. * Input recording. elseif(inpcmx(args(1:arg_length),'-rec#ording').ne.0)then if(STDSTR('INPUT'))linrec=.true. elseif(inpcmx(args(1:arg_length),'-norec#ording').ne.0)then linrec=.false. * Reading of profile file. elseif(inpcmx(args(1:arg_length),'-pr#ofile').ne.0)then lprof=.true. elseif(inpcmx(args(1:arg_length),'-nopr#ofile').ne.0)then lprof=.false. * Synchronisation prompt. elseif(inpcmx(args(1:arg_length),'-synch#ronise').ne.0)then lsynch=.true. elseif(inpcmx(args(1:arg_length),'-nosynch#ronise').ne.0)then lsynch=.false. * GKS error logging file. elseif(inpcmx(args(1:arg_length),'-GKSlog').ne.0)then if(iarg+1.le.nargs)then call argget(iarg+1,args,arg_length) gkslog=args(1:arg_length) ncgks=min(mxname,arg_length) if(arg_length.gt.mxname) - print *,' !!!!!! INIT WARNING : Name of GKS'// - ' error logging file too long; truncated.' inext=iarg+2 else print *,' !!!!!! INIT WARNING : File name missing'// - ' following the -GKSlog option.' endif * Alternate input file to be opened on unit 5. elseif(inpcmx(args(1:arg_length),'-input_file')+ - inpcmx(args(1:arg_length),'-infile').ne.0)then if(iarg+1.le.nargs)then call argget(iarg+1,args,arg_length) fninp=args(1:arg_length) ncfni=min(mxname,arg_length) if(arg_length.gt.mxname) - print *,' !!!!!! INIT WARNING : Input file'// - ' name too long; truncated.' inext=iarg+2 else print *,' !!!!!! INIT WARNING : File name missing'// - ' following the -input_file option.' endif * Alternate output file to be opened on unit 6. elseif(inpcmx(args(1:arg_length),'-output#_file')+ - inpcmx(args(1:arg_length),'-outfile').ne.0)then if(iarg+1.le.nargs)then call argget(iarg+1,args,arg_length) fnout=args(1:arg_length) ncfno=min(mxname,arg_length) if(arg_length.gt.mxname) - print *,' !!!!!! INIT WARNING : Output file'// - ' name too long; truncated.' inext=iarg+2 else print *,' !!!!!! INIT WARNING : File name missing'// - ' following the -output_file option.' endif * Terminal and metafile type. elseif(inpcmx(args(1:arg_length),'-term#inal')+ - inpcmx(args(1:arg_length),'-meta#file')+ - inpcmx(args(1:arg_length),'-interact#ive')+ - inpcmx(args(1:arg_length),'-batch').ne.0)then do 50 j=iarg+1,nargs call argget(j,args,arg_length) if(args(1:1).eq.'-'.and.arg_length.gt.1)then inext=j goto 30 endif 50 continue inext=nargs+1 * Command line arguments. elseif(inpcmx(args(1:arg_length),'-arg#uments').ne.0)then ncarg=0 do 60 j=iarg+1,nargs call argget(j,args,arg_length) if(inpcmx(args(1:arg_length),'-batch')+ - inpcmx(args(1:arg_length),'-interact#ive')+ - inpcmx(args(1:arg_length),'-GKSlog')+ - inpcmx(args(1:arg_length),'-deb#ug')+ - inpcmx(args(1:arg_length),'-nodeb#ug')+ - inpcmx(args(1:arg_length),'-id#entification')+ - inpcmx(args(1:arg_length),'-noid#entification')+ - inpcmx(args(1:arg_length),'-in#put_listing')+ - inpcmx(args(1:arg_length),'-noin#put_listing')+ - inpcmx(args(1:arg_length),'-input_file')+ - inpcmx(args(1:arg_length),'-infile')+ - inpcmx(args(1:arg_length),'-output_file')+ - inpcmx(args(1:arg_length),'-outfile')+ - inpcmx(args(1:arg_length),'-meta#file')+ - inpcmx(args(1:arg_length),'-nometa#file')+ - inpcmx(args(1:arg_length),'-pr#ofile')+ - inpcmx(args(1:arg_length),'-nopr#ofile')+ - inpcmx(args(1:arg_length),'-pro#gress_print')+ - inpcmx(args(1:arg_length),'-nopro#gress_print')+ - inpcmx(args(1:arg_length),'-rec#ording')+ - inpcmx(args(1:arg_length),'-norec#ording')+ - inpcmx(args(1:arg_length), - '-RNDM#_initialisation')+ - inpcmx(args(1:arg_length), - '-noRNDM#_initialisation')+ - inpcmx(args(1:arg_length),'-synch#ronise')+ - inpcmx(args(1:arg_length),'-nosynch#ronise')+ - inpcmx(args(1:arg_length),'-term#inal')+ - inpcmx(args(1:arg_length),'-noterm#inal').eq.0)then if(ncarg+1.le.len(argstr))then argstr(ncarg+1:)=args(1:arg_length)//' ' ncarg=min(len(argstr),ncarg+arg_length+1) else print *,' !!!!!! INIT WARNING : Command'// - ' line arguments too long; truncated.' endif inext=j+1 else goto 70 endif 60 continue 70 continue if(ncarg.gt.1)ncarg=ncarg-1 if(ncarg.lt.1)then argstr=' ' ncarg=1 endif * Anything else is not valid. elseif(inpcmx(args(1:arg_length),'-noterm#inal')+ - inpcmx(args(1:arg_length),'-nometa#file').eq.0)then print *,' !!!!!! INIT WARNING : Unrecognised option "'// - args(1:arg_length)//'" found on the command line.' endif 30 continue +SELF. *** Global variable initialisation. GLBVAR(1)='TIME_LEFT ' GLBMOD(1)=2 CALL TIMEL(GLBVAL(1)) * Type of compilation GLBVAR(2)='MACHINE ' IREF=-1 +SELF,IF=APOLLO. CALL STRBUF('STORE',IREF,'Apollo',6,IFAIL) +SELF,IF=CMS. CALL STRBUF('STORE',IREF,'CMS',3,IFAIL) +SELF,IF=CRAY. CALL STRBUF('STORE',IREF,'Cray',4,IFAIL) +SELF,IF=MVS. CALL STRBUF('STORE',IREF,'MVS',3,IFAIL) +SELF,IF=VAX. CALL STRBUF('STORE',IREF,'Vax',3,IFAIL) +SELF,IF=UNIX. CALL STRBUF('STORE',IREF,'Unix',4,IFAIL) +SELF,IF=CYGWIN. CALL STRBUF('STORE',IREF,'Cygwin',4,IFAIL) +SELF. IF(IREF.LT.0) - CALL STRBUF('STORE',IREF,'< not known >',13,IFAIL) GLBMOD(2)=1 GLBVAL(2)=IREF * Interactive or batch mode GLBVAR(3)='INTERACT ' GLBVAR(4)='BATCH ' GLBMOD(3)=3 GLBMOD(4)=3 IF(STDSTR('INPUT'))THEN GLBVAL(3)=1 GLBVAL(4)=0 ELSE GLBVAL(3)=0 GLBVAL(4)=1 ENDIF * Status for return of procedure calls GLBVAR(5)='OK ' GLBMOD(5)=3 GLBVAL(5)=1 * Output file. GLBVAR(7)='OUTPUT ' IF(FNOUT.EQ.' '.OR.NCFNO.LT.1)THEN CALL STRBUF('STORE',IREF,'Standard output',15,IFAIL) ELSE CLOSE(UNIT=6,ERR=2030) +SELF,IF=BOINC. call boincrf(fnout(1:ncfno),fnout) do i=len(fnout),1,-1 if(fnout(i:i).ne.' ')then ncfno=i goto 1234 endif enddo 1234 continue +SELF. OPEN(UNIT=6,FILE=FNOUT(1:NCFNO),ERR=2020) CALL STRBUF('STORE',IREF,FNOUT(1:NCFNO),NCFNO,IFAIL) ENDIF GLBMOD(7)=1 GLBVAL(7)=IREF * Parameter for plotting GLBVAR(8)='X ' GLBMOD(8)=2 GLBVAL(8)=0 * Plot frame number GLBVAR(9)='FRAME ' GLBMOD(9)=2 GLBVAL(9)=0 * Event number. GLBVAR(10)='EVENT ' GLBMOD(10)=2 GLBVAL(10)=0 * Read-out group number. GLBVAR(11)='GROUP ' GLBMOD(11)=2 GLBVAL(11)=0 NGLB=11 *** Plotting options for contours. LKEYPL =.FALSE. +SELF,IF=NAG,IF=PLOT10GKS,GTSGRAL,DECGKS. LKEYPL =.TRUE. +SELF. *** Initial data for the /MAGDAT/ common block. CALL MAGINT *** Initial data for the /GASDAT/ common block. CALL GASINT +SELF,IF=SIGNAL. *** Initial data for the /SIGDAT/ common block. TSTART =0.0 TDEV =0.01 NTIME =MXLIST RESSET =.FALSE. PRSTHR =0.0 AVALAN(1)=100000.0 AVALAN(2)=0.001 AVATYP ='NOT SET' NFOUR =1 LCROSS =.TRUE. TRASET =.FALSE. JIORD =1 NISIMP =2 NMQUAD =1 NASIMP =2 NORIA =MIN(50,MXORIA) FCNANG =' ' NCANG =0 LITAIL =.TRUE. LDTAIL =.FALSE. LRTAIL =.FALSE. LEPULS =.FALSE. LIPULS =.TRUE. SIGSET =.FALSE. * Memory allocation. CALL BOOK('INITIALISE','MCAMAT',' ',IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' ###### INIT ERROR : Unable to declare the'// - ' avalanche buffer; avalanche calculations may fail.' ENDIF NMCA=0 +SELF,IF=OPTIMISE. *** Data for the /OPTDAT/ common block. NPOINT=20 FUNFLD='V' NFLD=1 FUNPOS='0' NPOS=1 FUNWGT='1' NWGT=1 VALTYP='AVERAGE' PNTTYP='GRID' +SELF. *** Random number initialisation. IF(LRNDMI)THEN CALL DATTIM(DATE,TIME) READ(TIME,'(I2,1X,I2,1X,I2)') IRNDM,JRNDM,KRNDM CALL RNDINI((1+IRNDM)*(1+JRNDM)*(1+KRNDM)) IF(LDEBUG)PRINT *,' ++++++ INIT DEBUG : Number of'// - ' generator initialisation calls: ', - (1+IRNDM)*(1+JRNDM)*(1+KRNDM) ELSEIF(LDEBUG)THEN PRINT *,' ++++++ INIT DEBUG : No random initialisation.' ENDIF *** DO loop initialisation. ISTATE=-2 *** Take care of algebra, graphics, histogram and matrix initialisation. CALL ALGINT CALL GRINIT CALL HISINT CALL MATINT *** Command line reading routines initialisation. CALL INPINT *** Output the dimensions for front-end programs. IF(LSYNCH)WRITE(6,'('' >>>>>> set MX3D '',I10/ - '' >>>>>> set MXALGE '',I10/'' >>>>>> set MXARG '',I10/ - '' >>>>>> set MXBANG '',I10/'' >>>>>> set MXCHA '',I10/ - '' >>>>>> set MXCHAR '',I10/'' >>>>>> set MXCLUS '',I10/ - '' >>>>>> set MXCONS '',I10/'' >>>>>> set MXDLIN '',I10/ - '' >>>>>> set MXDLVL '',I10/'' >>>>>> set MXEDGE '',I10/ - '' >>>>>> set MXEMAT '',I10/'' >>>>>> set MXEPS '',I10/ - '' >>>>>> set MXEPS '',I10/'' >>>>>> set MXEQUT '',I10/ - '' >>>>>> set MXFOUR '',I10/'' >>>>>> set MXFPAR '',I10/ - '' >>>>>> set MXFPNT '',I10/'' >>>>>> set MXFRAC '',I10/ - '' >>>>>> set MXGRID '',I10/'' >>>>>> set MXHIST '',I10/ - '' >>>>>> set MXHLEV '',I10/'' >>>>>> set MXHLRL '',I10/ - '' >>>>>> set MXILVL '',I10/'' >>>>>> set MXINCH '',I10/ - '' >>>>>> set MXINS '',I10/'' >>>>>> set MXLINE '',I10/ - '' >>>>>> set MXLIST '',I10/'' >>>>>> set MXLIST '',I10/ - '' >>>>>> set MXLUN '',I10/'' >>>>>> set MXMAP '',I10/ - '' >>>>>> set MXMAP '',I10/'' >>>>>> set MXMAT '',I10/ - '' >>>>>> set MXMATT '',I10/'' >>>>>> set MXMATT '',I10/ - '' >>>>>> set MXMDIM '',I10/'' >>>>>> set MXNAME '',I10/ - '' >>>>>> set MXORIA '',I10/'' >>>>>> set MXPAIR '',I10/ - '' >>>>>> set MXPART '',I10/'' >>>>>> set MXPLAN '',I10/ - '' >>>>>> set MXPOIN '',I10/'' >>>>>> set MXPOLE '',I10/ - '' >>>>>> set MXRECL '',I10/'' >>>>>> set MXREG '',I10/ - '' >>>>>> set MXSBUF '',I10/'' >>>>>> set MXSHOT '',I10/ - '' >>>>>> set MXSOLI '',I10/'' >>>>>> set MXSTCK '',I10/ - '' >>>>>> set MXSUBT '',I10/'' >>>>>> set MXSW '',I10/ - '' >>>>>> set MXSW '',I10/'' >>>>>> set MXVAR '',I10/ - '' >>>>>> set MXWIRE '',I10/'' >>>>>> set MXWIRE '',I10/ - '' >>>>>> set MXWKLS '',I10/'' >>>>>> set MXWORD '',I10/ - '' >>>>>> set MXZERO '',I10/'' >>>>>> set MXZPAR '',I10)') - MX3D ,MXALGE,MXARG ,MXBANG,MXCHA ,MXCHAR,MXCLUS,MXCONS, - MXDLIN,MXDLVL,MXEDGE,MXEMAT,MXEPS ,MXEPS ,MXEQUT,MXFOUR, - MXFPAR,MXFPNT,MXFRAC,MXGRID,MXHIST,MXHLEV,MXHLRL,MXILVL, - MXINCH,MXINS ,MXLINE,MXLIST,MXLIST,MXLUN ,MXMAP ,MXMAP , - MXMAT ,MXMATT,MXMATT,MXMDIM,MXNAME,MXORIA,MXPAIR,MXPART, - MXPLAN,MXPOIN,MXPOLE,MXRECL,MXREG ,MXSBUF,MXSHOT,MXSOLI, - MXSTCK,MXSUBT,MXSW ,MXSW ,MXVAR ,MXWIRE,MXWIRE,MXWKLS, - MXWORD,MXZERO,MXZPAR *** Record the CPU time usage for initialisation. CALL TIMLOG('Initialisation:') *** I/O error processing. RETURN 2020 CONTINUE PRINT *,' ###### INIT ERROR : Error opening a file; quit.' CALL QUIT RETURN 2030 CONTINUE PRINT *,' ###### INIT ERROR : Error closing a file; quit.' CALL QUIT END +DECK,JOBLOGUX,IF=UNIX,CYGWIN. SUBROUTINE JOBLOG(TEXT) *----------------------------------------------------------------------- * JOBLOG - This routine writes a log file entry (userid, date & time) * in /afs/cern.ch/user/r/rjd/Garfield/Log/garfield.log. * (Last changed on 27/10/11.) *----------------------------------------------------------------------- +SEQ,PRINTPLOT. CHARACTER*(*) TEXT CHARACTER*32 HOST CHARACTER*8 DATE,TIME,NAME LOGICAL EXIST *** Check total length of the string. IF(LEN(TEXT)+34.GT.132)THEN PRINT *,' !!!!!! JOBLOG WARNING : Job log information'// - ' string too long; no entry written.' RETURN ENDIF *** Find out about current date and time + the user name. CALL DATTIM(DATE,TIME) +SELF,IF=-IBMRT,IF=-HPUX,IF=-SUN,IF=-LINUX,IF=-MACOSX,IF=-DECS,IF=-BOINC. CALL JOBNAM(NAME) HOST='Unknown' +SELF,IF=IBMRT,HPUX,SUN,DECS. irc=getlog(name) irc=hostnm(host) +SELF,IF=LINUX,MACOSX. call getlog(name) call hostnm(host) +SELF,IF=BOINC. NAME='Boinc' HOST='Unknown' +SELF. *** Find the length of the strings. DO 10 I=LEN(NAME),1,-1 IF(NAME(I:I).NE.' ')THEN NCNAME=I GOTO 20 ENDIF 10 CONTINUE NCNAME=1 20 CONTINUE DO 30 I=LEN(HOST),1,-1 IF(HOST(I:I).NE.' ')THEN NCHOST=I GOTO 40 ENDIF 30 CONTINUE NCHOST=1 40 CONTINUE *** Open the log file. INQUIRE(EXIST=EXIST, - FILE='/afs/cern.ch/user/r/rjd/Garfield/Log/garfield.log') *** Open and skip to the end of the file. +SELF,IF=LINUX,MACOSX,BOINC. OPEN(UNIT=12,STATUS='UNKNOWN',ACCESS='APPEND', - FILE='/afs/cern.ch/user/r/rjd/Garfield/Log/garfield.log', - IOSTAT=IOS,ERR=2020) +SELF,IF=-LINUX,IF=-MACOSX,IF=-BOINC. OPEN(UNIT=12,STATUS='UNKNOWN',ACCESS='SEQUENTIAL', - FILE='/afs/cern.ch/user/r/rjd/Garfield/Log/garfield.log', - IOSTAT=IOS,ERR=2020) IF(EXIST)THEN 100 CONTINUE READ(12,'(A1)',END=110,IOSTAT=IOS,ERR=2010) STRING GOTO 100 110 CONTINUE BACKSPACE(UNIT=12,IOSTAT=IOS,ERR=2040) ENDIF +SELF. *** Open a file and write the entry in it. WRITE(12,'(A,'' on '',A8,'' at '',A8,2X,A)',ERR=2010) - NAME(1:NCNAME)//'@'//HOST(1:NCHOST),DATE,TIME,TEXT CLOSE(UNIT=12,ERR=2030) *** Log its usage so the user can in principle know what happened. CALL DSNLOG('garfield.log','Log file ','Sequential', - 'Append ') *** Normal end of this routine. RETURN *** I/O error handling. 2010 CONTINUE IF(LDEBUG)WRITE(LUNOUT,'(1X,A)') ' ++++++ JOBLOG DEBUG :'// - ' I/O error occurred while reading or writing the log file.' IF(LDEBUG)CALL INPIOS(IOS) CLOSE(UNIT=12,ERR=2030,IOSTAT=IOS) RETURN 2020 CONTINUE IF(LDEBUG)WRITE(LUNOUT,'(1X,A)') ' ++++++ JOBLOG DEBUG :'// - ' An error occurred while opening the log file.' IF(LDEBUG)CALL INPIOS(IOS) RETURN 2030 CONTINUE IF(LDEBUG)WRITE(LUNOUT,'(1X,A)') ' ++++++ JOBLOG DEBUG :'// - ' An error occurred while closing the log file.' IF(LDEBUG)CALL INPIOS(IOS) RETURN +SELF,IF=-LINUX,IF=-MACOSX,IF=-BOINC. 2040 CONTINUE +SELF. END +DECK,JOBLOGCD,IF=CDC. SUBROUTINE JOBLOG(TEXT) *----------------------------------------------------------------------- * JOBLOG - This routine writes an entry in a log file (userid, time). *----------------------------------------------------------------------- CHARACTER*(*) TEXT END +DECK,JOBLOGVM,IF=CMS. SUBROUTINE JOBLOG(TEXT) *----------------------------------------------------------------------- * JOBLOG - This routine send a log file entry (userid, date and time) * to RJD@CERNVM. Routine to be used in debugging periods. *----------------------------------------------------------------------- CHARACTER*(*) TEXT CHARACTER*8 DATE,TIME,NAME *** Check total length of the string. IF(LEN(TEXT)+34.GT.132)THEN PRINT *,' !!!!!! JOBLOG WARNING : Job log information'// - ' string too long; no entry written.' RETURN ENDIF *** Find out about current date and time + the user name. CALL DATTIM(DATE,TIME) CALL JOBNAM(NAME) *** Open a file and write the entry in it. CALL VMCMS('FILEDEF JOBLOG DISK GARFIELD JOBLOG (LRECL 132',IRC) OPEN(UNIT=12,FILE='JOBLOG') WRITE(12,'(A8,'' on '',A8,'' at '',A8,2X,A)') NAME,DATE,TIME,TEXT CLOSE(UNIT=12) *** Send the file off and then destroy it. CALL VMCMS('EXEC SENDFILE GARFIELD JOBLOG A TO RJD AT CERNVM'// - ' (NOTYPE NOLOG NOACK',IRC) CALL VMCMS('ERASE GARFIELD JOBLOG A',IRC) *** Log its usage so the user can in principle know what happened. CALL DSNLOG('GARFIELD JOBLOG A','Log file ','Sequential', - 'C/R/W/S/D ') END +DECK,JOBLOGMV,IF=MVS. SUBROUTINE JOBLOG(TEXT) *----------------------------------------------------------------------- * JOBLOG - This routine writes an entry in a log file (userid, time). *----------------------------------------------------------------------- CHARACTER*(*) TEXT CHARACTER*8 DATE,TIME,NAME LOGICAL EXIS *** Check that the file exists, if not create one implicitly. INQUIRE(FILE='V8.RJD.DRIFTLOG',EXIST=EXIS) OPEN(UNIT=12,FILE='V8.RJD.DRIFTLOG',STATUS='UNKNOWN') IF(.NOT.EXIS)GOTO 30 *** Skipt to the EOF, backspace once to position the pointer correctly. 10 CONTINUE READ(12,'()',END=20) GOTO 10 20 CONTINUE BACKSPACE(UNIT=12) *** Ask userid, date and time and write the new entry. 30 CONTINUE CALL JOBNAM(NAME) CALL DATTIM(DATE,TIME) WRITE(12,'(A8,'' on '',A8,'' at '',A8,2X,A)') NAME,DATE,TIME,TEXT CLOSE(UNIT=12) END +DECK,JOBLOGVX,IF=VAX. SUBROUTINE JOBLOG(TEXT) *----------------------------------------------------------------------- * JOBLOG - This routine writes an entry in a log file (userid, time). *----------------------------------------------------------------------- +SEQ,PRINTPLOT. CHARACTER*(*) TEXT CHARACTER*8 DATE,TIME CHARACTER*32 NAME *** Pick up the Job Process Information definition file. INCLUDE '($JPIDEF)' *** Open the file with APPEND access. OPEN(UNIT=12,FILE='DISK$GARFIELD:GARFIELD.LOG',STATUS='UNKNOWN', - ACCESS='APPEND',ERR=2020,IOSTAT=IOS) *** Ask userid, date and time and write the new entry. ISTAT=LIB$GETJPI(%REF(JPI$_USERNAME),,,,NAME,LENGTH) IF(ISTAT.EQ.2*NINT(ISTAT/2.0))THEN NAME='?' LENGTH=1 ELSE DO I=LENGTH,1,-1 IF(NAME(I:I).NE.' ')THEN N=I GOTO 10 ENDIF N=1 ENDDO 10 CONTINUE LENGTH=N ENDIF CALL DATTIM(DATE,TIME) WRITE(12,'(A,'' on '',A8,'' at '',A8,2X,A)',ERR=2010,IOSTAT=IOS) - NAME(1:LENGTH),DATE,TIME,TEXT CLOSE(UNIT=12,ERR=2030,IOSTAT=IOS) RETURN *** I/O errors, ignore unless debugging mode is on. 2010 CONTINUE IF(LDEBUG)WRITE(LUNOUT,'(1X,A)') ' ++++++ JOBLOG DEBUG :'// - ' An I/O error occurred while writing the log entry.' IF(LDEBUG)CALL INPIOS(IOS) CLOSE(UNIT=12,ERR=2030,IOSTAT=IOS) RETURN 2020 CONTINUE IF(LDEBUG)WRITE(LUNOUT,'(1X,A)') ' ++++++ JOBLOG DEBUG :'// - ' An error occurred while opening the log file.' IF(LDEBUG)CALL INPIOS(IOS) RETURN 2030 CONTINUE IF(LDEBUG)WRITE(LUNOUT,'(1X,A)') ' ++++++ JOBLOG DEBUG :'// - ' An error occurred while closing the log file.' IF(LDEBUG)CALL INPIOS(IOS) END +DECK,QUIT. SUBROUTINE QUIT *----------------------------------------------------------------------- * QUIT - This routines calls some routines that print information * collected during the run and closes in batch mode the * display file. * (Last changed on 26/10/09.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. +SEQ,GRAPHICS. LOGICAL OPEN CHARACTER*20 OPSTR *** Close neBEM. CALL BEMEND *** Switch to graphics mode. CALL GRGRAF(.TRUE.) *** Keep track of statistics, inquiry errors. IERSUM=0 NOP=0 NOP0=0 NACT=0 NACT0=0 *** Determine Operating State value. CALL GQOPS(IOPSTA) *** Close current segment if open. IF(IOPSTA.EQ.4)CALL GCLSG *** Deactivate all active workstations, if appropriate. IF(IOPSTA.GE.3)THEN * Get number of open workstations. CALL GQACWK(0,IERR,NACT,IWK) IF(IERR.NE.0)IERSUM=IERSUM+1 * Loop over the open workstations. DO 10 I=NACT,1,-1 CALL GQACWK(I,IERR,IDUM,IWK) IF(IERR.NE.0)IERSUM=IERSUM+1 CALL GDAWK(IWK) WKSTAT(IWK)=2 WKSREQ(IWK)=2 +SELF,IF=HIGZ. CALL SGFLAG +SELF. 10 CONTINUE * Count the number of still active workstations. NACT0=NACT CALL GQACWK(0,IERR,NACT,IWK) IF(IERR.NE.0)IERSUM=IERSUM+1 ENDIF *** Close all open workstations. IF(IOPSTA.GE.2)THEN * Get number of active workstations. CALL GQOPWK(0,IERR,NOP,IWK) IF(IERR.NE.0)IERSUM=IERSUM+1 * Loop over the active workstations. DO 20 I=NOP,1,-1 * Get workstation identifier. CALL GQOPWK(I,IERR,IDUM,IWK) IF(IERR.NE.0)IERSUM=IERSUM+1 * Close the workstation. CALL GCLWK(IWK) WKSTAT(IWK)=1 WKSREQ(IWK)=1 * Check whether there is a file. IF(WKLUN(IWK).GT.0)THEN CLOSE(UNIT=WKLUN(IWK),STATUS='KEEP', - ERR=2034,IOSTAT=IOS) GOTO 90 2034 CONTINUE CALL INPIOS(IOS) PRINT *,' !!!!!! QUIT WARNING : Error closing'// - ' file associated to workstation ',IWK,'.' 90 CONTINUE ENDIF 20 CONTINUE * Count the number of still active workstations. NOP0=NOP CALL GQOPWK(0,IERR,NOP,IWK) IF(IERR.NE.0)IERSUM=IERSUM+1 ENDIF *** And print error messages if any. IF(NACT.NE.0)PRINT *,' !!!!!! QUIT WARNING : Unable to'// - ' deactivate all workstations.' IF(NOP.NE.0)PRINT *,' !!!!!! QUIT WARNING : Unable to'// - ' close all workstations.' IF(IERSUM.NE.0)PRINT *,' !!!!!! QUIT WARNING : Number of'// - ' inquiry errors during GKS close-down: ',IERSUM *** Print statistics if requested. IF(LDEBUG)THEN OPSTR='< unknown code >' IF(IOPSTA.EQ.0)OPSTR='GKS closed' IF(IOPSTA.EQ.1)OPSTR='GKS open' IF(IOPSTA.EQ.2)OPSTR='workstation open' IF(IOPSTA.EQ.3)OPSTR='workstation active' IF(IOPSTA.EQ.4)OPSTR='segment open' WRITE(LUNOUT,'(2X,''++++++ QUIT DEBUG : '', - ''GKS state was '',A20/26X, - ''Active workstations: '',I3,'' (was '',I3,'')''/26X, - ''Open workstations: '',I3,'' (was '',I3,'')''/26X, - ''Inquiry errors: '',I3)') - OPSTR,NACT,NACT0,NOP,NOP0,IERSUM ENDIF +SELF,IF=HIGZ. *** Close HIGZ. CALL IGTERM CALL IGEND +SELF,IF=-HIGZ. *** Close GKS itself. IF(IOPSTA.GE.1)CALL GCLKS +SELF. *** Close the GKS log file. INQUIRE(UNIT=10,OPENED=OPEN) IF(OPEN)CLOSE(UNIT=10,STATUS='KEEP',ERR=2030,IOSTAT=IOS) GOTO 50 * Error handling. 2030 CONTINUE CALL INPIOS(IOS) PRINT *,' !!!!!! QUIT WARNING : Error closing the'// - ' GKS error logging file during program termination.' 50 CONTINUE *** Close the main metafiles. INQUIRE(UNIT=11,OPENED=OPEN) IF(OPEN)THEN PRINT *,' !!!!!! QUIT WARNING : Found a metafile'// - ' left open on unit 11; closing the file.' CLOSE(UNIT=11,STATUS='KEEP',ERR=2031,IOSTAT=IOS) ENDIF GOTO 60 * Error handling. 2031 CONTINUE CALL INPIOS(IOS) PRINT *,' !!!!!! QUIT WARNING : Error closing a'// - ' graphics metafile during program termination.' 60 CONTINUE *** Close additional metafiles, there shouldn't be any. DO 30 I=40,49 INQUIRE(UNIT=I,OPENED=OPEN) IF(OPEN)THEN PRINT *,' !!!!!! QUIT WARNING : Found a metafile'// - ' left open on unit ',I,'; closing the file.' CLOSE(UNIT=I,STATUS='KEEP',ERR=2032,IOSTAT=IOS) ENDIF GOTO 30 * Error handling. 2032 CONTINUE CALL INPIOS(IOS) PRINT *,' !!!!!! QUIT WARNING : Error closing a'// - ' graphics metafile during program termination.' 30 CONTINUE *** Close the recording file. INQUIRE(UNIT=18,OPENED=OPEN) IF(OPEN)CLOSE(UNIT=18,STATUS='KEEP',ERR=2033,IOSTAT=IOS) GOTO 70 * Error handling. 2033 CONTINUE CALL INPIOS(IOS) PRINT *,' !!!!!! QUIT WARNING : Error closing the'// - ' input recording file during program termination.' 70 CONTINUE *** Print the graphics, dataset and timing log. CALL GRAPRT CALL DSNPRT CALL TIMLOG(' ') *** List objects still in memory. IF(LDEBUG)THEN PRINT *,' ++++++ QUIT DEBUG : Histograms ...' CALL HISADM('LIST',IREF,0,0.0,0.0,.TRUE.,IFAIL) PRINT *,' ++++++ QUIT DEBUG : Matrices ...' CALL MATADM('LIST',IDUM,NDUM,NDUM,NDUM,IFAIL1) PRINT *,' ++++++ QUIT DEBUG : Booked objects ...' CALL BOOK('LIST',' ',' ',IFAIL) PRINT *,' ++++++ QUIT DEBUG : Strings ...' CALL STRBUF('DUMP',IREF,' ',1,IFAIL) ENDIF +SELF,IF=AST. *** Stop AST handling CALL ASTXIT +SELF. *** Inform synchronisation. IF(LSYNCH)WRITE(6,'('' >>>>>> quit'')') +SELF,IF=BOINC. *** Inform BOINC that we're done. call boinc_finish(0) +SELF. *** And stop program execution. STOP END +DECK,SKIP. SUBROUTINE SKIP *----------------------------------------------------------------------- * SKIP - This routine places the pointer of the input file at the * next header. * (Last changed on 29/10/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. CHARACTER*(MXINCH) STRING INTEGER NC,NWORD LOGICAL STDSTR EXTERNAL STDSTR *** Set the prompt string. CALL INPPRM('Main','NEW-PRINT') *** The program is running in batch. IF(.NOT.STDSTR('INPUT'))THEN PRINT *,' ------ SKIP MESSAGE : The following section'// - ' is skipped.' * Print the current line if the INPUT option is off. IF(.NOT.LINPUT)THEN CALL INPNUM(NWORD) CALL INPSTR(1,NWORD,STRING,NC) PRINT *,' ====== SKIP INPUT : '// - STRING(1:MAX(1,NC)) ENDIF * Read a new input line, skip until a new header is found. 10 CONTINUE CALL INPWRD(NWORD) IF(NWORD.EQ.0)GOTO 10 CALL INPSTR(1,NWORD,STRING,NC) IF(STRING(1:1).NE.'&')THEN IF(.NOT.LINPUT)PRINT *,' ====== SKIP INPUT : '// - STRING(1:MAX(1,NC)) GOTO 10 ENDIF * The pointer should now be at the right position. PRINT *,' ------ SKIP MESSAGE : End of skipped input.' *** The program is running in an interactive environment. ELSE PRINT *,' !!!!!! SKIP WARNING : The section header'// - ' was rejected ; please try again.' 20 CONTINUE CALL INPWRD(NWORD) IF(NWORD.EQ.0)GOTO 20 CALL INPSTR(1,NWORD,STRING,NC) IF(STRING(1:1).NE.'&')THEN IF(.NOT.LINPUT)PRINT *,' ====== SKIP INPUT : '// - STRING(1:MAX(1,NC)) PRINT *,' !!!!!! SKIP WARNING : Please enter'// - ' a section header or a global command.' GOTO 20 ENDIF ENDIF END +PATCH,INPUT. +DECK,INPCAL. SUBROUTINE INPCAL(MODE,IENTRY,IFAIL) *----------------------------------------------------------------------- * INPCAL - Handles CALL statements in normal input. * (Last changed on 1/11/11.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,GLOBALS. +SEQ,PRINTPLOT. +SEQ,INPUT. +SEQ,ALGDATA. CHARACTER*(*) MODE LOGICAL USE(MXVAR),SQUOTE,DQUOTE,RQUOTE REAL RES(1) INTEGER MODRES(1),IENTRY,IFAIL,IFAIL1,ICALL,I,J,II,JJ,NLEV, - ISTART,IEND,I0,I1,I2,KARG,NNRES,IPROC,IENTNO,IFIRST,ILAST *** First few returns are all on IFAIL=1. IFAIL=1 *** Don't do anything if there is just 1 word. IF(NWORD.LE.1)THEN PRINT *,' !!!!!! INPCAL WARNING : CALL must be followed'// - ' by at least a routine name; ignored.' RETURN ENDIF *** Search for delimiters, initial values. ISTART=0 IEND=0 * Opening parenthesis. ICALL=INDEX(STRING,'CALL') DO 10 I=ICALL+4,MXINCH IF(STRING(I:I).EQ.'(')THEN ISTART=I+1 SQUOTE=.FALSE. DQUOTE=.FALSE. RQUOTE=.FALSE. NLEV=1 * Closing parenthesis. DO 30 J=ISTART,MXINCH IF(STRING(J:J).EQ.'(')THEN IF(.NOT.(SQUOTE.OR.DQUOTE.OR.RQUOTE))NLEV=NLEV+1 ELSEIF(STRING(J:J).EQ.')')THEN IF(.NOT.(SQUOTE.OR.DQUOTE.OR.RQUOTE))NLEV=NLEV-1 ELSEIF(STRING(J:J).EQ.'''')THEN SQUOTE=.NOT.SQUOTE ELSEIF(STRING(J:J).EQ.'"')THEN DQUOTE=.NOT.DQUOTE ELSEIF(STRING(J:J).EQ.'`')THEN RQUOTE=.NOT.RQUOTE ENDIF IF(NLEV.EQ.0)THEN IEND=J-1 IF(STRING(J:).NE.')')PRINT *,' !!!!!! INPCAL WARNING'// - ' : Extra characters after the closing'// - ' parenthesis are ignored.' GOTO 20 ENDIF 30 CONTINUE GOTO 20 ENDIF 10 CONTINUE 20 CONTINUE * Check syntax. IF((ISTART.EQ.0.AND.IEND.NE.0).OR. - (IEND.EQ.0.AND.ISTART.NE.0))THEN PRINT *,' !!!!!! INPCAL WARNING : The arguments of the'// - ' CALL statement are not' PRINT *,' properly delimited'// - ' ; statement is ignored.' RETURN ELSEIF(ISTART.EQ.0.AND.IEND.EQ.0.OR.ISTART.GT.IEND)THEN ISTART=0 IEND=0 GOTO 130 ELSEIF(STRING(ISTART:IEND).EQ.' ')THEN ISTART=0 IEND=0 GOTO 130 ENDIF *** Locate undeclared global variable arguments. I0=ISTART-1 KARG=0 * Find the beginning of the word. 100 CONTINUE I0=I0+1 IF(I0.GT.IEND)THEN PRINT *,' !!!!!! INPCAL WARNING : No argument found after'// - ' last delimiter.' GOTO 130 ENDIF IF(STRING(I0:I0).EQ.' ')GOTO 100 * First non-blank character a , ? IF(STRING(I0:I0).EQ.',')THEN PRINT *,' !!!!!! INPCAL WARNING : No argument found'// - ' between 2 delimiters.' GOTO 100 ENDIF * Find the end of the word. I2=I0-1 110 CONTINUE I2=I2+1 IF(STRING(I2:I2).EQ.',')THEN I2=I2-1 ELSEIF(I2.LT.IEND)THEN GOTO 110 ENDIF * And remove trailing blanks. I1=I2+1 120 CONTINUE I1=I1-1 IF(I1.LT.I0)THEN PRINT *,' !!!!!! INPCAL WARNING : Argument string ',KARG+1, - ' is entirely blank.' ELSEIF(STRING(I1:I1).EQ.' ')THEN GOTO 120 ENDIF * See whether this is a valid variable name. IF(I1.GE.I0)THEN KARG=KARG+1 IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ INPCAL DEBUG :'', - '' Argument '',I3,'': '',A)') KARG,STRING(I0:I1) IF(INDEX('ABCDEFGHIJKLMNOPQRSTUVWXYZ', - STRING(I0:I0)).EQ.0.OR. - STRING(I0:I1).EQ.'PI'.OR. - STRING(I0:I1).EQ.'FALSE'.OR. - STRING(I0:I1).EQ.'TRUE'.OR. - STRING(I0:I1).EQ.'RND_UNIFORM'.OR. - STRING(I0:I1).EQ.'RND_GAUSS'.OR. - STRING(I0:I1).EQ.'RND_NORMAL'.OR. - STRING(I0:I1).EQ.'RND_EXP'.OR. - STRING(I0:I1).EQ.'RND_EXPONENTIAL'.OR. - STRING(I0:I1).EQ.'RND_POISSON'.OR. - STRING(I0:I1).EQ.'RND_POLYA'.OR. - STRING(I0:I1).EQ.'RND_GAMMA'.OR. - STRING(I0:I1).EQ.'RND_LANDAU'.OR. - STRING(I0:I1).EQ.'RND_LAPLACE'.OR. - STRING(I0:I1).EQ.'RND_FUNCTION')GOTO 150 DO 140 II=I0+1,I1 IF(INDEX('+-*/&|<=#>^ ,.:;([{)]}''"`',STRING(II:II)).NE.0) - GOTO 150 140 CONTINUE DO 160 JJ=1,NGLB IF(GLBVAR(JJ).EQ.STRING(I0:I1))GOTO 150 160 CONTINUE IF(LDEBUG)WRITE(LUNOUT,'(26X,''Is an undeclared global.'')') IF(NGLB.LT.MXVAR)THEN NGLB=NGLB+1 GLBVAR(NGLB)=STRING(I0:I1) GLBVAL(NGLB)=0 GLBMOD(NGLB)=0 IF(I1-I0+1.GT.LEN(GLBVAR(NGLB)))THEN PRINT *,' !!!!!! INPCAL WARNING : '// - STRING(I0:I1)//' is too long for a'// - ' variable name; has been truncated.' ELSE WRITE(LUNOUT,'('' ------ INPCAL MESSAGE : '',A, - '' declared as a global variable.'')') - STRING(I0:I1) ENDIF ELSE PRINT *,' !!!!!! INPCAL WARNING : No room left to', - ' store ',STRING(I0:I1),' as a global variable.' RETURN ENDIF 150 CONTINUE ENDIF * Next element. I0=I2+1 IF(I0.LE.IEND)GOTO 100 * Finished. 130 CONTINUE *** Pass the argument on to ALGPRE to build an instruction list. IF(ISTART.EQ.0.AND.IEND.EQ.0)THEN CALL ALGPRE('1',1,GLBVAR,NGLB,NNRES,USE,IENTRY,IFAIL1) ELSE CALL ALGPRE(STRING(ISTART:IEND),IEND-ISTART+1, - GLBVAR,NGLB,NNRES,USE,IENTRY,IFAIL1) ENDIF IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! INPCAL WARNING : The arguments of the'// - ' CALL statement can' PRINT *,' not be translated ;'// - ' statement is ignored.' IF(MODE.EQ.'EXECUTE')CALL ALGCLR(IENTRY) RETURN ENDIF * Locate the entry point number. IENTNO=0 DO 80 I=1,NALGE IF(ALGENT(I,1).EQ.IENTRY)IENTNO=I 80 CONTINUE IF(IENTNO.EQ.0)THEN PRINT *,' !!!!!! INPCAL WARNING : Unable to find the'// - ' entry point; program bug.' IF(MODE.EQ.'EXECUTE')CALL ALGCLR(IENTRY) RETURN ENDIF *** Scan the instruction list, change RESULT into ARGUMENT. DO 50 I=ALGENT(IENTNO,5),ALGENT(IENTNO,5)+ALGENT(IENTNO,6)-1 IF(INS(I,2).NE.0)GOTO 50 IF(INS(I,3).LE.NGLB.AND.INS(I,3).GT.0)THEN INS(I,1)=0 ELSE INS(I,1)=2 ENDIF INS(I,2)=8 50 CONTINUE *** Locate the routine name, first isolate the name. IFIRST=0 ILAST=NCHAR(2) DO 60 I=1,NCHAR(2) IF(IFIRST.EQ.0.AND.WORD(2)(I:I).NE.' ')IFIRST=I IF(WORD(2)(I:I).EQ.' '.OR.WORD(2)(I:I).EQ.'(')THEN ILAST=I-1 GOTO 70 ENDIF 60 CONTINUE 70 CONTINUE *** Check it is not blank. IF(IFIRST.EQ.0.OR.ILAST.LT.IFIRST)THEN PRINT *,' !!!!!! INPCAL WARNING : The routine name is'// - ' blank or null; CALL ignored.' IF(MODE.EQ.'EXECUTE')CALL ALGCLR(IENTRY) RETURN ENDIF *** Identify, first general purpose printing. IF(WORD(2)(IFIRST:ILAST).EQ.'PRINT')THEN IPROC=-1 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'TIME_DELAY')THEN IPROC=-2 * Cell related calls. ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'GET_CELL_DATA')THEN IPROC=-11 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'GET_CELL_SIZE')THEN IPROC=-12 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'GET_WIRE'.OR. - WORD(2)(IFIRST:ILAST).EQ.'GET_WIRE_DATA')THEN IPROC=-13 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'GET_X_PLANES')THEN IPROC=-14 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'GET_Y_PLANES')THEN IPROC=-15 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'GET_PERIODS')THEN IPROC=-16 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'GET_SOLID_DATA')THEN IPROC=-17 * String manipulation. ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'STRING_INDEX')THEN IPROC=-901 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'STRING_PORTION')THEN IPROC=-902 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'STRING_DELETE')THEN IPROC=-903 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'STRING_LOWER')THEN IPROC=-904 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'STRING_UPPER')THEN IPROC=-905 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'STRING_WORDS')THEN IPROC=-906 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'STRING_WORD')THEN IPROC=-907 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'STRING_MATCH')THEN IPROC=-908 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'STRING_REPLACE')THEN IPROC=-909 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'STRING_LISTING'.OR. - WORD(2)(IFIRST:ILAST).EQ.'STRING_LIST'.OR. - WORD(2)(IFIRST:ILAST).EQ.'LIST_STRINGS'.OR. - WORD(2)(IFIRST:ILAST).EQ.'LIST_STRING'.OR. - WORD(2)(IFIRST:ILAST).EQ.'SLIST')THEN IPROC=-910 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'STRING_LENGTH')THEN IPROC=-911 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'DELETE_STRING'.OR. - WORD(2)(IFIRST:ILAST).EQ.'DELETE_STRINGS')THEN IPROC=-912 * File handling. ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'INQUIRE_TYPE'.OR. - WORD(2)(IFIRST:ILAST).EQ.'QTYPE')THEN IPROC=-50 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'INQUIRE_FILE'.OR. - WORD(2)(IFIRST:ILAST).EQ.'QFILE')THEN IPROC=-51 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'INQUIRE_MEMBER'.OR. - WORD(2)(IFIRST:ILAST).EQ.'QMEMBER')THEN IPROC=-52 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'OBJECT_LISTING'.OR. - WORD(2)(IFIRST:ILAST).EQ.'LIST_OBJECTS'.OR. - WORD(2)(IFIRST:ILAST).EQ.'LIST_OBJECT'.OR. - WORD(2)(IFIRST:ILAST).EQ.'OLIST')THEN IPROC=-53 * Fitting. ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'FIT_GAUSSIAN')THEN IPROC=-60 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'FIT_POLYNOMIAL')THEN IPROC=-61 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'FIT_EXPONENTIAL')THEN IPROC=-62 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'FIT_POLYA')THEN IPROC=-63 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'FIT_FUNCTION')THEN IPROC=-64 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'FIT_MATHIESON')THEN IPROC=-65 * Signal related calls. ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'THRESHOLD_CROSSING')THEN IPROC=-70 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'GET_SIGNAL')THEN IPROC=-71 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'STORE_SIGNAL')THEN IPROC=-72 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'GET_RAW_SIGNAL')THEN IPROC=-73 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'LIST_RAW_SIGNALS')THEN IPROC=-74 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'SIGNAL_FIELD'.OR. - WORD(2)(IFIRST:ILAST).EQ.'WEIGHTING_FIELD')THEN IPROC=-75 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'SIGNAL_FIELD_3'.OR. - WORD(2)(IFIRST:ILAST).EQ.'WEIGHTING_FIELD_3')THEN IPROC=-76 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'INDUCED_CHARGE'.OR. - WORD(2)(IFIRST:ILAST).EQ.'QIN')THEN IPROC=-77 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'ADD_SIGNAL'.OR. - WORD(2)(IFIRST:ILAST).EQ.'ADD_SIGNALS')THEN IPROC=-78 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'AVALANCHE_SIGNAL')THEN IPROC=-79 * Matrix procedures. ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'EXTRACT_SUBMATRIX')THEN IPROC=-80 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'STORE_SUBMATRIX')THEN IPROC=-81 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'PRINT_MATRIX'.OR. - WORD(2)(IFIRST:ILAST).EQ.'PRINT_MATRICES'.OR. - WORD(2)(IFIRST:ILAST).EQ.'MPRINT')THEN IPROC=-82 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'BOOK_MATRIX'.OR. - WORD(2)(IFIRST:ILAST).EQ.'MBOOK')THEN IPROC=-83 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'RESHAPE_MATRIX')THEN IPROC=-84 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'ADJUST_MATRIX')THEN IPROC=-85 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'DELETE_MATRIX'.OR. - WORD(2)(IFIRST:ILAST).EQ.'DELETE_MATRICES'.OR. - WORD(2)(IFIRST:ILAST).EQ.'MDELETE')THEN IPROC=-86 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'LIST_MATRIX'.OR. - WORD(2)(IFIRST:ILAST).EQ.'LIST_MATRICES'.OR. - WORD(2)(IFIRST:ILAST).EQ.'MLIST')THEN IPROC=-87 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'WRITE_MATRIX'.OR. - WORD(2)(IFIRST:ILAST).EQ.'MWRITE')THEN IPROC=-88 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'GET_MATRIX'.OR. - WORD(2)(IFIRST:ILAST).EQ.'MGET')THEN IPROC=-89 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'MULTIPLY_MATRICES')THEN IPROC=-90 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'SOLVE_EQUATION')THEN IPROC=-91 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'DIMENSIONS'.OR. - WORD(2)(IFIRST:ILAST).EQ.'DIMENSION')THEN IPROC=-92 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'INTERPOLATE')THEN IPROC=-93 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'PLOT_SURFACE')THEN IPROC=-94 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'DERIVATIVE')THEN IPROC=-95 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'INTERPOLATE_1')THEN IPROC=-96 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'INTERPOLATE_2')THEN IPROC=-97 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'INTERPOLATE_3')THEN IPROC=-98 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'INTERPOLATE_4')THEN IPROC=-99 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'PLOT_CONTOUR'.OR. - WORD(2)(IFIRST:ILAST).EQ.'PLOT_CONTOURS')THEN IPROC=-100 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'PLOT_ERROR_BAND'.OR. - WORD(2)(IFIRST:ILAST).EQ.'ERROR_BAND')THEN IPROC=-101 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'ZERO'.OR. - WORD(2)(IFIRST:ILAST).EQ.'ZEROES')THEN IPROC=-102 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'PLOT_BARCHART'.OR. - WORD(2)(IFIRST:ILAST).EQ.'PLOT_BARCHART'.OR. - WORD(2)(IFIRST:ILAST).EQ.'PLOT_BAR_CHART'.OR. - WORD(2)(IFIRST:ILAST).EQ.'PLOT_BAR_CHART')THEN IPROC=-103 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'SORT'.OR. - WORD(2)(IFIRST:ILAST).EQ.'SORT_MATRIX')THEN IPROC=-104 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'PLOT_3D')THEN IPROC=-105 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'LOCATE_MAXIMUM')THEN IPROC=-106 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'LOCATE_MINIMUM')THEN IPROC=-107 * Gas related procedures. ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'GAS_AVAILABILITY')THEN IPROC=-201 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'GET_GAS_DATA')THEN IPROC=-202 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'DRIFT_VELOCITY_E'.OR. - WORD(2)(IFIRST:ILAST).EQ.'VELOCITY_E')THEN IPROC=-203 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'ION_MOBILITY')THEN IPROC=-204 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'LONGITUDINAL_DIFFUSION'.OR. - WORD(2)(IFIRST:ILAST).EQ.'SIGMA_L')THEN IPROC=-205 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'TOWNSEND'.OR. - WORD(2)(IFIRST:ILAST).EQ.'TOWNSEND_COEFFICIENT'.OR. - WORD(2)(IFIRST:ILAST).EQ.'TOWNSEND_COEFFICIENTS')THEN IPROC=-206 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'ATTACHMENT'.OR. - WORD(2)(IFIRST:ILAST).EQ.'ATTACHMENT_COEFFICIENT'.OR. - WORD(2)(IFIRST:ILAST).EQ.'ATTACHMENT_COEFFICIENTS')THEN IPROC=-207 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'LORENTZ_ANGLES'.OR. - WORD(2)(IFIRST:ILAST).EQ.'LORENTZ_ANGLE'.OR. - WORD(2)(IFIRST:ILAST).EQ.'VE_ANGLES'.OR. - WORD(2)(IFIRST:ILAST).EQ.'VE_ANGLE')THEN IPROC=-208 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'TRANSVERSE_DIFFUSION'.OR. - WORD(2)(IFIRST:ILAST).EQ.'SIGMA_T')THEN IPROC=-209 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'DRIFT_VELOCITY'.OR. - WORD(2)(IFIRST:ILAST).EQ.'VELOCITY')THEN IPROC=-210 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'DRIFT_VELOCITY_BTRANSVERSE'.OR. - WORD(2)(IFIRST:ILAST).EQ.'VELOCITY_BTRANSVERSE'.OR. - WORD(2)(IFIRST:ILAST).EQ.'DRIFT_VELOCITY_BTRANSVERSAL'.OR. - WORD(2)(IFIRST:ILAST).EQ.'VELOCITY_BTRANSVERSAL'.OR. - WORD(2)(IFIRST:ILAST).EQ.'DRIFT_VELOCITY_BTRANS'.OR. - WORD(2)(IFIRST:ILAST).EQ.'VELOCITY_BTRANS'.OR. - WORD(2)(IFIRST:ILAST).EQ.'DRIFT_VELOCITY_B'.OR. - WORD(2)(IFIRST:ILAST).EQ.'VELOCITY_B')THEN IPROC=-211 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'DRIFT_VELOCITY_EXB'.OR. - WORD(2)(IFIRST:ILAST).EQ.'VELOCITY_EXB')THEN IPROC=-212 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'DIFFUSION_TENSOR')THEN IPROC=-213 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'GET_E/P_TABLE')THEN IPROC=-214 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'ION_DISSOCIATION'.OR. - WORD(2)(IFIRST:ILAST).EQ. - 'ION_DISSOCIATION_COEFFICIENT'.OR. - WORD(2)(IFIRST:ILAST).EQ. - 'ION_DISSOCIATION_COEFFICIENTS'.OR. - WORD(2)(IFIRST:ILAST).EQ.'DISSOCIATION'.OR. - WORD(2)(IFIRST:ILAST).EQ. - 'DISSOCIATION_COEFFICIENT'.OR. - WORD(2)(IFIRST:ILAST).EQ. - 'DISSOCIATION_COEFFICIENTS')THEN IPROC=-215 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'EXCITATION_ID'.OR. - WORD(2)(IFIRST:ILAST).EQ.'EXC_ID'.OR. - WORD(2)(IFIRST:ILAST).EQ.'EXCITATION_IDENTIFIER'.OR. - WORD(2)(IFIRST:ILAST).EQ.'EXCITATION_NAME')THEN IPROC=-216 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'IONISATION_ID'.OR. - WORD(2)(IFIRST:ILAST).EQ.'ION_ID'.OR. - WORD(2)(IFIRST:ILAST).EQ.'IONISATION_IDENTIFIER'.OR. - WORD(2)(IFIRST:ILAST).EQ.'IONISATION_NAME')THEN IPROC=-217 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'CROSS_SECTION_ID'.OR. - WORD(2)(IFIRST:ILAST).EQ.'CS_ID'.OR. - WORD(2)(IFIRST:ILAST).EQ.'CROSS_SECTION_IDENTIFIER'.OR. - WORD(2)(IFIRST:ILAST).EQ.'CROSS_SECTION_NAME')THEN IPROC=-218 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'LEVEL_COUNT'.OR. - WORD(2)(IFIRST:ILAST).EQ.'LEVELS_COUNT'.OR. - WORD(2)(IFIRST:ILAST).EQ.'COUNT_LEVEL'.OR. - WORD(2)(IFIRST:ILAST).EQ.'COUNT_LEVELS')THEN IPROC=-219 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'EXCITATION_RATE'.OR. - WORD(2)(IFIRST:ILAST).EQ.'EXC_RATE')THEN IPROC=-220 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'IONISATION_RATE'.OR. - WORD(2)(IFIRST:ILAST).EQ.'ION_RATE')THEN IPROC=-221 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'EXTRACT_LEVELS')THEN IPROC=-222 * Electric and magnetic field. ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'ELECTRIC_FIELD'.OR. - WORD(2)(IFIRST:ILAST).EQ.'EFIELD'.OR. - WORD(2)(IFIRST:ILAST).EQ.'ELECTRIC_FIELD_2'.OR. - WORD(2)(IFIRST:ILAST).EQ.'EFIELD2')THEN IPROC=-301 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'ELECTRIC_FIELD_3'.OR. - WORD(2)(IFIRST:ILAST).EQ.'EFIELD3')THEN IPROC=-302 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'FORCE_FIELD')THEN IPROC=-303 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'MAGNETIC_FIELD'.OR. - WORD(2)(IFIRST:ILAST).EQ.'BFIELD')THEN IPROC=-304 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'MAGNETIC_FIELD_3'.OR. - WORD(2)(IFIRST:ILAST).EQ.'BFIELD3')THEN IPROC=-305 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'INTEGRATE_CHARGE'.OR. - WORD(2)(IFIRST:ILAST).EQ.'CHARGE')THEN IPROC=-306 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'INTEGRATE_FLUX'.OR. - WORD(2)(IFIRST:ILAST).EQ.'FLUX')THEN IPROC=-307 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'MAP_INDEX')THEN IPROC=-310 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'MAP_ELEMENT')THEN IPROC=-311 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'MAP_MATERIAL')THEN IPROC=-312 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'PLOT_FIELD_AREA')THEN IPROC=-320 * Timing, progress logging. ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'TIME_LOG'.OR. - WORD(2)(IFIRST:ILAST).EQ.'TIME_LOGGING')THEN IPROC=-401 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'PROGRESS_SET')THEN IPROC=-402 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'PROGRESS_PRINT')THEN IPROC=-403 +SELF,IF=LINUX,MACOSX. ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'SLEEP')THEN IPROC=-404 +SELF. * Drifting. ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'NEW_TRACK')THEN IPROC=-501 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'GET_CLUSTER')THEN IPROC=-502 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'DRIFT_ELECTRON')THEN IPROC=-503 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'DRIFT_ION')THEN IPROC=-504 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'DRIFT_ELECTRON_3')THEN IPROC=-505 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'DRIFT_ION_3')THEN IPROC=-506 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'GET_DRIFT_LINE')THEN IPROC=-507 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'DRIFT_MC_ELECTRON'.OR. - WORD(2)(IFIRST:ILAST).EQ.'DRIFT_ELECTRON_MC')THEN IPROC=-508 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'DRIFT_MC_ION'.OR. - WORD(2)(IFIRST:ILAST).EQ.'DRIFT_ION_MC')THEN IPROC=-509 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'PLOT_DRIFT_LINE')THEN IPROC=-510 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'PLOT_TRACK')THEN IPROC=-511 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'AVALANCHE')THEN IPROC=-512 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'PLOT_DRIFT_AREA')THEN IPROC=-513 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'DRIFT_NEGATIVE_ION')THEN IPROC=-514 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'DRIFT_NEGATIVE_ION_3')THEN IPROC=-515 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'DRIFT_MC_NEGATIVE_ION')THEN IPROC=-516 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'DRIFT_VACUUM_ELECTRON')THEN IPROC=-517 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'DRIFT_VACUUM_ION')THEN IPROC=-518 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'DRIFT_MC_TEST')THEN IPROC=-519 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'DRIFT_INFORMATION'.OR. - WORD(2)(IFIRST:ILAST).EQ.'DRIFT_INFO')THEN IPROC=-520 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'DRIFT_POSITRON')THEN IPROC=-521 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'DRIFT_POSITRON_3')THEN IPROC=-522 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'DRIFT_MC_POSITRON')THEN IPROC=-523 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'INTERPOLATE_TRACK')THEN IPROC=-524 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'RND_MULTIPLICATION')THEN IPROC=-525 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'ELECTRON_VELOCITY')THEN IPROC=-526 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'ION_VELOCITY')THEN IPROC=-527 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'PRINT_DRIFT_LINE')THEN IPROC=-528 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'DRIFT_DIVERGENCE')THEN IPROC=-529 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'DRIFT_ROTATION')THEN IPROC=-530 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'INTEGRATE_EXCITATIONS')THEN IPROC=-531 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'INTEGRATE_IONISATIONS')THEN IPROC=-532 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'DRIFT_MICROSCOPIC_ELECTRON'.OR. - WORD(2)(IFIRST:ILAST).EQ.'DRIFT_ELECTRON_MICROSCOPIC'.OR. - WORD(2)(IFIRST:ILAST).EQ.'DRIFT_MICROSCOPIC')THEN IPROC=-533 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'AVALANCHE_MICROSCOPIC'.OR. - WORD(2)(IFIRST:ILAST).EQ.'MICROSCOPIC_AVALANCHE')THEN IPROC=-534 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'AVALANCHE_INFORMATION'.OR. - WORD(2)(IFIRST:ILAST).EQ.'AVALANCHE_INFO')THEN IPROC=-535 * Histograms. ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'BOOK_HISTOGRAM'.OR. - WORD(2)(IFIRST:ILAST).EQ.'HBOOK')THEN IPROC=-602 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'FILL_HISTOGRAM'.OR. - WORD(2)(IFIRST:ILAST).EQ.'HFILL')THEN IPROC=-603 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'PLOT_HISTOGRAM'.OR. - WORD(2)(IFIRST:ILAST).EQ.'HPLOT')THEN IPROC=-604 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'PRINT_HISTOGRAM'.OR. - WORD(2)(IFIRST:ILAST).EQ.'HPRINT')THEN IPROC=-605 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'DELETE_HISTOGRAM'.OR. - WORD(2)(IFIRST:ILAST).EQ.'DELETE_HISTOGRAMS'.OR. - WORD(2)(IFIRST:ILAST).EQ.'HDELETE')THEN IPROC=-606 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'LIST_HISTOGRAMS'.OR. - WORD(2)(IFIRST:ILAST).EQ.'HLIST')THEN IPROC=-607 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'WRITE_HISTOGRAM'.OR. - WORD(2)(IFIRST:ILAST).EQ.'HWRITE')THEN IPROC=-608 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'GET_HISTOGRAM'.OR. - WORD(2)(IFIRST:ILAST).EQ.'HGET')THEN IPROC=-609 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'INQUIRE_HISTOGRAM'.OR. - WORD(2)(IFIRST:ILAST).EQ.'QHIST')THEN IPROC=-610 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'CONVOLUTE')THEN IPROC=-611 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'BARYCENTRE'.OR. - WORD(2)(IFIRST:ILAST).EQ.'BARYCENTER')THEN IPROC=-612 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'HISTOGRAM_TO_MATRIX')THEN IPROC=-613 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'MATRIX_TO_HISTOGRAM')THEN IPROC=-614 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'WRITE_HISTOGRAM_RZ'.OR. - WORD(2)(IFIRST:ILAST).EQ.'WRITE_HISTOGRAMS_RZ'.OR. - WORD(2)(IFIRST:ILAST).EQ.'HROUT')THEN IPROC=-615 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'CUT_HISTOGRAM'.OR. - WORD(2)(IFIRST:ILAST).EQ.'HCUT')THEN IPROC=-616 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'REBIN_HISTOGRAM'.OR. - WORD(2)(IFIRST:ILAST).EQ.'HREBIN')THEN IPROC=-617 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'RESET_HISTOGRAM'.OR. - WORD(2)(IFIRST:ILAST).EQ.'HRESET')THEN IPROC=-618 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'CUMULATE_HISTOGRAM'.OR. - WORD(2)(IFIRST:ILAST).EQ.'HCUMUL')THEN IPROC=-619 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'SKIP_HISTOGRAM'.OR. - WORD(2)(IFIRST:ILAST).EQ.'HSKIP')THEN IPROC=-620 * Utility routines. ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'CARTESIAN_TO_POLAR'.OR. - WORD(2)(IFIRST:ILAST).EQ.'CTP')THEN IPROC=-701 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'CARTESIAN_TO_INTERNAL'.OR. - WORD(2)(IFIRST:ILAST).EQ.'CTR')THEN IPROC=-702 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'POLAR_TO_CARTESIAN'.OR. - WORD(2)(IFIRST:ILAST).EQ.'PTC')THEN IPROC=-703 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'POLAR_TO_INTERNAL'.OR. - WORD(2)(IFIRST:ILAST).EQ.'PTR')THEN IPROC=-704 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'INTERNAL_TO_CARTESIAN'.OR. - WORD(2)(IFIRST:ILAST).EQ.'RTC')THEN IPROC=-705 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'INTERNAL_TO_POLAR'.OR. - WORD(2)(IFIRST:ILAST).EQ.'RTP')THEN IPROC=-706 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'PREPARE_RND_FUNCTION')THEN IPROC=-710 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'EXTREMUM')THEN IPROC=-711 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'INITIALISE_GENERATORS')THEN IPROC=-712 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'VAVILOV')THEN IPROC=-713 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'RND_VAVILOV_FAST')THEN IPROC=-714 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'RND_VAVILOV')THEN IPROC=-715 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'RND_IONISATION_ENERGY')THEN IPROC=-716 * Plotting. ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'PLOT_FRAME')THEN IPROC=-801 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'PLOT_END')THEN IPROC=-802 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'PLOT_MARKER'.OR. - WORD(2)(IFIRST:ILAST).EQ.'PLOT_MARKERS')THEN IPROC=-803 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'PLOT_LINE'.OR. - WORD(2)(IFIRST:ILAST).EQ.'PLOT_VECTOR'.OR. - WORD(2)(IFIRST:ILAST).EQ.'PLOT_VECTORS')THEN IPROC=-804 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'PLOT_TEXT')THEN IPROC=-805 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'PLOT_COMMENT')THEN IPROC=-806 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'PLOT_AREA')THEN IPROC=-807 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'PLOT_GRAPH')THEN IPROC=-808 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'PLOT_ERROR_BAR'.OR. - WORD(2)(IFIRST:ILAST).EQ.'PLOT_ERROR_BARS'.OR. - WORD(2)(IFIRST:ILAST).EQ.'ERROR_BAR'.OR. - WORD(2)(IFIRST:ILAST).EQ.'ERROR_BARS')THEN IPROC=-809 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'PROJECT_LINE')THEN IPROC=-810 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'PROJECT_MARKER'.OR. - WORD(2)(IFIRST:ILAST).EQ.'PROJECT_MARKERS')THEN IPROC=-811 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'PLOT_START')THEN IPROC=-812 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'GKS_WINDOW'.OR. - WORD(2)(IFIRST:ILAST).EQ.'GSWN')THEN IPROC=-813 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'GKS_VIEWPORT'.OR. - WORD(2)(IFIRST:ILAST).EQ.'GSVP')THEN IPROC=-814 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'GKS_SELECT_NT'.OR. - WORD(2)(IFIRST:ILAST).EQ.'GSELNT')THEN IPROC=-815 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'GKS_POLYLINE')THEN IPROC=-816 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'GKS_POLYMARKER')THEN IPROC=-817 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'SET_POLYLINE_ATTRIBUTES'.OR. - WORD(2)(IFIRST:ILAST).EQ.'SET_LINE_ATTRIBUTES')THEN IPROC=-818 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'SET_POLYMARKER_ATTRIBUTES'.OR. - WORD(2)(IFIRST:ILAST).EQ.'SET_MARKER_ATTRIBUTES')THEN IPROC=-819 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'SET_TEXT_ATTRIBUTES')THEN IPROC=-820 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'SET_AREA_ATTRIBUTES')THEN IPROC=-821 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'GKS_TEXT')THEN IPROC=-822 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'GKS_AREA')THEN IPROC=-823 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'GKS_SET_TEXT_ALIGNMENT'.OR. - WORD(2)(IFIRST:ILAST).EQ.'GSTXAL')THEN IPROC=-824 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'GKS_SET_TEXT_COLOUR'.OR. - WORD(2)(IFIRST:ILAST).EQ.'GSTXCI')THEN IPROC=-825 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'GKS_SET_CHARACTER_HEIGHT'.OR. - WORD(2)(IFIRST:ILAST).EQ.'GSCHH')THEN IPROC=-826 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'GKS_SET_CHARACTER_EXPANSION'.OR. - WORD(2)(IFIRST:ILAST).EQ.'GSCHXP')THEN IPROC=-827 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'GKS_SET_CHARACTER_SPACING'.OR. - WORD(2)(IFIRST:ILAST).EQ.'GSCHSP')THEN IPROC=-828 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'GKS_SET_CHARACTER_UP_VECTOR'.OR. - WORD(2)(IFIRST:ILAST).EQ.'GSCHUP')THEN IPROC=-829 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'GKS_SET_TEXT_FONT_PRECISION'.OR. - WORD(2)(IFIRST:ILAST).EQ.'GSTXFP')THEN IPROC=-830 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'PLOT_OBLIQUE_ERROR_BAR'.OR. - WORD(2)(IFIRST:ILAST).EQ.'PLOT_OBLIQUE_ERROR_BARS'.OR. - WORD(2)(IFIRST:ILAST).EQ.'OBLIQUE_ERROR_BAR'.OR. - WORD(2)(IFIRST:ILAST).EQ.'OBLIQUE_ERROR_BARS')THEN IPROC=-831 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'PLOT_ARROW')THEN IPROC=-850 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'PLOT_TITLE')THEN IPROC=-851 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'PLOT_X_LABEL')THEN IPROC=-852 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'PLOT_Y_LABEL')THEN IPROC=-853 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'RAINBOW')THEN IPROC=-854 * Rest is not known. ELSE PRINT *,' !!!!!! INPCAL WARNING : Procedure '// - WORD(2)(IFIRST:ILAST)//' is not known; not called.' IF(MODE.EQ.'EXECUTE')CALL ALGCLR(IENTRY) RETURN ENDIF *** Add the CALL statement to the instruction list. IF(NINS.GE.MXINS)THEN PRINT *,' !!!!!! INPCAL WARNING : Instruction list buffer'// - ' is full; CALL statement not processed.' IF(MODE.EQ.'EXECUTE')CALL ALGCLR(IENTRY) RETURN ENDIF IF(ISTART.EQ.0.AND.IEND.EQ.0)THEN INS(NINS-1,1)=IPROC INS(NINS-1,2)=9 INS(NINS-1,3)=0 INS(NINS-1,4)=0 ALGENT(IENTNO,6)=2 ALGENT(IENTNO,10)=0 ELSE INS(NINS+1,1)=INS(NINS,1) INS(NINS+1,2)=INS(NINS,2) INS(NINS+1,3)=INS(NINS,3) INS(NINS+1,4)=INS(NINS,4) INS(NINS,1)=IPROC INS(NINS,2)=9 INS(NINS,3)=NNRES INS(NINS,4)=0 NINS=NINS+1 ALGENT(IENTNO,6)=ALGENT(IENTNO,6)+1 ALGENT(IENTNO,10)=0 ENDIF *** In debug mode, print the list. IF(LDEBUG)THEN WRITE(LUNOUT,'('' ++++++ INPCAL DEBUG : Instruction'', - '' list after processing for CALL statement:'')') CALL ALGPRT(ALGENT(IENTNO,5),ALGENT(IENTNO,5)+ - ALGENT(IENTNO,6)-1) ENDIF *** Execute and clear the instruction list, if requested. IF(MODE.EQ.'EXECUTE')THEN CALL TIMEL(GLBVAL(1)) CALL ALGEXE(IENTRY,GLBVAL,GLBMOD,NGLB,RES,MODRES,0,IFAIL1) CALL ALGERR CALL ALGCLR(IENTRY) ENDIF *** Things seem to have worked. IFAIL=0 END +DECK,INPCDO. SUBROUTINE INPCDO *----------------------------------------------------------------------- * INPCDO - Cleans up the current DO loop. * (Last changed on 1/11/01.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,DOLOOP. +SEQ,GLOBALS. INTEGER I,J,NC,IFAIL CHARACTER STRING *** Clean up entry points. DO 10 I=1,NLOOP IF(DOREF(I,9).GT.0)THEN DO 20 J=1,5 IF(DOREF(I,J).GT.0)CALL ALGCLR(DOREF(I,J)) 20 CONTINUE IF(DOREF(I,11).GT.0)CALL ALGCLR(DOREF(I,11)) ELSE DO 30 J=3,4 IF(DOREF(I,J).GT.0)CALL ALGCLR(DOREF(I,J)) 30 CONTINUE ENDIF 10 CONTINUE *** Remove the lines from the string buffer and entries for IF's. DO 40 I=1,NDOLIN * Global statements. IF(LINREF(I,1).EQ.21.AND.LINREF(I,8).GT.0) - CALL ALGCLR(LINREF(I,8)) * Call statements. IF(LINREF(I,1).EQ.22.AND.LINREF(I,8).GT.0) - CALL ALGCLR(LINREF(I,8)) * Leading IF ... THEN ... parts. IF(LINREF(I,4).GT.0)CALL ALGCLR(LINREF(I,4)) * Strings associated with instructions. CALL STRBUF('DELETE',LINREF(I,2),STRING,NC,IFAIL) IF(IFAIL.NE.0)PRINT *,' !!!!!! INPCDO WARNING : Unable to'// - ' delete a line from the string buffer; bug - no problem.' 40 CONTINUE *** Reset the number of DO lines to disallow reexecution. NDOLIN=-1 NLOOP=-1 ISTATE=-1 END +DECK,INPCHK. SUBROUTINE INPCHK(IWRD,IFMT,IFAIL) *----------------------------------------------------------------------- * INPCHK - Routine checking the validity of numeric input and applying * corrections if necessary, before the Fortran input routines * are called. * VARIABLES : IFMT : Expected type 0=char,1=int,2=real,3=hex * IEXP : 0 If no exponent ('E') notation has been * come across yet, 1 if this is the case. * IDOT,ISIGN : Similar to IEXP. * INUM : 0 And 1 see IEXP, 2 a blank has been seen * after a number. * (Last changed on 27/11/10.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,INPUT. +SEQ,PRINTPLOT. +SEQ,ALGDATA. CHARACTER*(MXCHAR) AUX CHARACTER CHAR LOGICAL NUMBER,HEX INTEGER IWRD,IFMT,IFAIL,INUM,IDOT,IEXP,ISIGN,IDELET,ICONV,I, - ILAST,NUMEXP *** Define 2 statement functions to be used to identify symbols. NUMBER(CHAR)=INDEX('0123456789',CHAR).NE.0 HEX(CHAR)=INDEX('0123456789ABCDEF',CHAR).NE.0 *** Identify the subroutine, if requested. IF(LIDENT)PRINT *,' /// ROUTINE INPCHK ///' *** Preset IFAIL to 0, ie OK. IFAIL=0 *** Return without checking if IWRD is out of range. IF(IWRD.LE.0.OR.IWRD.GT.NWORD)THEN IFAIL=1 RETURN ENDIF *** Initialise ERRCDE(IWRD) and ERRPRT(IWRD). ERRCDE(IWRD)=' ' ERRPRT(IWRD)=.FALSE. *** Handle format 0 and word='*': no checks. IF(IFMT.EQ.0.OR.WORD(IWRD).EQ.'*'.OR.WORD(IWRD).EQ.' ')RETURN *** Initialise the counting variables (0=not yet seen, 1=seen, 2=end). INUM=0 IDOT=0 IEXP=0 ISIGN=0 IDELET=0 ICONV=0 *** Return immediately if the field is too long. IF(NCHAR(IWRD).GT.25)THEN ERRCDE(IWRD)='Word is longer than 25 chars. ' GOTO 100 ENDIF *** Hexadecimal numbers. IF(IFMT.EQ.3)THEN IF(NCHAR(IWRD).GT.6)THEN ERRCDE(IWRD)='Hex number longer than 6 byte.' GOTO 100 ELSE DO 30 I=1,NCHAR(IWRD) IF(.NOT.HEX(WORD(IWRD)(I:I)))THEN ERRCDE(IWRD)='Illegal characters seen. ' GOTO 100 ENDIF 30 CONTINUE ENDIF RETURN ENDIF *** Handle the normal formats: integer(=1) and real (=2). I=0 20 CONTINUE I=I+1 CHAR=WORD(IWRD)(I:I) * Remove character if IDELET is 1. IF(CHAR.EQ.'E'.AND.IDELET.EQ.1.AND.ICONV.EQ.1)IDELET=0 IF(IDELET.EQ.1)THEN IF(CHAR.NE.' '.AND.ERRCDE(IWRD).EQ.' ')THEN ERRPRT(IWRD)=.TRUE. ERRCDE(IWRD)='The second number is removed. ' ENDIF WORD(IWRD)(I:I)=' ' * Set INUM to 1 if at least one number is seen, delete after a blank. ELSEIF(NUMBER(CHAR))THEN INUM=1 * Delete from the first blank onwards. ELSEIF(CHAR.EQ.' ')THEN IF(WORD(IWRD)(:I).NE.' ')IDELET=1 * Only one '.' is allowed, only for reals and only before the E. ELSEIF(CHAR.EQ.'.')THEN IF(IDOT.EQ.1.OR.IEXP.EQ.1)THEN ERRCDE(IWRD)='Illegal use of a decimal dot. ' GOTO 100 ELSEIF(IFMT.EQ.1)THEN WORD(IWRD)(I:I)=' ' ERRCDE(IWRD)='Decimal not allowed in integer' IDELET=1 ICONV=1 ERRPRT(IWRD)=.TRUE. ENDIF IDOT=1 * Only one E is allowed (after a number), no '.' allowed anymore. ELSEIF(CHAR.EQ.'E')THEN IF(IEXP.EQ.1)THEN ERRCDE(IWRD)='E has been used at least twice' GOTO 100 ELSEIF(INUM.EQ.0)THEN IF(IFMT.EQ.1.AND.WORD(IWRD)(MXCHAR:MXCHAR).EQ.' ')THEN IF(I.GT.1)THEN AUX=WORD(IWRD)(1:I-1)//'0'// - WORD(IWRD)(I:MXCHAR-1) ELSE AUX='0'//WORD(IWRD)(I:MXCHAR-1) ENDIF WORD(IWRD)=AUX I=I+1 ERRCDE(IWRD)='0 is required before the E. ' ELSEIF(IFMT.EQ.2.AND. - WORD(IWRD)(MXCHAR-1:MXCHAR).EQ.' ')THEN IF(I.GT.1)THEN AUX=WORD(IWRD)(1:I-1)//'0.'// - WORD(IWRD)(I:MXCHAR-2) ELSE AUX='0.'//WORD(IWRD)(I:MXCHAR-2) ENDIF WORD(IWRD)=AUX I=I+2 ERRCDE(IWRD)='0. is required before the E. ' ELSE ERRCDE(IWRD)='E is not preceded by a number.' GOTO 100 ENDIF ELSEIF(IFMT.EQ.2.AND.IDOT.EQ.0)THEN IF(WORD(IWRD)(MXCHAR:MXCHAR).EQ.' ' - .AND.I.GE.2.AND.I.LT.MXCHAR)THEN IF(I.GT.1)THEN AUX=WORD(IWRD)(1:I-1)//'.'// - WORD(IWRD)(I:MXCHAR-1) ELSE AUX='.'//WORD(IWRD)(I:MXCHAR-1) ENDIF WORD(IWRD)=AUX ERRCDE(IWRD)='Decimal dot required for reals' I=I+1 ELSE ERRCDE(IWRD)='Unable to insert a dot. ' GOTO 100 ENDIF ENDIF IEXP=1 IDOT=1 ISIGN=0 INUM=0 * Accept only one sign before and one after E and before numbers. ELSEIF(CHAR.EQ.'+'.OR.CHAR.EQ.'-')THEN IF(INUM.EQ.1.OR.ISIGN.EQ.1.OR.(IDOT.EQ.1.AND.IEXP.EQ.0))THEN ERRCDE(IWRD)='Illegal use of a + or - sign. ' GOTO 100 ENDIF ISIGN=1 * Check that character is legal, remove if not. ELSE IF(IEXP.EQ.0.AND.INUM.EQ.0.AND.IDOT.EQ.0.AND.ISIGN.EQ.0)THEN WORD(IWRD)(I:I)=' ' ERRCDE(IWRD)='Illegal character(s) removed. ' ERRPRT(IWRD)=.TRUE. ELSE ERRCDE(IWRD)='Illegal character "'//CHAR//'" found. ' GOTO 100 ENDIF ENDIF IF(I.LT.MXCHAR)GOTO 20 *** Stop if line is blank after correction. IF(WORD(IWRD).EQ.' ')GOTO 100 *** Make some additional checks on numbers with an E. IF(IEXP.EQ.1.AND.INUM.EQ.0)THEN WORD(IWRD)(INDEX(WORD(IWRD),'E'):)=' ' ERRCDE(IWRD)='No exponential sign is needed.' IEXP=0 ISIGN=0 * In case there is an E, make sure the exponent is not too large. ELSEIF(IEXP.EQ.1)THEN AUX=WORD(IWRD)(INDEX(WORD(IWRD),'E'):) AUX(1:1)=' ' READ(AUX,'(BN,I10)') NUMEXP IF(ABS(NUMEXP).GT.30)THEN ERRCDE(IWRD)='Exponent is out of range. ' IF(LINUND)THEN WORD(IWRD)='0.0' IEXP=0 ISIGN=0 ELSE GOTO 100 ENDIF ENDIF ENDIF *** Add zeros in numbers with a sign without number. IF(IEXP.EQ.0.AND.ISIGN.EQ.1.AND.INUM.EQ.0)THEN IF(IFMT.EQ.1)WORD(IWRD)='0' IF(IFMT.EQ.2)WORD(IWRD)='0.0' ERRCDE(IWRD)='Only a + or a - sign was found. ' *** Supplement a dot (if not yet present) to a real without an E. ELSEIF(IFMT.EQ.2.AND.IEXP.EQ.0.AND.IDOT.EQ.0)THEN ILAST=0 INUM=0 DO 40 I=1,MXCHAR IF(NUMBER(WORD(IWRD)(I:I)))THEN IF(INUM.EQ.0)INUM=1 ELSE IF(INUM.EQ.1)THEN INUM=2 ILAST=I ENDIF ENDIF 40 CONTINUE IF(INUM.NE.2)THEN ERRCDE(IWRD)='Unable to insert a dot (no E).' GOTO 100 ELSE WORD(IWRD)(ILAST:ILAST)='.' ERRCDE(IWRD)='Decimal dot required for reals' ENDIF ENDIF GOTO 110 *** Case of irrepairable syntax errors. 100 CONTINUE ERRPRT(IWRD)=.TRUE. WORD(IWRD)='*' NCHAR(IWRD)=1 IFAIL=1 *** Remove blanks and count the number of characters again. 110 CONTINUE NCHAR(IWRD)=0 DO 120 I=1,MXCHAR IF(WORD(IWRD)(I:I).NE.' ')THEN NCHAR(IWRD)=NCHAR(IWRD)+1 WORD(IWRD)(NCHAR(IWRD):NCHAR(IWRD))=WORD(IWRD)(I:I) ENDIF 120 CONTINUE IF(NCHAR(IWRD).LT.MXCHAR)WORD(IWRD)(NCHAR(IWRD)+1:)=' ' END +DECK,INPCMP. INTEGER FUNCTION INPCMP(IWRD,REF) *----------------------------------------------------------------------- * INPCMP - Integer function returning 1 if word IWRD matches with * REF in all segments (delimited by - signs). * VARIABLES : REF : Reference string, the hash (#) signs * indicate the abbreviation points. * IWRD : The word to be matched with REF. * NMIN : Minimum of characters required to match. * (Last changed on 26/10/07.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,INPUT. CHARACTER*(*) REF CHARACTER*80 REFSTR INTEGER IWRD,IFREF,IFCMP,ILREF,ILCMP,NMIN,NCREF,IHASH,NCOMP *** Initialise some parameters. INPCMP=0 IFREF=1 IFCMP=1 *** Return right away if the string to be compared with does not exist. IF(IWRD.LE.0.OR.IWRD.GT.NWORD)RETURN IF(NCHAR(IWRD).EQ.0)RETURN *** Return to this point if further segments are to be searched for. 10 CONTINUE *** Find the next part of the reference string. ILREF=INDEX(REF(IFREF:LEN(REF)),'-') IF(ILREF.EQ.0)THEN ILREF=LEN(REF) ELSE ILREF=IFREF+ILREF-2 ENDIF * Remove the # sign from the string and store NMIN. REFSTR=' ' IF(ILREF.LT.IFREF)THEN REFSTR=' ' NMIN=0 NCREF=0 ELSE IHASH=INDEX(REF(IFREF:ILREF),'#') IF(IHASH.EQ.0)THEN REFSTR(1:ILREF-IFREF+1)=REF(IFREF:ILREF) NMIN=ILREF-IFREF+1 NCREF=ILREF-IFREF+1 ELSE IF(IHASH.GE.2) - REFSTR(1:IHASH-1)=REF(IFREF:IFREF+IHASH-2) IF(IHASH.LT.ILREF-IFREF+1)REFSTR(IHASH:ILREF-IFREF)= - REF(IFREF+IHASH:ILREF) NMIN=IHASH-1 NCREF=ILREF-IFREF ENDIF ENDIF ** Do similar things with the string to be compared. ILCMP=INDEX(WORD(IWRD)(IFCMP:NCHAR(IWRD)),'-') IF(ILCMP.EQ.0)THEN ILCMP=NCHAR(IWRD) ELSE ILCMP=IFCMP+ILCMP-2 ENDIF ** And compare the two strings. IF(NCREF.LT.ILCMP-IFCMP+1)RETURN NCOMP=MIN(NCREF,MAX(NMIN,ILCMP-IFCMP+1)) IF(NCOMP.GT.0)THEN IF(REFSTR(1:NCOMP).NE.WORD(IWRD)(IFCMP:IFCMP+NCOMP-1))RETURN ENDIF *** Return for a further cycle if there is more to compare. IFREF=ILREF+2 IFCMP=ILCMP+2 IF(IFREF.GT.LEN(REF))THEN IF(IFCMP.GT.NCHAR(IWRD))INPCMP=1 RETURN ELSEIF(IFCMP.GT.NCHAR(IWRD))THEN IF(REF(IFREF:IFREF).EQ.'#')INPCMP=1 RETURN ENDIF GOTO 10 END +DECK,INPCMX. INTEGER FUNCTION INPCMX(STR1,STR2) *----------------------------------------------------------------------- * INPCMX - Compares strings STR1 and STR2 where STR1 is the word and * STR2 the pattern string. * (Last changed on 26/10/07.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,INPUT. CHARACTER*(*) STR1,STR2 CHARACTER*(MXWORD) WRDRES CHARACTER*30 ECDRES LOGICAL ERRRES INTEGER INPCMP,NWRRES,NCHRES EXTERNAL INPCMP *** First store all data on word 1 and remember the number of words. WRDRES=WORD(1) ECDRES=ERRCDE(1) ERRRES=ERRPRT(1) NCHRES=NCHAR(1) NWRRES=NWORD *** Store the word to be checked in word 1 and check it. NWORD=1 IF(LEN(STR1).GT.MXWORD)THEN INPCMX=0 ELSE WORD(1)=STR1 NCHAR(1)=LEN(STR1) INPCMX=INPCMP(1,STR2) ENDIF *** Restore the old word 1 in its place. WORD(1) =WRDRES ERRCDE(1)=ECDRES ERRPRT(1)=ERRRES NCHAR(1) =NCHRES NWORD =NWRRES END +DECK,INPDEL. SUBROUTINE INPDEL(IWRD) *----------------------------------------------------------------------- * INPDEL - Deletes a word from the list of words. * (Last changed on 20/ 5/99.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,INPUT. +SEQ,PRINTPLOT. INTEGER IWRD,I *** Return in case the word is out of range. IF(IWRD.LE.0.OR.IWRD.GT.NWORD)RETURN *** Blank the word to be deleted also from the main string. C IF(NCHAR(IWRD).GE.1) C - STRING(INDWRD(IWRD):INDWRD(IWRD)+NCHAR(IWRD)-1)=' ' *** Shift all words from IWRD onwards one place. DO 10 I=IWRD,NWORD-1 WORD(I)=WORD(I+1) NCHAR(I)=NCHAR(I+1) INDWRD(I)=INDWRD(I+1) ERRCDE(I)=ERRCDE(I+1) ERRPRT(I)=ERRPRT(I+1) 10 CONTINUE *** The number of words is one less by now. NWORD=NWORD-1 END +DECK,INPERR. SUBROUTINE INPERR *----------------------------------------------------------------------- * INPERR - Prints the errors detected by INPCHK in a compact manner. * (Last changed on 20/ 5/99.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,INPUT. +SEQ,PRINTPLOT. LOGICAL OK CHARACTER*(MXINCH+1) MARK INTEGER LASTCH(MXWORD),I,J,IORIG,IPART,JSTART IF(LIDENT)PRINT *,' /// ROUTINE INPERR ///' *** Find out whether something is wrong or not and preset the mark line. MARK=' ' OK=.TRUE. DO 10 I=1,NWORD IF(ERRPRT(I))OK=.FALSE. IF(ERRCDE(I).NE.' ')THEN IF(ERRPRT(I))MARK(INDWRD(I):INDWRD(I))='#' IF(.NOT.ERRPRT(I))MARK(INDWRD(I):INDWRD(I))='!' ENDIF 10 CONTINUE *** Return at this point if there are no error messages. IF(OK)RETURN * Otherwise print a heading for the messages. PRINT *,' !!!!!! INPERR WARNING : The words marked # and !'// - ' have been changed:' *** Find out where each string ends. DO 20 I=1,NWORD * Starting point of the search. IF(I.EQ.NWORD)THEN JSTART=MXCHAR ELSE JSTART=INDWRD(I+1)-1 ENDIF * Search for last non-blank character of the string. DO 30 J=JSTART,INDWRD(I),-1 IF(STRING(J:J).NE.' ')THEN LASTCH(I)=J GOTO 40 ENDIF 30 CONTINUE LASTCH(I)=INDWRD(I) 40 CONTINUE 20 CONTINUE * Add as many words as will fit without spilling to next line. IORIG=1 IPART=0 DO 50 I=1,NWORD IF(I.NE.NWORD)THEN IF(LASTCH(I+1)-INDWRD(IORIG)+25.LE.75)GOTO 50 ENDIF IF(IORIG.EQ.1.AND.I.EQ.NWORD)THEN PRINT *,' Original input : '// - STRING(INDWRD(IORIG):LASTCH(I)) ELSE IPART=IPART+1 WRITE(*,'(/'' Input part '',I3,'' : '',A)') IPART, - STRING(INDWRD(IORIG):LASTCH(I)) ENDIF PRINT *,' Modified words : '// - MARK(INDWRD(IORIG):LASTCH(I)) DO 60 J=IORIG,I IF(ERRCDE(J).NE.' '.AND.WORD(J)(1:NCHAR(J)).EQ.'*DELETED*')THEN PRINT *,' Deleted, reason: '//ERRCDE(J) ELSEIF(ERRCDE(J).NE.' ')THEN PRINT *,' Changed into "'//WORD(J)(1:NCHAR(J))// - '", reason: '//ERRCDE(J) ENDIF 60 CONTINUE IORIG=I+1 50 CONTINUE *** End of the printout. PRINT *,' ' END +DECK,INPESC. SUBROUTINE INPESC(STR,NCSTR,IFAIL) *----------------------------------------------------------------------- * INPESC - Removes escape characters from the string. * (Last changed on 4/ 6/92.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,INPUT. CHARACTER*(*) STR *** Scan the string for backslashes. NCOUT=0 DO 10 I=1,NCSTR IF(STR(I:I).NE.ESCAPE)THEN NCOUT=NCOUT+1 STR(NCOUT:NCOUT)=STR(I:I) ENDIF 10 CONTINUE *** Blank remainder of string. IF(NCSTR.GT.NCOUT)STR(NCOUT+1:NCSTR)=' ' *** Set new number of characters. NCSTR=NCOUT *** Routine always works. IFAIL=0 END +DECK,INPFIX. SUBROUTINE INPFIX(STRIN,STROUT,NC) *----------------------------------------------------------------------- * INPFIX - Converts a comparison string into a more legible format. *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,INPUT. CHARACTER*(*) STRIN,STROUT LOGICAL TRANS INTEGER NC *** Initial values. TRANS=.FALSE. NC=0 *** Loop over the input string. DO 10 I=1,LEN(STRIN) *** Check whether there is room for further characters in the output. IF(NC.GE.LEN(STROUT))THEN PRINT *,' !!!!!! INPFIX WARNING : Receiving string is too'// - ' short ; output has been truncated.' NC=LEN(STROUT) RETURN ENDIF *** Skip blanks and hatches. IF(STRIN(I:I).EQ.' '.OR.STRIN(I:I).EQ.'#')THEN GOTO 10 *** Copy dashes as-is but leave the next upper case character untouched. ELSEIF(STRIN(I:I).EQ.'-')THEN NC=NC+1 STROUT(NC:NC)='-' TRANS=.FALSE. *** Convert the character to lower case if it's alphabetic. ELSEIF(TRANS)THEN NC=NC+1 IC=ICHAR(STRIN(I:I)) * ASCII: all letters are contiguous and located between 97 and 122. IF(ICHSET.EQ.1.AND.IC.LE.90.AND.IC.GE.65)THEN STROUT(NC:NC)=CHAR(IC+32) * EBCDIC: there are 2 gaps in the set (idea from IBM of course). ELSEIF(ICHSET.EQ.2.AND.((IC.GE.193.AND.IC.LE.201).OR. - (IC.GE.209.AND.IC.LE.217).OR. - (IC.GE.226.AND.IC.LE.233)))THEN STROUT(NC:NC)=CHAR(IC-64) * Anything else: no translation. ELSE STROUT(NC:NC)=STRIN(I:I) ENDIF *** Leave the first upper case character in each segment as it is. ELSE NC=NC+1 STROUT(NC:NC)=STRIN(I:I) TRANS=.TRUE. ENDIF 10 CONTINUE END +DECK,INPGET. SUBROUTINE INPGET *----------------------------------------------------------------------- * INPGET - This routine reads a line from unit LUN (without checking * that it is opened). It isolates the words. * VARIABLES : SQUOTE : Becomes TRUE when a single quote has been * met (separators are ignored inside quotes) * DQUOTE : Similar to SQUOTE, but for double quotes * BQUOTE : Similar to SQUOTE, but for reverse quotes * (Last changed on 15/ 2/11.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,INPUT. +SEQ,PRINTPLOT. +SEQ,GLOBALS. CHARACTER*(MXNAME) FILE INTEGER I,I0,I1,I0STR,NCSTR,IFLAG,IFIRST,IOS,IFAIL,NC,IC LOGICAL SQUOTE,DQUOTE,BQUOTE,BRACK,DQINBR,BQINBR,KPCASE, - STDSTR,REREAD,ACT1,ACT2 EXTERNAL STDSTR *** Identify the routine IF(LIDENT)PRINT *,' /// ROUTINE INPGET ///' *** Initialise the number of words, the quote logicals, the error codes 30 CONTINUE NWORD=0 DO 50 I=1,MXWORD ERRPRT(I)=.FALSE. ERRCDE(I)=' ' WORD(I)=' ' NCHAR(I)=1 50 CONTINUE *** Read a line from the DO buffer, if available. IF(DOEXEC)THEN * Fetch the line. CALL INPXDO(STRING,NCSTR,IFLAG) * Error in the DO loop execution routine. IF(IFLAG.LT.0)THEN PRINT *,' ------ INPGET MESSAGE : Resuming input'// - ' from normal stream after DO execution error.' DOEXEC=.FALSE. * End of loop reached without error. ELSEIF(IFLAG.EQ.+2)THEN DOEXEC=.FALSE. ENDIF * Line didn't come from the buffer. ELSE IFLAG=0 ENDIF *** Read a line from normal input, disable condition handling. IF(.NOT.DOEXEC)THEN +SELF,IF=AST. CALL ASTDCC +SELF. * Initial settings. STRING=' ' IFIRST=1 * Return here for more string portions. 110 CONTINUE * Adjust prompt for multiple sections. IF(IFIRST.NE.1)CALL INPPRM('More ...','ADD') * Synchronisation prompt. IF(LSYNCH.AND.LUN.EQ.5.AND.STDSTR('INPUT').AND. - NCPROM.GE.1)THEN WRITE(6,'('' >>>>>> input '',A)') PROMPT(1:NCPROM) +IMI,FLAGSEEN,IF=VAX,IBMRT,SUN,HPUX,LINUX,MACOSX,DECS,APOLLO. +SELF,IF=VAX. * Display the prompt in underlined, fat mode (VT100 escape sequence). ELSEIF(LUN.EQ.5.AND.STDSTR('INPUT').AND.NCPROM.GE.1)THEN WRITE(6,'(''$ '',A,'': '')') - CHAR(27)//CHAR(91)//CHAR(49)//CHAR(109)// - CHAR(27)//CHAR(91)//CHAR(52)//CHAR(109)// - PROMPT(1:NCPROM)//CHAR(27)//CHAR(91)//CHAR(109) +SELF,IF=IBMRT. * Display the prompt in underlined, fat mode (VT100 escape sequence). ELSEIF(LUN.EQ.5.AND.STDSTR('INPUT').AND.NCPROM.GE.1)THEN WRITE(6,'('' '',A,'': '')',ADVANCE='NO') - CHAR(27)//CHAR(91)//CHAR(49)//CHAR(109)// - CHAR(27)//CHAR(91)//CHAR(52)//CHAR(109)// - PROMPT(1:NCPROM)//CHAR(27)//CHAR(91)//CHAR(109) +SELF,IF=SUN,HPUX,LINUX,MACOSX,DECS. * Display the prompt in underlined, fat mode (VT100 escape sequence). ELSEIF(LUN.EQ.5.AND.STDSTR('INPUT').AND.NCPROM.GE.1)THEN WRITE(6,'('' '',A,'': '',$)') - CHAR(27)//CHAR(91)//CHAR(49)//CHAR(109)// - CHAR(27)//CHAR(91)//CHAR(52)//CHAR(109)// - PROMPT(1:NCPROM)//CHAR(27)//CHAR(91)//CHAR(109) +SELF,IF=APOLLO. * Display the prompt normal way. ELSEIF(LUN.EQ.5.AND.STDSTR('INPUT').AND.NCPROM.GE.1)THEN WRITE(6,'('' '',A,'': '',$)') PROMPT(1:NCPROM) +SELF,IF=-FLAGSEEN. * Display the prompt by appending it to the READY string. ELSEIF((LUN.EQ.5).AND.STDSTR('INPUT').AND. - (NCPROM.GE.1).AND.LPROM)THEN WRITE(6,'('' Ready ('',A,'')'')') PROMPT(1:NCPROM) +SELF. ENDIF * Restablish the prompt. IF(IFIRST.NE.1)CALL INPPRM(' ','BACK') * Read a portion of the line. IF(IFIRST.GE.MXINCH)THEN PRINT *,' !!!!!! INPGET WARNING : No room for more'// - ' input characters.' GOTO 130 ELSE +SELF,IF=-CMS. READ(LUN,'(A)',END=2000,IOSTAT=IOS,ERR=2010) - STRING(IFIRST:MXINCH) +SELF,IF=CMS. READ(LUN,END=2000,IOSTAT=IOS,ERR=2010,NUM=NBYTE) - STRING(IFIRST:MXINCH) +SELF. * Input translation. CALL INPTRA(STRING(IFIRST:MXINCH),MXINCH-IFIRST+1) * Write out to the recording file if requested and appropriate. IF(LUN.EQ.5.AND.LINREC)THEN DO 150 I=MXINCH,IFIRST,-1 IF(STRING(I:I).NE.' ')THEN WRITE(18,'(A)',IOSTAT=IOS,ERR=2020) - STRING(IFIRST:MIN(132+IFIRST,I)) GOTO 160 ENDIF 150 CONTINUE WRITE(18,'('' '')',IOSTAT=IOS,ERR=2020) 160 CONTINUE ENDIF ENDIF * Remove any part of the string beyond // IF(INDEX(STRING,'//').NE.0)STRING(INDEX(STRING,'//'):)=' ' * Print the string if requested and determine whether to continue. DO 120 I=MXINCH-2,IFIRST,-1 IF(STRING(I:I+2).EQ.'...')THEN IF(LINPUT)PRINT *,' ====== INPGET INPUT : '// - STRING(IFIRST:I+2) IFIRST=I GOTO 110 ELSEIF(STRING(I:I+2).NE.' '.AND.STRING(I:I+2).NE.'. ' - .AND.STRING(I:I+2).NE.'.. ')THEN IF(LINPUT)PRINT *,' ====== INPGET INPUT : '// - STRING(IFIRST:I+2) GOTO 130 ENDIF 120 CONTINUE 130 CONTINUE +SELF,IF=AST. * Reenable condition handling. CALL ASTECC +SELF. * Check the EOF label. IF(STRING.EQ.EOFSTR.AND.EOFSTR.NE.'EOF')GOTO 2000 ENDIF * Determine the length of the string. NCSTR=1 I0STR=1 DO 140 I=MXINCH,1,-1 IF(STRING(I:I).NE.' ')THEN IF(NCSTR.EQ.1)NCSTR=I I0STR=I ENDIF 140 CONTINUE *** Change lower case characters to upper case, except for $ lines. +SELF,IF=CMS. KPCASE=.FALSE. +SELF,IF=-CMS. IF(INDEX('$><',STRING(I0STR:I0STR)).NE.0)THEN KPCASE=.TRUE. ELSE KPCASE=.FALSE. ENDIF +SELF. DQUOTE=.FALSE. BQUOTE=.FALSE. BRACK=.FALSE. DQINBR=.FALSE. BQINBR=.FALSE. DO 40 I=1,NCSTR * Keep track of double quotes and curly brackets. IF(I.EQ.1.OR.STRING(MAX(1,I-1):MAX(1,I-1)).NE.ESCAPE)THEN IF(STRING(I:I).EQ.'"')DQUOTE=.NOT.DQUOTE IF(STRING(I:I).EQ.'`')BQUOTE=.NOT.BQUOTE IF(BRACK.AND.STRING(I:I).EQ.'"')DQINBR=.NOT.DQINBR IF(BRACK.AND.STRING(I:I).EQ.'`')BQINBR=.NOT.BQINBR IF(STRING(I:I).EQ.'{')BRACK=.TRUE. IF(STRING(I:I).EQ.'{')DQINBR=.FALSE. IF(STRING(I:I).EQ.'{')BQINBR=.FALSE. IF(STRING(I:I).EQ.'}')BRACK=.FALSE. IF(STRING(I:I).EQ.'}')DQINBR=.FALSE. IF(STRING(I:I).EQ.'}')BQINBR=.FALSE. ENDIF * Do not change case inside quotes but change inside brackets but ... IF(DQUOTE.AND.(((.NOT.BRACK).AND.(.NOT.DQINBR)).OR. - (BRACK.AND.DQINBR)))GOTO 40 IF(BQUOTE.AND.(((.NOT.BRACK).AND.(.NOT.BQINBR)).OR. - (BRACK.AND.BQINBR)))GOTO 40 * Do not change special commands, except in brackets and quotes. IF(KPCASE.AND..NOT.(BRACK.OR.BQINBR.OR.DQINBR))GOTO 40 * Loop up character sequence number. IC=ICHAR(STRING(I:I)) * ASCII: all letters are contiguous and located between 97 and 122. IF(ICHSET.EQ.1.AND.IC.LE.122.AND.IC.GE.97)THEN STRING(I:I)=CHAR(IC-32) * EBCDIC: there are 2 gaps in the set (idea from IBM of course). ELSEIF(ICHSET.EQ.2.AND.((IC.GE.129.AND.IC.LE.137).OR. - (IC.GE.145.AND.IC.LE.153).OR.(IC.GE.162.AND.IC.LE.169)))THEN STRING(I:I)=CHAR(IC+64) ENDIF 40 CONTINUE *** Perform substitutions. IF((.NOT.DOREAD).AND.(STRING(I0STR:I0STR).NE.'*'))THEN CALL INPIFQ(ACT1,ACT2) IF(ACT2.OR.(ACT1.AND. - STRING(I0STR:MIN(I0STR+6,NCSTR)).EQ.'ELSEIF ')) - CALL INPSUB(STRING,NCSTR,IFAIL) ENDIF *** Get rid of escape characters. CALL INPESC(STRING,NCSTR,IFAIL) *** Split the string in pieces. SQUOTE=.FALSE. DQUOTE=.FALSE. BQUOTE=.FALSE. * Locate start of next word. I0=0 10 CONTINUE I0=I0+1 IF(I0.GT.NCSTR)GOTO 100 * If first character is a quote, set flags accordingly. IF(STRING(I0:I0).EQ.'''')THEN SQUOTE=.TRUE. ELSE SQUOTE=.FALSE. ENDIF IF(STRING(I0:I0).EQ.'"')THEN DQUOTE=.TRUE. ELSE DQUOTE=.FALSE. ENDIF IF(STRING(I0:I0).EQ.'`')THEN BQUOTE=.TRUE. ELSE BQUOTE=.FALSE. ENDIF * Proceed with next character if STRING(I0:I0) is a separator. IF(INDEX(' ,=',STRING(I0:I0)).NE.0)GOTO 10 * Scan for the end of the word DO 20 I1=I0+1,NCSTR+1 IF(I1.NE.NCSTR+1.AND. - (INDEX('''"` ,=:',STRING(I1:I1)).EQ.0.OR. - ((DQUOTE.OR.SQUOTE.OR.BQUOTE).AND. - INDEX(' ,=:',STRING(I1:I1)).NE.0).OR. - (STRING(I1:I1).EQ.''''.AND.(DQUOTE.OR.BQUOTE)).OR. - (STRING(I1:I1).EQ.'`'.AND.(DQUOTE.OR.SQUOTE)).OR. - (STRING(I1:I1).EQ.'"'.AND.(SQUOTE.OR.BQUOTE))))GOTO 20 * Check that the string ends on a quote IF((SQUOTE.AND.STRING(I1:I1).NE.'''').OR. - (DQUOTE.AND.STRING(I1:I1).NE.'"').OR. - (BQUOTE.AND.STRING(I1:I1).NE.'`')) - PRINT *,' !!!!!! INPGET WARNING : A quote is missing in'// - ' the line ; assuming one at the end.' * Make sure that the maximum number of words is not exceeded IF(NWORD+1.GT.MXWORD)THEN PRINT *,' !!!!!! INPGET WARNING : The number of keywords'// - ' exceeds MXWORD (=',MXWORD,') ; rest is ignored.' GOTO 100 ENDIF NWORD=NWORD+1 * Store word together with its length and the index of first character IF(INDEX('''"',STRING(I0:I0)).NE.0)THEN IF(I0.EQ.I1-1)THEN WORD(NWORD)=' ' NCHAR(NWORD)=0 ELSE WORD(NWORD)=STRING(I0+1:I1-1) NCHAR(NWORD)=MIN(MXCHAR,I1-I0-1) ENDIF INDWRD(NWORD)=I0+1 IF(I1-I0-1.GT.MXCHAR)PRINT *,' !!!!!! INPGET WARNING : "'// - STRING(I0+1:I1-1)//'" is truncated to "'// - WORD(NWORD)//'" (MXCHAR characters).' ELSEIF(STRING(I0:I0).EQ.'`')THEN WORD(NWORD)=STRING(I0:I1) NCHAR(NWORD)=MIN(MXCHAR,I1-I0+1) IF(I1-I0+1.GT.MXCHAR)PRINT *,' !!!!!! INPGET WARNING : "'// - STRING(I0:I1)//'" is truncated to "'// - WORD(NWORD)//'" (MXCHAR characters).' INDWRD(NWORD)=I0 ELSE WORD(NWORD)=STRING(I0:I1-1) NCHAR(NWORD)=MIN(MXCHAR,I1-I0) IF(I1-I0.GT.MXCHAR)PRINT *,' !!!!!! INPGET WARNING : "'// - STRING(I0:I1-1)//'" is truncated to "'// - WORD(NWORD)//'" (MXCHAR characters).' INDWRD(NWORD)=I0 ENDIF * Continue with the next word. IF((STRING(I1:I1).EQ.''''.AND..NOT.SQUOTE).OR. - (STRING(I1:I1).EQ.'"'.AND..NOT.DQUOTE).OR. - (STRING(I1:I1).EQ.'`'.AND..NOT.BQUOTE))THEN I0=I1-1 ELSE I0=I1 ENDIF GOTO 10 20 CONTINUE 100 CONTINUE * Care for the empty string case. IF(NWORD.EQ.0)THEN WORD(1)=' ' NCHAR(1)=1 ENDIF *** Print the list of words if the debug option is on. IF(LDEBUG)THEN IF(NWORD.EQ.0)THEN WRITE(LUNOUT,'(1X,A)') - ' ++++++ INPGET DEBUG : Empty input string.' ELSE WRITE(LUNOUT,'(1X,A)') ' ++++++ INPGET DEBUG :'// - ' Word Length Start Text' DO 200 I=1,NWORD WRITE(LUNOUT,'(26X,3I7,2X,A)') - I,NCHAR(I),INDWRD(I), - WORD(I)(1:MAX(1,MIN(MXCHAR,NCHAR(I)))) 200 CONTINUE WRITE(LUNOUT,'('' '')') ENDIF ENDIF *** Input line started with an IF clause. IF(IFLAG.EQ.+1)THEN DO 210 I=1,NWORD IF(WORD(1).EQ.'THEN')THEN CALL INPDEL(1) GOTO 220 ELSE CALL INPDEL(1) ENDIF 210 CONTINUE 220 CONTINUE ENDIF *** Check the IF condition outside the DO loops. IF((.NOT.DOREAD).AND.(.NOT.DOEXEC))THEN CALL INPIFT(REREAD,IFAIL) IF(REREAD)THEN IF(LDEBUG)WRITE(LUNOUT,'(1X,A)') - ' ++++++ INPGET DEBUG : Line is skipped.' GOTO 30 ENDIF ENDIF *** Normal end of this routine. RETURN *** Handle I/O problems, first EOF on standard input. 2000 CONTINUE IF(LUN.EQ.5)THEN +SELF,IF=-CMS. PRINT *,' ------ INPGET MESSAGE : EOF on standard'// - ' input ; end of program execution.' CALL QUIT +SELF,IF=CMS. IF(LINREC)WRITE(18,'('' '')',IOSTAT=IOS,ERR=2020) IF(STDSTR('INPUT'))THEN NWORD=0 REWIND(UNIT=5) RETURN ELSE PRINT *,' ------ INPGET MESSAGE : EOF on standard', - ' input ; end of program execution.' CALL QUIT ENDIF +SELF. * Next, EOF on switched input. ELSEIF(LUN.EQ.12)THEN NWORD=0 RETURN * And finally EOF on alternate input. ELSE CALL STRBUF('READ',LUNSTR(LUN,1),FILE,NC,IFAIL) PRINT *,' ------ INPGET MESSAGE : End of file reached on '// - FILE(1:NC)//',' CLOSE(UNIT=LUN,STATUS='KEEP',IOSTAT=IOS,ERR=2030) CALL STRBUF('DELETE',LUNSTR(LUN,1),FILE,NC,IFAIL) CALL STRBUF('DELETE',LUNSTR(LUN,2),EOFSTR,NCEOF,IFAIL) CALL STRBUF('DELETE',LUNSTR(LUN,3),ARGSTR,NCARG,IFAIL) IF(LUN.EQ.20)LUN=5 IF(LUN.GT.20)LUN=LUN-1 CALL STRBUF('READ',LUNSTR(LUN,1),FILE,NC,IFAIL) CALL STRBUF('READ',LUNSTR(LUN,2),EOFSTR,NCEOF,IFAIL) CALL STRBUF('READ',LUNSTR(LUN,3),ARGSTR,NCARG,IFAIL) PRINT *,' input will continue'// - ' from '//FILE(1:NC)//' until '//EOFSTR(1:NCEOF)//'.' GLBVAL(6)=LUNSTR(LUN,1) GOTO 30 ENDIF *** I/O error reading the input, stop if on unit 5, else close. 2010 CONTINUE CALL STRBUF('READ',LUNSTR(LUN,1),FILE,NC,IFAIL) PRINT *,' ###### INPGET ERROR : I/O error detected on '// - FILE(1:NC)//',' CALL INPIOS(IOS) IF(LUN.NE.5)THEN CALL STRBUF('DELETE',LUNSTR(LUN,1),FILE,NC,IFAIL) CALL STRBUF('DELETE',LUNSTR(LUN,2),EOFSTR,NCEOF,IFAIL) CALL STRBUF('DELETE',LUNSTR(LUN,3),ARGSTR,NCARG,IFAIL) CLOSE(UNIT=LUN,STATUS='KEEP',IOSTAT=IOS,ERR=2030) IF(LUN.EQ.20)LUN=5 IF(LUN.GT.20)LUN=LUN-1 CALL STRBUF('READ',LUNSTR(LUN,1),FILE,NC,IFAIL) CALL STRBUF('READ',LUNSTR(LUN,2),EOFSTR,NCEOF,IFAIL) CALL STRBUF('READ',LUNSTR(LUN,3),ARGSTR,NCARG,IFAIL) PRINT *,' file closed, reading'// - ' from '//FILE(1:NC)//' until '//EOFSTR(1:NCEOF)//'.' GLBVAL(6)=LUNSTR(LUN,1) GOTO 30 ELSE PRINT *,' end of program execution.' CALL QUIT ENDIF *** Recording errors. 2020 CONTINUE PRINT *,' ###### INPGET ERROR : Error while recording input'// - ' statements; recording stopped.' LINREC=.FALSE. CALL INPIOS(IOS) GOTO 30 *** Error closing an alternate input file. 2030 CONTINUE CALL STRBUF('READ',LUNSTR(LUN,1),FILE,NC,IFAIL) PRINT *,' ###### INPGET ERROR : Unable to close '//FILE(1:NC)// - ' ; further alternative input may cause problems.' CALL STRBUF('DELETE',LUNSTR(LUN,1),FILE,NC,IFAIL) CALL STRBUF('DELETE',LUNSTR(LUN,2),EOFSTR,NCEOF,IFAIL) CALL STRBUF('DELETE',LUNSTR(LUN,3),ARGSTR,NCARG,IFAIL) CALL INPIOS(IOS) IF(LUN.EQ.20)LUN=5 IF(LUN.GT.20)LUN=LUN-1 GLBVAL(6)=LUNSTR(LUN,1) GOTO 30 END +DECK,INPGLB. SUBROUTINE INPGLB *----------------------------------------------------------------------- * INPGLB - Updates the table of global variables. * (Last changed on 19/ 1/11.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,ALGDATA. +SEQ,GLOBALS. +SEQ,PRINTPLOT. CHARACTER*(MXINCH) STRING,INDSTR CHARACTER*54 VALUE CHARACTER*10 MODE LOGICAL USE(MXVAR) INTEGER MODRES(1),NCIND,NCSTR,NC,NWORD,I,IGLB,IENTNO,IENTRY, - ILAST,IFAIL,IEXTR,NNRES,ITEMP,ISIZ(1) REAL RES(1) *** Check number of arguments. CALL INPNUM(NWORD) * No arguments, listing required. IF(NWORD.EQ.1)THEN WRITE(LUNOUT,'(/2X,''GLOBAL VARIABLES CURRENTLY DEFINED''// - 2X,''Name Type Value''/)') DO 40 I=1,NGLB IF(GLBMOD(I).EQ.1)THEN MODE='String' ELSEIF(GLBMOD(I).EQ.2)THEN MODE='Number' ELSEIF(GLBMOD(I).EQ.3)THEN MODE='Logical' ELSEIF(GLBMOD(I).EQ.4)THEN MODE='Histogram' ELSEIF(GLBMOD(I).EQ.5)THEN MODE='Matrix' ELSEIF(GLBMOD(I).EQ.0)THEN MODE='Undefined' ELSE MODE='# Unknown' ENDIF CALL OUTFMT(GLBVAL(I),GLBMOD(I),VALUE,NC,'LEFT') IF(I.LE.7)THEN WRITE(LUNOUT,'(2X,A10,2X,A10,2X,A, - '' (Not user modifiable)'')') - GLBVAR(I),MODE,VALUE(1:NC) ELSEIF(I.LE.11)THEN WRITE(LUNOUT,'(2X,A10,2X,A10,2X,A, - '' (Can be modified by the program)'')') - GLBVAR(I),MODE,VALUE(1:NC) ELSE WRITE(LUNOUT,'(2X,A10,2X,A10,2X,A)') - GLBVAR(I),MODE,VALUE(1:NC) ENDIF 40 CONTINUE RETURN ENDIF *** Pick up the name of the variable. CALL INPSTR(2,2,STRING,NC) * Find out whether this is a matrix indexing expression. IF(INDEX(STRING(1:NC),'[').GT.1.AND.STRING(NC:NC).EQ.']')THEN NCSTR=INDEX(STRING(1:NC),'[')-1 INDSTR=STRING(NCSTR+1:NC) NCIND=NC-NCSTR ELSE NCSTR=NC INDSTR=' ' NCIND=0 ENDIF * Check the name starts with a character. IF(INDEX('ABCDEFGHIJKLMNOPQRSTUVWXYZ',STRING(1:1)).EQ.0)THEN PRINT *,' !!!!!! INPGLB WARNING : The variable name does'// - ' not start with a character.' RETURN ENDIF * Check for illegal characters. DO 30 I=1,NCSTR IF(INDEX('+-*/&|<=#>^ ,.:;([{)]}''"`',STRING(I:I)).NE.0)THEN PRINT *,' !!!!!! INPGLB WARNING : The variable name'// - ' contains at least 1 illegal character; ignored.' RETURN ENDIF 30 CONTINUE * Make sure the name is not empty. IF(STRING.EQ.' '.OR.NCSTR.LT.1)THEN PRINT *,' !!!!!! INPGLB WARNING : The variable name'// - ' is empty; definition is ignored.' RETURN ENDIF * Warn if the name is longer than 10 characters. IF(NCSTR.GT.10)PRINT *,' !!!!!! INPGLB WARNING : The variable'// - ' name is truncated to the first 10 characters.' *** Scan the table, add an entry if needed. DO 10 I=1,NGLB IF(GLBVAR(I).EQ.STRING(1:MAX(1,MIN(10,NCSTR))))THEN IF(NCIND.NE.0.AND.GLBMOD(I).NE.5)THEN PRINT *,' !!!!!! INPGLB WARNING : '//STRING(1:NCSTR)// - ' is not of type Matrix; indexing not permitted.' RETURN ENDIF IGLB=I GOTO 20 ENDIF 10 CONTINUE * If a submatrix, the variables must have been defined before. IF(NCIND.NE.0)THEN PRINT *,' !!!!!! INPGLB WARNING : '//STRING(1:NCSTR)// - ' is not a declared Matrix; indexing not permitted.' RETURN ELSEIF(NGLB.GE.MXVAR)THEN PRINT *,' !!!!!! INPGLB WARNING : No room to add another'// - ' global variable; definition ignored.' RETURN ENDIF NGLB=NGLB+1 IGLB=NGLB GLBVAR(NGLB)=STRING(1:MAX(1,MIN(10,NCSTR))) GLBMOD(NGLB)=0 * Ensure that this variable is not a system variable. 20 CONTINUE IF(IGLB.LE.7)THEN PRINT *,' !!!!!! INPGLB WARNING : This variable can'// - ' not be redefined by the user.' RETURN ENDIF *** Only 2 arguments: reset. IF(NWORD.EQ.2)THEN IF(NCIND.EQ.0)THEN GLBMOD(IGLB)=0 GLBVAL(IGLB)=0 ELSE PRINT *,' !!!!!! INPGLB WARNING : Partial reset of'// - ' matrices is not permitted ; ignored.' ENDIF RETURN ENDIF *** Translation of the expression, fetch the string. CALL INPSTR(3,NWORD,STRING,NC) ** Translate for the case with indexing. IF(NCIND.NE.0)THEN * Translate expression. CALL ALGPRE('('//STRING(1:NC)//')'//INDSTR(1:NCIND), - NC+NCIND+2,GLBVAR,NGLB,NNRES,USE,IENTRY,IFAIL) * Check validity. IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! INPGLB WARNING : Unable to process'// - ' the indexing expression; global not assigned.' CALL ALGCLR(IENTRY) RETURN ELSEIF(NNRES.NE.1)THEN PRINT *,' !!!!!! INPGLB WARNING : Indexing doesn''t'// - ' lead to 1 result; global not assigned.' CALL ALGCLR(IENTRY) RETURN ENDIF * Locate the entry point number. IENTNO=0 DO 50 I=1,NALGE IF(ALGENT(I,1).EQ.IENTRY.AND.ALGENT(I,3).EQ.1)IENTNO=I 50 CONTINUE IF(IENTNO.EQ.0)THEN PRINT *,' !!!!!! INPGLB WARNING : No valid indexing'// - ' entry point found; global not assigned.' CALL ALGCLR(IENTRY) RETURN ENDIF * Locate the final EXTRACT_SUBMATRIX call. DO 60 I=ALGENT(IENTNO,5)+ALGENT(IENTNO,6)-1, - ALGENT(IENTNO,5)+2,-1 IF(INS(I,1).EQ.-80.AND.INS(I,2).EQ.9.AND. - INS(I-1,2).EQ.8.AND.INS(I-2,2).EQ.8)THEN IEXTR=I GOTO 70 ENDIF 60 CONTINUE PRINT *,' !!!!!! INPGLB WARNING : Instruction list'// - ' tail not as expected.' CALL ALGCLR(IENTRY) RETURN 70 CONTINUE * Store the location of the last instruction. ILAST=ALGENT(IENTNO,5)+ALGENT(IENTNO,6)-1 * Store reference to temporary matrix. ITEMP=INS(IEXTR-2,3) * Replace result and return by DELETE_MATRIX on temporary matrix. IF(ITEMP.GT.NGLB)THEN INS(ILAST-1,1)= 0 INS(ILAST-1,2)= 8 INS(ILAST-1,3)=ITEMP INS(ILAST-1,4)= 1 INS(ILAST ,1)=-86 INS(ILAST ,2)= 9 INS(ILAST ,3)= 1 INS(ILAST ,4)= 0 ELSE INS(ILAST-1,1)= 0 INS(ILAST-1,2)= -1 INS(ILAST-1,3)= 0 INS(ILAST-1,4)= 0 INS(ILAST ,1)= 0 INS(ILAST ,2)= -1 INS(ILAST ,3)= 0 INS(ILAST ,4)= 0 ENDIF * Replace EXTRACT_SUBMATRIX by STORE_SUBMATRIX. INS(IEXTR ,1)=-81 * Exchange the in/out matrices, assign to global, fix protections. INS(IEXTR-1,1)= 3 INS(IEXTR-1,3)=INS(IEXTR-2,3) INS(IEXTR-2,1)= 0 INS(IEXTR-2,3)=IGLB *** In debug mode, print the list. IF(LDEBUG)THEN WRITE(LUNOUT,'('' ++++++ INPGLB DEBUG : List'', - '' after processing indexing calls:'')') CALL ALGPRT(ALGENT(IENTNO,5),ALGENT(IENTNO,5)+ - ALGENT(IENTNO,6)-1) ENDIF ** Translate for the case without indexing. ELSE CALL ALGPRE(STRING(1:NC),NC, - GLBVAR,NGLB,NNRES,USE,IENTRY,IFAIL) * Check validity. IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! INPGLB WARNING : Unable to process'// - ' the expression; global not assigned.' CALL ALGCLR(IENTRY) RETURN ELSEIF(NNRES.NE.1)THEN PRINT *,' !!!!!! INPGLB WARNING : Formula doesn''t'// - ' lead to 1 result; global not assigned.' CALL ALGCLR(IENTRY) RETURN ENDIF * No temporary matrix. ITEMP=0 ENDIF *** Evaluate. CALL TIMEL(GLBVAL(1)) CALL ALGEXE(IENTRY,GLBVAL,GLBMOD,NGLB,RES,MODRES,1,IFAIL) * Error messages ? CALL ALGERR * If failed, return. IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! INPGLB WARNING : Unable to evaluate'// - ' the expression; definition ignored.' ISIZ(1)=1 IF(NCIND.NE.0.AND.ITEMP.GT.NGLB) - CALL MATADM('DELETE',NINT(REG(ITEMP)),1,ISIZ,2,IFAIL) CALL ALGCLR(IENTRY) RETURN ENDIF * Store the reference or the value itself. IF(NCIND.EQ.0)THEN IF((MODRES(1).EQ.1.OR.MODRES(1).EQ.4.OR.MODRES(1).EQ.5).AND. - MODRES(1).EQ.GLBMOD(IGLB).AND. - NINT(GLBVAL(IGLB)).EQ.NINT(RES(1)))THEN GLBVAL(IGLB)=RES(1) GLBMOD(IGLB)=MODRES(1) ELSE CALL ALGREU(NINT(GLBVAL(IGLB)),GLBMOD(IGLB),0) GLBVAL(IGLB)=RES(1) GLBMOD(IGLB)=MODRES(1) ENDIF ENDIF * Remove the entry point. CALL ALGCLR(IENTRY) END +DECK,INPIFT. SUBROUTINE INPIFT(REREAD,IFAIL) *----------------------------------------------------------------------- * INPIFT - Checks IF structures outside a DO loop. * INPIFQ - Tells the status of the current level and one level below. * (Last changed on 14/ 4/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,GLOBALS. +SEQ,PRINTPLOT. INTEGER TRACIF(0:MXILVL,2),INPCMP,CIFLVL,I,IFAIL,NWORD,IENTRY,NC, - MODRES(1),NRES,NCPRM,ITHEN LOGICAL USE(MXVAR),ACTIVE(0:MXILVL),REREAD,IFCOND,ACT1,ACT2 CHARACTER*(MXINCH) STRING CHARACTER*13 PROMPT REAL RES(1) EXTERNAL INPCMP +SELF,IF=SAVE. SAVE TRACIF,CIFLVL,ACTIVE +SELF. *** Initial state. DATA CIFLVL /0/, ACTIVE(0) /.TRUE./ DATA (TRACIF(0,I),I=1,2) /0,0/ *** Number of words is needed frequently. CALL INPNUM(NWORD) * Locate the THEN, if there is one. DO 10 I=1,NWORD IF(INPCMP(I,'THEN').NE.0)THEN ITHEN=I GOTO 20 ENDIF 10 CONTINUE ITHEN=0 20 CONTINUE * Would usually work. IFAIL=0 REREAD=.FALSE. *** This routine should not touch a start of DO loop. IF(INPCMP(1,'IF').NE.0.AND.ITHEN.NE.0.AND. - INPCMP(NWORD,'DO').NE.0.AND.NWORD.GT.ITHEN)THEN RETURN *** Ensure that THEN does not follow IF immediately. ELSEIF((INPCMP(1,'IF').NE.0.OR.INPCMP(1,'ELSEIF').NE.0).AND. - ITHEN.LE.2)THEN PRINT *,' !!!!!! INPIFT WARNING : Empty clause in an IF'// - ' or ELSEIF line; line ignored.' IFAIL=1 *** Check whether this is an IF-line. ELSEIF(NWORD.GT.ITHEN.AND.INPCMP(1,'IF').NE.0.AND.ITHEN.NE.0)THEN * Active area, see what the condition looks like. IF(ACTIVE(CIFLVL))THEN CALL INPSTR(2,ITHEN-1,STRING,NC) CALL ALGPRE(STRING(1:NC),NC,GLBVAR,NGLB,NRES, - USE,IENTRY,IFAIL) IFCOND=.FALSE. IF(IFAIL.NE.0.OR.NRES.NE.1)THEN PRINT *,' !!!!!! INPIFT WARNING : Failed to'// - ' translate condition of IF-line;'// - ' assumed not to hold.' IFCOND=.FALSE. ELSE CALL TIMEL(GLBVAL(1)) CALL ALGEXE(IENTRY,GLBVAL,GLBMOD,NGLB, - RES,MODRES,NRES,IFAIL) IF(IFAIL.EQ.0.AND.MODRES(1).NE.3)THEN PRINT *,' !!!!!! INPIFT WARNING : '// - STRING(1:NC)//' does not evaluate'// - ' to a logical; assumed not to hold.' ELSEIF(IFAIL.EQ.0.AND.ABS(RES(1)).LT.1.0E-5)THEN IFCOND=.FALSE. ELSEIF(IFAIL.EQ.0.AND.ABS(RES(1)-1).LT.1.0E-5)THEN IFCOND=.TRUE. ELSE PRINT *,' !!!!!! INPIFT WARNING : Failed'// - ' to evaluate '//STRING(1:NC)// - ' ; assumed not to hold.' IFCOND=.FALSE. ENDIF ENDIF CALL ALGCLR(IENTRY) * If the condition holds, delete the first words and have executed. IF(IFCOND)THEN DO 30 I=ITHEN,1,-1 CALL INPDEL(I) 30 CONTINUE NWORD=NWORD-ITHEN REREAD=.FALSE. * If not, just read the new line. ELSE REREAD=.TRUE. ENDIF * Inactive area, also read a new line no matter the condition. ELSE REREAD=.TRUE. ENDIF *** Check whether this is an IF block piece. ELSEIF(INPCMP(1,'IF').NE.0.AND.ITHEN.NE.0)THEN * Check whether we may still increase the IF level. IF(CIFLVL.GE.MXILVL)THEN PRINT *,' !!!!!! INPIFT WARNING : The IF blocks'// - ' are nested too deep; IF ignored.' IFAIL=1 ELSE * Check whether this is the first IF, if so add prompt. IF(CIFLVL.EQ.0)CALL INPPRM('If','ADD') * Increment level counter. CIFLVL=CIFLVL+1 * Add the new block to the trace. TRACIF(CIFLVL,1)=1 TRACIF(CIFLVL,2)=0 * The activity starts out the same as at the previous level. ACTIVE(CIFLVL)=ACTIVE(CIFLVL-1) * If we are inside an accepted region, evaluate and execute. IF(ACTIVE(CIFLVL))THEN CALL INPSTR(2,ITHEN-1,STRING,NC) CALL ALGPRE(STRING(1:NC),NC,GLBVAR,NGLB,NRES, - USE,IENTRY,IFAIL) IFCOND=.FALSE. IF(IFAIL.NE.0.OR.NRES.NE.1)THEN PRINT *,' !!!!!! INPIFT WARNING : Failed'// - ' to translate condition of IF-block;'// - ' assumed not to hold.' IFCOND=.FALSE. ELSE CALL TIMEL(GLBVAL(1)) CALL ALGEXE(IENTRY,GLBVAL,GLBMOD,NGLB, - RES,MODRES,NRES,IFAIL) IF(IFAIL.EQ.0.AND.MODRES(1).NE.3)THEN PRINT *,' !!!!!! INPIFT WARNING : '// - STRING(1:NC)//' does not'// - ' evaluate to a logical;'// - ' assumed not to hold.' ELSEIF(IFAIL.EQ.0.AND. - ABS(RES(1)).LT.1.0E-5)THEN IFCOND=.FALSE. ELSEIF(IFAIL.EQ.0.AND. - ABS(RES(1)-1).LT.1.0E-5)THEN IFCOND=.TRUE. ELSE PRINT *,' !!!!!! INPIFT WARNING :'// - ' Failed to evaluate '// - STRING(1:NC)//'; assumed not'// - ' to hold.' IFCOND=.FALSE. ENDIF ENDIF CALL ALGCLR(IENTRY) * If the condition holds, mark block as executed. IF(IFCOND)THEN TRACIF(CIFLVL,2)=1 * Otherwise mark this area is inactive. ELSE ACTIVE(CIFLVL)=.FALSE. ENDIF ENDIF ENDIF * Whatever happened, read a new line. REREAD=.TRUE. *** Ensure this is not an attempt at an ELSEIF ... THEN command. ELSEIF(NWORD.GT.ITHEN.AND.INPCMP(1,'ELSEIF').NE.0.AND. - ITHEN.NE.0)THEN PRINT *,' !!!!!! INPIFT WARNING : An ELSEIF line can not'// - ' have a command on it; line ignored.' IFAIL=1 *** Check whether this is an ELSEIF branch. ELSEIF(INPCMP(1,'ELSEIF').NE.0.AND.ITHEN.NE.0)THEN * Check whether we are really inside an IF block. IF(CIFLVL.LE.0)THEN PRINT *,' !!!!!! INPIFT WARNING : An ELSEIF may only'// - ' occur inside an IF-block; ignored.' IFAIL=1 * Check this ELSEIF was not preceded by an ELSE. ELSEIF(TRACIF(CIFLVL,1).GE.3)THEN PRINT *,' !!!!!! INPIFT WARNING : An ELSEIF may not'// - ' follow an ELSE in the same IF-block; ignored.' IFAIL=1 * Already executed IF block. ELSEIF(TRACIF(CIFLVL,2).EQ.1)THEN ACTIVE(CIFLVL)=.FALSE. * Check condition if embedding block is active and block not yet ex. ELSEIF(ACTIVE(CIFLVL-1).AND.TRACIF(CIFLVL,2).EQ.0)THEN CALL INPSTR(2,ITHEN-1,STRING,NC) CALL ALGPRE(STRING(1:NC),NC,GLBVAR,NGLB,NRES, - USE,IENTRY,IFAIL) IFCOND=.FALSE. IF(IFAIL.NE.0.OR.NRES.NE.1)THEN PRINT *,' !!!!!! INPIFT WARNING : Failed to'// - ' translate condition of an ELSEIF'// - ' line; assumed not to hold.' IFCOND=.FALSE. ELSE CALL TIMEL(GLBVAL(1)) CALL ALGEXE(IENTRY,GLBVAL,GLBMOD,NGLB, - RES,MODRES,NRES,IFAIL) IF(IFAIL.EQ.0.AND.MODRES(1).NE.3)THEN PRINT *,' !!!!!! INPIFT WARNING : '// - STRING(1:NC)//' does not evaluate'// - ' to a logical; assumed not to hold.' ELSEIF(IFAIL.EQ.0.AND.ABS(RES(1)).LT.1.0E-5)THEN IFCOND=.FALSE. ELSEIF(IFAIL.EQ.0.AND.ABS(RES(1)-1).LT.1.0E-5)THEN IFCOND=.TRUE. ELSE PRINT *,' !!!!!! INPIFT WARNING : Failed'// - ' to evaluate '//STRING(1:NC)// - ' ; assumed not to hold.' IFCOND=.FALSE. ENDIF ENDIF CALL ALGCLR(IENTRY) * If the condition holds, make active and mark block as executed. IF(IFCOND)THEN TRACIF(CIFLVL,2)=1 ACTIVE(CIFLVL)=.TRUE. * Otherwise mark area as inactive. ELSE ACTIVE(CIFLVL)=.FALSE. ENDIF ENDIF * Remember we saw an ELSEIF line but don't overrule an ELSE. TRACIF(CIFLVL,1)=MAX(2,TRACIF(CIFLVL,1)) * Always read a new line. REREAD=.TRUE. *** Warn for an ELSE outside an IF block. ELSEIF(INPCMP(1,'ELSE').NE.0.AND.CIFLVL.LE.0)THEN PRINT *,' !!!!!! INPIFT WARNING : An ELSE may only occur'// - ' inside an IF-block; line ignored.' IFAIL=1 *** Warn for an ELSE with additional words. ELSEIF(INPCMP(1,'ELSE').NE.0.AND.NWORD.GT.1)THEN PRINT *,' !!!!!! INPIFT WARNING : An ELSE line may not'// - ' have a command on it; line ignored.' IFAIL=1 *** An ELSE part of an IF block. ELSEIF(INPCMP(1,'ELSE').NE.0)THEN * Check this ELSEIF was not preceded by an ELSE. IF(TRACIF(CIFLVL,1).GE.3)THEN PRINT *,' !!!!!! INPIFT WARNING : There may not be'// - ' two ELSE parts in the same IF-block; ignored.' IFAIL=1 * Already executed IF block. ELSEIF(TRACIF(CIFLVL,2).EQ.1)THEN ACTIVE(CIFLVL)=.FALSE. * Execute active area of not yet executed IF block. ELSEIF(ACTIVE(CIFLVL-1).AND.TRACIF(CIFLVL,2).EQ.0)THEN TRACIF(CIFLVL,2)=1 ACTIVE(CIFLVL)=.TRUE. ENDIF * Remember we saw an ELSE line but don't overrule an ENDIF. TRACIF(CIFLVL,1)=MAX(3,TRACIF(CIFLVL,1)) * Always read a new line. REREAD=.TRUE. *** Warn for an ENDIF line outside an IF block. ELSEIF(INPCMP(1,'ENDIF').NE.0.AND.CIFLVL.LE.0)THEN PRINT *,' !!!!!! INPIFT WARNING : An ENDIF may only occur'// - ' inside an IF-block; line ignored.' IFAIL=1 *** Warn for an attempt of an ENDIF with additional words. ELSEIF(INPCMP(1,'ENDIF').NE.0.AND.NWORD.GT.1)THEN PRINT *,' !!!!!! INPIFT WARNING : An ENDIF line may not'// - ' have a command on it; line ignored.' IFAIL=1 *** The ENDIF part of a block. ELSEIF(INPCMP(1,'ENDIF').NE.0)THEN * Check whether we are really inside an IF block. IF(CIFLVL.LE.0)THEN PRINT *,' !!!!!! INPIFT WARNING : An ENDIF may only'// - ' occur at the end of an IF-block; ignored.' IFAIL=1 * In other cases, just go back by one level. ELSE TRACIF(CIFLVL,1)=4 CIFLVL=CIFLVL-1 CALL INPPRM(' ','BACK') ENDIF * Reread always. REREAD=.TRUE. *** Any other line. ELSE REREAD=.NOT.ACTIVE(CIFLVL) ENDIF *** Update the prompt. PROMPT=' ' IF(CIFLVL.GT.0)THEN WRITE(PROMPT,'(''If_'',I10)') CIFLVL NCPRM=0 DO 400 I=1,13 IF(PROMPT(I:I).NE.' ')THEN NCPRM=NCPRM+1 PROMPT(NCPRM:NCPRM)=PROMPT(I:I) ENDIF 400 CONTINUE CALL INPPRM(' ','BACK') CALL INPPRM(PROMPT(1:MAX(1,NCPRM)),'ADD') ENDIF *** Normal end of this routine. RETURN *** Entry for quick check whether substitution must be carried out. ENTRY INPIFQ(ACT1,ACT2) ACT1=ACTIVE(MAX(0,CIFLVL-1)) ACT2=ACTIVE(CIFLVL) END +DECK,INPINT. SUBROUTINE INPINT *----------------------------------------------------------------------- * INPINT - Initialises the input routines. Determines the character * set being used (courtesy Carlo Mekenkamp, Leiden). * (Last changed on 26/10/07.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,INPUT. +SEQ,PRINTPLOT. +SEQ,GLOBALS. LOGICAL EXIST INTEGER NCFILE,IFAIL CHARACTER*100 INFILE +SELF,IF=UNIX,CYGWIN. INTEGER I,NCHOME CHARACTER*80 HOME +SELF. *** Initial input logical unit, first input file. LUN=5 IF(FNINP.EQ.' '.OR.NCFNI.LT.1)THEN CALL STRBUF('STORE',LUNSTR(LUN,1),'Standard input',14,IFAIL) ELSE CLOSE(UNIT=LUN,ERR=2030) +SELF,IF=BOINC. call boincrf(fninp(1:ncfni),fninp) do i=len(fninp),1,-1 if(fninp(i:i).ne.' ')then ncfni=i goto 1234 endif enddo 1234 continue +SELF. OPEN(UNIT=LUN,FILE=FNINP(1:NCFNI),ERR=2020) CALL STRBUF('STORE',LUNSTR(LUN,1),FNINP(1:NCFNI),NCFNI, - IFAIL) ENDIF GLBVAR(6)='INPUT ' GLBMOD(6)=1 GLBVAL(6)=LUNSTR(LUN,1) * EOF string. EOFSTR='EOF' NCEOF=3 CALL STRBUF('STORE',LUNSTR(5,2),EOFSTR(1:NCEOF),NCEOF,IFAIL) * Input arguments have been set inside INIT. CALL STRBUF('STORE',LUNSTR(5,3),ARGSTR(1:NCARG),NCARG,IFAIL) *** Look for initialisation file. +SELF,IF=CMS. INFILE='GARFINIT INPUT' NCFILE=14 CALL DSNINQ(INFILE,NCFILE,EXIST) +SELF,IF=VAX. INFILE='GARFINIT.DAT' NCFILE=12 CALL DSNINQ(INFILE,NCFILE,EXIST) * If it is not found in the current directory, look at home. IF(.NOT.EXIST)THEN INFILE='SYS$LOGIN:GARFINIT.DAT' NCFILE=22 CALL DSNINQ(INFILE,NCFILE,EXIST) ENDIF +SELF,IF=UNIX,CYGWIN. CALL GETENV('HOME',HOME) DO 10 I=LEN(HOME),1,-1 IF(HOME(I:I).NE.' ')THEN NCHOME=I GOTO 20 ENDIF 10 CONTINUE NCHOME=1 20 CONTINUE INFILE='garfinit' NCFILE=8 CALL DSNINQ(INFILE,NCFILE,EXIST) IF(.NOT.EXIST)THEN INFILE=HOME(1:NCHOME)//'/garfinit' NCFILE=MIN(LEN(INFILE),NCHOME+9) CALL DSNINQ(INFILE,NCFILE,EXIST) ENDIF IF(.NOT.EXIST)THEN INFILE=HOME(1:NCHOME)//'/.garfinit' NCFILE=MIN(LEN(INFILE),NCHOME+10) CALL DSNINQ(INFILE,NCFILE,EXIST) ENDIF IF(.NOT.EXIST)THEN INFILE=HOME(1:NCHOME)//'/Garfield/Files/garfinit' NCFILE=MIN(LEN(INFILE),NCHOME+24) CALL DSNINQ(INFILE,NCFILE,EXIST) ENDIF IF(.NOT.EXIST)THEN INFILE=HOME(1:NCHOME)//'/Garfield/Files/.garfinit' NCFILE=MIN(LEN(INFILE),NCHOME+25) CALL DSNINQ(INFILE,NCFILE,EXIST) ENDIF +SELF,IF=-CMS,IF=-VAX,IF=-UNIX,IF=-CYGWIN. INFILE=' ' NCFILE=1 EXIST=.FALSE. +SELF. IF(EXIST.AND.LPROF)THEN LUN=20 CALL DSNOPN(INFILE,NCFILE,LUN,'READ-FILE',IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! INPINT WARNING : Opening '// - INFILE(1:NCFILE)//' failed; initialisation'// - 'not performed.' LUN=5 ELSE CALL STRBUF('STORE',LUNSTR(20,1),INFILE,NCFILE,IFAIL) GLBVAL(6)=LUNSTR(LUN,1) EOFSTR='EOF' NCEOF=3 CALL STRBUF('STORE',LUNSTR(20,2),EOFSTR(1:NCEOF),NCEOF, - IFAIL) ARGSTR=' ' NCARG=1 CALL STRBUF('STORE',LUNSTR(20,3),ARGSTR(1:NCARG),NCARG, - IFAIL) CALL DSNLOG(INFILE(1:NCFILE),'Profile ', - 'Sequential','Read only ') ENDIF ENDIF *** Determine the character set being used by the computer: +SELF,IF=APOLLO,UNIX,VAX,CYGWIN. ICHSET=1 +SELF,IF=CMS,MVS. ICHSET=2 +SELF,IF=CDC. ICHSET=0 +SELF,IF=-APOLLO,IF=-CDC,IF=-CMS,IF=-MVS,IF=-UNIX,IF=-VAX,IF=-CYGWIN. * in ASCII the codes for A and Z differ by 25, IF(ICHAR('Z')-ICHAR('A').EQ.25)THEN ICHSET=1 IF(LDEBUG)PRINT *,' ++++++ INPINT DEBUG : Character', - ' is assumed to be ASCII.' * in EBCDIC the codes for A and Z differ by 40, ELSEIF(ICHAR('Z')-ICHAR('A').EQ.40)THEN ICHSET=2 IF(LDEBUG)PRINT *,' ++++++ INPINT DEBUG : Character', - ' is assumed to be EBCDIC.' * otherwise do not change the case. ELSE PRINT *,' !!!!!! INPINT WARNING : Character set not known'// - ' recognised; lower case will not be translated.' ICHSET=0 ENDIF +SELF. *** Translation table initialisation. CALL INPTRI +SELF,IF=UNIX. *** Default shell. CALL GETENV('SHELL',HOME) IF(HOME.EQ.' ')CALL GETENV('shell',HOME) DO 30 I=LEN(HOME),1,-1 IF(HOME(I:I).NE.' ')THEN SHELL=HOME(1:I) NCSH=I GOTO 40 ENDIF 30 CONTINUE SHELL='tcsh' NCSH=4 40 CONTINUE +SELF,IF=CYGWIN. *** Default shell. CALL GETENV('SHELL',HOME) IF(HOME.EQ.' ')CALL GETENV('shell',HOME) DO 30 I=LEN(HOME),1,-1 IF(HOME(I:I).NE.' ')THEN SHELL=HOME(1:I) NCSH=I GOTO 40 ENDIF 30 CONTINUE SHELL='CMD' NCSH=4 40 CONTINUE +SELF,IF=-UNIX,IF=-CYGWIN. SHELL='* No default shell *' NCSH=20 +SELF. *** Escape character (double because \ is a Unix escape). ESCAPE='\\' *** Initialise the prompt. PROMPT='Main' LPROM=.TRUE. NCPROM=4 *** Start reading normal input and allow substitution. DOEXEC=.FALSE. DOREAD=.FALSE. *** Input recording. IF(LINREC)THEN +SELF,IF=CMS. CALL DSNOPN('GARFLAST INPUT A',16,18,'WRITE-FILE',IFAIL) CALL DSNLOG('GARFLAST INPUT','Recording ', - 'Sequential','Write ') +SELF,IF=VAX. CALL DSNOPN('GARFLAST.DAT',12,18,'WRITE-FILE',IFAIL) CALL DSNLOG('GARFLAST.DAT','Recording ', - 'Sequential','Write ') +SELF,IF=UNIX,CYGWIN. CALL DSNOPN('garflast.dat',12,18,'WRITE-FILE',IFAIL) CALL DSNLOG('garflast.dat','Recording ', - 'Sequential','Write ') +SELF,IF=-CMS,IF=-VAX,IF=-UNIX,IF=-CYGWIN. CALL DSNOPN('GARFLAST',8,18,'WRITE-FILE',IFAIL) CALL DSNLOG('GARFLAST','Recording ', - 'Sequential','Write ') +SELF. IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! INPINT WARNING : Opening the'// - ' recording file failed; recording cancelled.' LINREC=.FALSE. ELSEIF(LDEBUG)THEN PRINT *,' ++++++ INPINT DEBUG :'// - ' Recording has been enabled.' ENDIF ELSE IF(LDEBUG)PRINT *,' ++++++ INPINT DEBUG : Recording'// - ' has been disabled.' ENDIF *** I/O error processing. RETURN 2020 CONTINUE PRINT *,' ###### INPINT ERROR : Error opening a file; quit.' CALL QUIT RETURN 2030 CONTINUE PRINT *,' ###### INPINT ERROR : Error closing a file; quit.' CALL QUIT END +DECK,INPIOSOT,IF=-VAX,IF=-APOLLO,IF=-IBMRT. SUBROUTINE INPIOS(IOS) *----------------------------------------------------------------------- * INPIOS - Prints details about the most recent Fortran error message. * Still to be provided for most non-Vax computers. *----------------------------------------------------------------------- +SEQ,PRINTPLOT. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ INPIOS DEBUG : IOSTAT'', - '' return code:'',I8)') IOS END +DECK,INPIOSAP,IF=APOLLO. SUBROUTINE INPIOS(IOS) *----------------------------------------------------------------------- * INPIOS - Prints details about the most recent Fortran error message. * Version for Apollo computers. *----------------------------------------------------------------------- INTEGER*4 IOS %include '/sys/ins/fio.ins.ftn' CALL ERROR_$PRINT(IOS) END +DECK,INPIOSVX,IF=VAX. SUBROUTINE INPIOS(IOS) *----------------------------------------------------------------------- * INPIOS - Prints details about the most recent Fortran error message. * Version for Vax computers. * (Last changed on 14/11/93.) *----------------------------------------------------------------------- +SEQ,PRINTPLOT. character*256 message *** Fetch the error description. CALL ERRSNS(IERR,IRMS,ISTV,IUNIT,ICOND) call lib$sys_getmsg(irms,nc,message) *** Dump the data in DEBUG mode. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ INPIOS DEBUG : Most'', - '' recent error:'',I3,'','',/, - 26X,''RMS completion status code (STS): '',I6,'','',/, - 26X,''RMS status value (STV): '',I6,'','',/,26X, - ''Logical unit on which the error occurred: '',I2,'','',/, - 26X,''VAX-11 condition value: '',I8,''.'')') - IERR,IRMS,ISTV,IUNIT,ICOND IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ INPIOS DEBUG : IOSTAT'', - '' error code received is '',I8)') IOS *** Interpret the error message. WRITE(LUNOUT,'('' ------ INPIOS MESSAGE : The RMS explanation'', - '' of the above error is:''/26X,A,''.'')') - message(INDEX(message,' ')+1:NC) END +DECK,INPIOSIR,IF=IBMRT. SUBROUTINE INPIOS(IOS) *----------------------------------------------------------------------- * INPIOS - Prints details about the most recent Fortran error message. * Version for IBM RT and SP2 computers, error messages from * XL Fortran for AIX Language Reference Version 3 Release 2. * (Last changed on 12/ 9/95.) *----------------------------------------------------------------------- implicit none +SEQ,PRINTPLOT. CHARACTER*60 MESS INTEGER IOS *** Print an message according to the IOS value. IF(IOS.EQ.-4)THEN MESS='(EOR) End of record encountered, external READ.' ELSEIF(IOS.EQ.-2)THEN MESS='(EOF) End of file encountered for an internal READ.' ELSEIF(IOS.EQ.-1)THEN MESS='(EOF) End of file encountered during external READ.' ELSEIF(IOS.EQ.0)THEN MESS='(OK) I/O operation successfully completed.' ELSEIF(IOS.EQ.1)THEN MESS='(S) Non-existing record specified for a direct READ.' ELSEIF(IOS.EQ.2)THEN MESS='(S) End of file encountered during external WRITE.' ELSEIF(IOS.EQ.3)THEN MESS='(CNV) End of record on an unformatted file.' ELSEIF(IOS.EQ.4)THEN MESS='(CNV) End of record on a formatted external file.' ELSEIF(IOS.EQ.5)THEN MESS='(CNV) End of record on an internal file.' ELSEIF(IOS.EQ.6)THEN MESS='(S) OPEN with STATUS=OLD, but file not found.' ELSEIF(IOS.EQ.7)THEN MESS='(CNV) Format error in external list-directed input.' ELSEIF(IOS.EQ.8)THEN MESS='(CNV) Format error in internal list-directed input.' ELSEIF(IOS.EQ.9)THEN MESS='(CNV) List-directed or NAMELIST item too long.' ELSEIF(IOS.EQ.10)THEN MESS='(S) READ error on a direct access file.' ELSEIF(IOS.EQ.11)THEN MESS='(S) WRITE error on a direct access file.' ELSEIF(IOS.EQ.12)THEN MESS='(S) READ error on a sequential access file.' ELSEIF(IOS.EQ.13)THEN MESS='(S) WRITE error on a sequential access file.' ELSEIF(IOS.EQ.14)THEN MESS='(S) Error opening a file.' ELSEIF(IOS.EQ.15)THEN MESS='(S) Permanent I/O error encountered on a file.' ELSEIF(IOS.EQ.16)THEN MESS='(E) Invalid record specified for a direct I/O.' ELSEIF(IOS.EQ.17)THEN MESS='(E) I/O statement not allowed on direct file.' ELSEIF(IOS.EQ.18)THEN MESS='(E) Direct I/O attempted on an unconnected unit.' ELSEIF(IOS.EQ.19)THEN MESS='(E) Unformatted I/O attempted on a formatted file.' ELSEIF(IOS.EQ.20)THEN MESS='(E) Formatted I/O attempted on an unformatted file.' ELSEIF(IOS.EQ.21)THEN MESS='(E) Sequential I/O attempted on a direct file.' ELSEIF(IOS.EQ.22)THEN MESS='(E) Direct I/O attempted on a sequential file.' ELSEIF(IOS.EQ.23)THEN MESS='(E) Attempt to connect an already connected file.' ELSEIF(IOS.EQ.24)THEN MESS='(E) Specifiers of OPEN do not match file attributes.' ELSEIF(IOS.EQ.25)THEN MESS='(E) RECL specifier missing on OPEN for a direct file.' ELSEIF(IOS.EQ.26)THEN MESS='(E) RECL specified on an OPEN is negative.' ELSEIF(IOS.EQ.27)THEN MESS='(E) ACCESS specifier on an OPEN statement is invalid.' ELSEIF(IOS.EQ.28)THEN MESS='(E) FORM specifier on an OPEN statement is invalid.' ELSEIF(IOS.EQ.29)THEN MESS='(E) STATUS specifier on an OPEN statement is invalid.' ELSEIF(IOS.EQ.30)THEN MESS='(E) BLANK specifier on an OPEN statement is invalid.' ELSEIF(IOS.EQ.31)THEN MESS='(E) FILE specifier on an OPEN or INQUIRE is invalid.' ELSEIF(IOS.EQ.32)THEN MESS='(E) STATUS=SCRATCH and file name specified on OPEN.' ELSEIF(IOS.EQ.33)THEN MESS='(E) STATUS=KEEP on CLOSE for a scratch file.' ELSEIF(IOS.EQ.34)THEN MESS='(E) Value of STATUS not valid on CLOSE.' ELSEIF(IOS.EQ.36)THEN MESS='(E) Invalid unit number specified in I/O statement.' ELSEIF(IOS.EQ.37)THEN MESS='(S) Dynamic memory allocation failure.' ELSEIF(IOS.EQ.38)THEN MESS='(S) REWIND error.' ELSEIF(IOS.EQ.39)THEN MESS='(S) ENDFILE error.' ELSEIF(IOS.EQ.40)THEN MESS='(S) BACKSPACE error.' ELSEIF(IOS.EQ.41)THEN MESS='(CNV) Valid logical input not found in external file.' ELSEIF(IOS.EQ.42)THEN MESS='(CNV) Valid logical input not found in internal file.' ELSEIF(IOS.EQ.43)THEN MESS='(CNV) Complex value not found in external READ.' ELSEIF(IOS.EQ.44)THEN MESS='(CNV) Complex value not found in internal READ.' ELSEIF(IOS.EQ.45)THEN MESS='(CNV) NAMELIST item of unknown or invalid type.' ELSEIF(IOS.EQ.46)THEN MESS='(CNV) NAMELIST item with invalid substring range.' ELSEIF(IOS.EQ.47)THEN MESS='(E) NAMELIST input has items of non-zero rank.' ELSEIF(IOS.EQ.48)THEN MESS='(E) NAMELIST input item with zero-sized array.' ELSEIF(IOS.EQ.49)THEN MESS='(CNV) Invalid delimited character string in input.' ELSEIF(IOS.EQ.53)THEN MESS='(F90) Mismatch between edit descriptor and item.' ELSEIF(IOS.EQ.56)THEN MESS='(CNV) Invalid digit in B, O or Z format input.' ELSEIF(IOS.EQ.58)THEN MESS='(E/F90) Format specification error.' ELSEIF(IOS.EQ.84)THEN MESS='(CNV) NAMELIST group header not found, external file.' ELSEIF(IOS.EQ.85)THEN MESS='(CNV) NAMELIST group header not found, internal file.' ELSEIF(IOS.EQ.86)THEN MESS='(CNV) Invalid NAMELIST input found in external file.' ELSEIF(IOS.EQ.87)THEN MESS='(CNV) Invalid NAMELIST input found in internal file.' ELSEIF(IOS.EQ.88)THEN MESS='(CNV) Invalid name found in NAMELIST input.' ELSEIF(IOS.EQ.90)THEN MESS='(CNV) Invalid character in NAMELIST group or item.' ELSEIF(IOS.EQ.91)THEN MESS='(CNV) Invalid NAMELIST input syntax.' ELSEIF(IOS.EQ.92)THEN MESS='(CNV) Invalid subscript list for NAMELIST input item.' ELSEIF(IOS.EQ.93)THEN MESS='(E) I/O statement not allowed on the error unit (0).' ELSEIF(IOS.EQ.94)THEN MESS='(CNV) Invalid repeat counter found in external input.' ELSEIF(IOS.EQ.95)THEN MESS='(CNV) Invalid repeat counter found in internal input.' ELSEIF(IOS.EQ.96)THEN MESS='(CNV) Integer overflow in input.' ELSEIF(IOS.EQ.97)THEN MESS='(CNV) Invalid decimal digit found in input.' ELSEIF(IOS.EQ.98)THEN MESS='(CNV) Input too long for B, Z or O formats.' ELSEIF(IOS.EQ.107)THEN MESS='(S) OPEN with STATUS=NEW and file exists already.' ELSEIF(IOS.EQ.110)THEN MESS='(E) Illegal edit descriptor in formatted I/O' ELSEIF(IOS.EQ.119)THEN MESS='(S) BACKSPACE attempted on a tape device.' ELSEIF(IOS.EQ.120)THEN MESS='(E) The NLWIDTH setting exceeds the record length.' ELSEIF(IOS.EQ.121)THEN MESS='(CNV) Output length of NAMELIST too long.' ELSEIF(IOS.EQ.122)THEN MESS='(S) Incomplete record encountered during direct READ.' ELSEIF(IOS.EQ.125)THEN MESS='(E) BLANK given on an OPEN for an unformatted file.' ELSEIF(IOS.EQ.127)THEN MESS='(E) POSITION given on an OPEN for a direct file.' ELSEIF(IOS.EQ.128)THEN MESS='(E) POSITION value given on an OPEN is not valid.' ELSEIF(IOS.EQ.129)THEN MESS='(E) ACTION value given on an OPEN is not valid.' ELSEIF(IOS.EQ.130)THEN MESS='(S) ACTION=READWRITE for an OPEN on a pipe.' ELSEIF(IOS.EQ.131)THEN MESS='(E) DELIM given on an OPEN for an unformatted file.' ELSEIF(IOS.EQ.132)THEN MESS='(E) DELIM value given on an OPEN is not valid.' ELSEIF(IOS.EQ.133)THEN MESS='(E) PAD given on an OPEN for an unformatted file.' ELSEIF(IOS.EQ.134)THEN MESS='(E) PAD value given on an OPEN is not valid.' ELSEIF(IOS.EQ.135)THEN MESS='(S) Call to an unsupported version of the XLF RTL.' ELSEIF(IOS.EQ.136)THEN MESS='(E) ADVANCE value given on a READ is not valid.' ELSEIF(IOS.EQ.137)THEN MESS='(E) SIZE present but ADVANCE=NO missing in a READ.' ELSEIF(IOS.EQ.138)THEN MESS='(E) EOR present but ADVANCE=NO missing in a READ.' ELSEIF(IOS.EQ.139)THEN MESS='(S) Operation not compatible with ACTION specifier.' ELSEIF(IOS.EQ.140)THEN MESS='(F90) I/O attempted for an unconnected unit.' ELSEIF(IOS.EQ.141)THEN MESS='(F90) Two consecutive ENDFILEs.' ELSEIF(IOS.EQ.142)THEN MESS='(S) CLOSE error.' ELSEIF(IOS.EQ.144)THEN MESS='(S) INQUIRE error.' ELSEIF(IOS.EQ.145)THEN MESS='(E) READ or WRITE attempted after the end-of-file.' ELSEIF(IOS.EQ.151)THEN MESS='(F90) FILE missing nor STATUS=SCRATCH in OPEN.' ELSEIF(IOS.EQ.152)THEN MESS='(S) OPEN with ACCESS=DIRECT for a sequential file.' ELSEIF(IOS.EQ.153)THEN MESS='(S) REWIND or APPEND on an OPEN for a pipe.' ELSEIF(IOS.EQ.156)THEN MESS='(S) Invalid record length on an OPEN statement.' ELSEIF(IOS.EQ.159)THEN MESS='(S) External input not flushed - seek not possible.' ELSE MESS='(?) Error message with unknown IOSTAT code.' ENDIF *** Dump the data in DEBUG mode. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ INPIOS DEBUG : IOSTAT'', - '' error code received is '',I8)') IOS *** Interpret the error message. WRITE(LUNOUT,'('' ------ INPIOS MESSAGE : Supplementary data'', - '' for the above error message:''/26X,A)') MESS END +DECK,INPLUN. SUBROUTINE INPLUN(LUNIN) *----------------------------------------------------------------------- * INPLUN - Returns the current input logical unit number. * (Last changed on 10/12/90.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,INPUT. INTEGER LUNIN *** Return the unit number. LUNIN=LUN END +DECK,INPMSG. SUBROUTINE INPMSG(IWRD,MSG) *----------------------------------------------------------------------- * INPMSG - Registers the error message MSG for word IWRD. *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,INPUT. CHARACTER*(*) MSG INTEGER IWRD *** Assign error message and set print flag. ERRPRT(IWRD)=.TRUE. ERRCDE(IWRD)=MSG *** Replace the word. WORD(IWRD)='*DELETED*' NCHAR(IWRD)=9 END +DECK,INPNUM. SUBROUTINE INPNUM(NNWORD) *----------------------------------------------------------------------- * INPNUM - Returns the current number of words. *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,INPUT. INTEGER NNWORD NNWORD=NWORD END +DECK,INPPAR. SUBROUTINE INPPAR(IFAIL) *----------------------------------------------------------------------- * INPPAR - Imitates the Parse instruction from REXX by assigning bits * of a string to global variables. * (Last changed on 9/11/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,GLOBALS. +SEQ,PRINTPLOT. +SEQ,INPUT. EXTERNAL INPCMP INTEGER INPCMP,IFAIL,NCFMT,NCLINE,NCVAR,MODRES(MXVAR),IGLB, - IFAIL1,NRES,IENTRY,I,ITYPE CHARACTER*10 VARNAM CHARACTER*(MXINCH) FORMAT,LINE LOGICAL USE(MXVAR),EXEC REAL RES(1) *** Identify the routine for tracing purposes. IF(LIDENT)PRINT *,' /// ROUTINE INPPAR ///' *** Assume that things will work out correctly. IFAIL=0 *** Assume we are in non-execution mode. EXEC=.FALSE. *** Check for the EVALUATE and LITERAL options. IF(INPCMP(2,'EVAL#UATE')+INPCMP(2,'EXEC#UTE').NE.0)THEN EXEC=.TRUE. ITYPE=3 ELSEIF(INPCMP(2,'LIT#ERALLY')+INPCMP(2,'NOEVAL#UATE')+ - INPCMP(2,'NOEXEC#UTE').NE.0)THEN EXEC=.FALSE. ITYPE=3 ELSE ITYPE=2 ENDIF *** Get the number of words. IF(NWORD.LT.ITYPE)RETURN *** Input is a global variable. IF(INPCMP(ITYPE,'GL#OBAL').NE.0)THEN * Check that there are enough arguments. IF(NWORD.LT.ITYPE+2)THEN PRINT *,' !!!!!! INPPAR WARNING : Parse Global needs'// - ' at least a global name and a template; ignored.' IFAIL=1 RETURN ENDIF * Locate the global variable. CALL INPSTR(ITYPE+1,ITYPE+1,VARNAM,NCVAR) IGLB=0 DO 10 I=1,NGLB IF(VARNAM(1:NCVAR).EQ.GLBVAR(I))IGLB=I 10 CONTINUE IF(IGLB.EQ.0)THEN PRINT *,' !!!!!! INPPAR WARNING : The global'// - ' variable '//VARNAM(1:NCVAR)//' is not'// - ' known; Parse Global ignored.' IFAIL=1 RETURN ENDIF * Get the global variable. CALL OUTFMT(GLBVAL(IGLB),GLBMOD(IGLB),LINE,NCLINE,'LEFT') * And get the template. CALL INPSTR(ITYPE+2,NWORD,FORMAT,NCFMT) * Assign the globals. CALL INPTMP(LINE,NCLINE,FORMAT,NCFMT,EXEC,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! INPPAR WARNING : Error detected'// - ' in Parse Global for '//VARNAM(1:NCVAR)//'.' IFAIL=1 RETURN ENDIF *** Input is from regular input. ELSEIF(INPCMP(ITYPE,'IN#PUT').NE.0)THEN * Check that there are enough arguments. IF(NWORD.LT.ITYPE+1)THEN PRINT *,' !!!!!! INPPAR WARNING : Parse Input needs'// - ' at least a template; ignored.' IFAIL=1 RETURN ENDIF * And get the template. CALL INPSTR(ITYPE+1,NWORD,FORMAT,NCFMT) * Set a prompt. CALL INPPRM('Input','ADD-PRINT') * Get an input line. CALL INPGET CALL INPSTR(1,NWORD,LINE,NCLINE) * Remove prompt. CALL INPPRM(' ','BACK-PRINT') * Assign the globals. CALL INPTMP(LINE,NCLINE,FORMAT,NCFMT,EXEC,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! INPPAR WARNING : Error detected'// - ' in Parse Input.' IFAIL=1 RETURN ENDIF *** Input file argument. ELSEIF(INPCMP(ITYPE,'ARG#UMENT').NE.0)THEN * Check that there are enough arguments. IF(NWORD.LT.ITYPE+1)THEN PRINT *,' !!!!!! INPPAR WARNING : Parse Argument'// - ' needs at least a template; ignored.' IFAIL=1 RETURN ENDIF * And get the template. CALL INPSTR(ITYPE+1,NWORD,FORMAT,NCFMT) * Assign the globals. CALL INPTMP(ARGSTR,NCARG,FORMAT,NCFMT,EXEC,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! INPPAR WARNING : Error detected'// - ' in Parse Argument.' IFAIL=1 RETURN ENDIF *** Input is from terminal input. ELSEIF(INPCMP(ITYPE,'TERM#INAL').NE.0)THEN * Check that there are enough arguments. IF(NWORD.LT.ITYPE+1)THEN PRINT *,' !!!!!! INPPAR WARNING : Parse Terminal'// - ' needs at least a template; ignored.' IFAIL=1 RETURN ENDIF * And get the template. CALL INPSTR(ITYPE+1,NWORD,FORMAT,NCFMT) * Switch to terminal input. CALL INPSWI('TERMINAL') * Set a prompt. CALL INPPRM('Input','ADD-PRINT') * Get an input line. CALL INPGET CALL INPSTR(1,NWORD,LINE,NCLINE) * Remove prompt. CALL INPPRM(' ','BACK-PRINT') * Return to regular input. CALL INPSWI('RESTORE') * Assign the globals. CALL INPTMP(LINE,NCLINE,FORMAT,NCFMT,EXEC,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! INPPAR WARNING : Error detected'// - ' in Parse Terminal.' IFAIL=1 RETURN ENDIF *** Input from the result of some calculation. ELSEIF(INPCMP(ITYPE,'VAL#UE').NE.0)THEN * Check that there are enough arguments. IF(NWORD.LT.ITYPE+2)THEN PRINT *,' !!!!!! INPPAR WARNING : Parse Value needs'// - ' at least a global name and a template; ignored.' IFAIL=1 RETURN ENDIF * Get the expression. CALL INPSTR(ITYPE+1,ITYPE+1,LINE,NCLINE) * Translate the expression. CALL ALGPRE(LINE(1:NCLINE),NCLINE, - GLBVAR,NGLB,NRES,USE,IENTRY,IFAIL1) * Make sure that the formula was OK. IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! INPPAR WARNING : Translation'// - ' of expression '//LINE(1:NCLINE)// - ' failed; Parse Value ignored.' IFAIL=1 CALL ALGCLR(IENTRY) RETURN * Verify that we get indeed only one result. ELSEIF(NRES.NE.1)THEN PRINT *,' !!!!!! INPPAR WARNING : Translation'// - ' of expression '//LINE(1:NCLINE)// - ' does not yield 1 result; Parse Value ignored.' CALL ALGCLR(IENTRY) IFAIL=1 RETURN ENDIF * Set the execution time. CALL TIMEL(GLBVAL(1)) * Evaluate the formula. CALL ALGEXE(IENTRY,GLBVAL,GLBMOD,NGLB,RES,MODRES,1,IFAIL1) * Check the return code of the evaluation. IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! INPTMP WARNING : Evaluation of'// - ' expression '//LINE(1:NCLINE)// - ' failed; Parse Value ignored.' CALL ALGCLR(IENTRY) IFAIL=1 RETURN ENDIF * Print any evaluation errors. CALL ALGERR * Remove the entry point of the formula. CALL ALGCLR(IENTRY) * Assign the result to the string. CALL OUTFMT(RES(1),MODRES(1),LINE,NCLINE,'LEFT') * And get the template. CALL INPSTR(ITYPE+2,NWORD,FORMAT,NCFMT) * Assign the globals. CALL INPTMP(LINE,NCLINE,FORMAT,NCFMT,EXEC,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! INPPAR WARNING : Error detected'// - ' in Parse Value.' IFAIL=1 RETURN ENDIF *** Other sources. ELSE CALL INPSTR(ITYPE,ITYPE,LINE,NCLINE) PRINT *,' !!!!!! INPPAR WARNING : '//LINE(1:NCLINE)// - ' is not a known source for Parse; ignored.' IFAIL=1 RETURN ENDIF END +DECK,INPPRM. SUBROUTINE INPPRM(TEXT,MODE) *----------------------------------------------------------------------- * INPPRM - Sets or expands the prompt string, the prompt string is * ignored on some computers. *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,INPUT. CHARACTER*(*) TEXT,MODE INTEGER I,ILAST *** Check for the NEW/ADD options. IF(INDEX(MODE,'NEW').NE.0)THEN PROMPT=TEXT(1:LEN(TEXT)) NCPROM=LEN(TEXT) ELSEIF(INDEX(MODE,'ADD').NE.0.AND.NCPROM.LT.80)THEN PROMPT(NCPROM+1:MIN(80,NCPROM+1+LEN(TEXT)))= - '-'//TEXT(1:LEN(TEXT)) NCPROM=MIN(80,NCPROM+1+LEN(TEXT)) ELSEIF(INDEX(MODE,'BACK').NE.0)THEN ILAST=NCPROM DO 10 I=ILAST,1,-1 IF(PROMPT(I:I).EQ.'-')THEN NCPROM=I-1 GOTO 20 ENDIF 10 CONTINUE 20 CONTINUE ENDIF *** Check for the PRINT/NOPRINT options. IF(INDEX(MODE,'NOPRINT').NE.0)THEN LPROM=.FALSE. ELSEIF(INDEX(MODE,'PRINT').NE.0)THEN LPROM=.TRUE. ENDIF END +DECK,INPRAW. SUBROUTINE INPRAW(OUT) *----------------------------------------------------------------------- * INPRAW - Return the raw input string. * (Last changed on 23/ 4/90.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,INPUT. CHARACTER*(*) OUT OUT=STRING END +DECK,INPRDH. SUBROUTINE INPRDH(IWRD,IVAL,IDEF) *----------------------------------------------------------------------- * INPRDH - Reads word IWRD into IVAL, using the default IDEF if the * word is empty and if it contains a *. * (Last changed on 14/11/09.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,INPUT. CHARACTER CHAR INTEGER HEX,IWRD,IVAL,IDEF,I *** Statement function used for decoding Hex numbers. HEX(CHAR)=INDEX('0123456789ABCDEF',CHAR)-1 *** Word out of range or blank or default. IF(IWRD.LE.0.OR.IWRD.GT.NWORD.OR. - WORD(IWRD).EQ.' '.OR.WORD(IWRD).EQ.'*')THEN IVAL=IDEF RETURN ENDIF *** Read the hexadecimal constant, avoiding overflow. IF(NCHAR(IWRD).LE.0.OR.NCHAR(IWRD).GT.6)THEN IVAL=IDEF RETURN ENDIF * Character by character. IVAL=0 DO 10 I=NCHAR(IWRD),1,-1 IVAL=IVAL+16**(NCHAR(IWRD)-I)*HEX(WORD(IWRD)(I:I)) 10 CONTINUE END +DECK,INPRDI. SUBROUTINE INPRDI(IWRD,IVAL,IDEF) *----------------------------------------------------------------------- * INPRDI - Reads word IWRD into IVAL, using the default IDEF if the * word is empty and if it contains a *. * (Last changed on 1/ 7/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,INPUT. INTEGER IWRD,IVAL,IDEF CHARACTER*25 AUX *** Out of range ? IF(IWRD.LE.0.OR.IWRD.GT.NWORD.OR. - WORD(IWRD).EQ.' '.OR.WORD(IWRD).EQ.'*')THEN IVAL=IDEF RETURN ENDIF *** Read the value. AUX=WORD(IWRD)(1:NCHAR(IWRD)) READ(AUX,'(BN,I25)') IVAL END +DECK,INPRDO. SUBROUTINE INPRDO(IFAIL) *----------------------------------------------------------------------- * INPRDO - Reads a DO loop, stores the lines and prepares entries. * (Last changed on 11/ 5/12.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,DOLOOP. +SEQ,GLOBALS. +SEQ,ALGDATA. +SEQ,PRINTPLOT. CHARACTER*(MXCHAR) BLANK,FROM,STEP,WHILE,UNTIL,TO,IN CHARACTER*13 PROMPT CHARACTER*10 FOR CHARACTER*8 TYPE CHARACTER*(MXINCH) STRING,INDSTR INTEGER INPCMP,NCSTR,NCIND,IENTNO,IEXTR,ILAST,MAXDOL,MAXIFL,NC, - NNRES,IFAIL,NWORD, - NCFOR,NCFROM,NCSTEP,NCWHIL,NCUNTL,NCTO,NCIN, - I,J,I0,I1,IFAIL1,IFAIL2,IFAIL3,IFAIL4,IFAIL5,IFAIL11, - NRES1,NRES2,NRES3,NRES4,NRES5,NRES11, - ILLCHR,IGLB,NCPRM,ITHEN LOGICAL OK,USE(MXVAR),LFROM,LSTEP,LWHILE,LUNTIL,LTO,LIN EXTERNAL INPCMP *** Initialise the various level and line counters. NDOLIN=0 CDOLVL=0 TRACDO(0)=0 CIFLVL=0 TRACIF(0)=0 MAXDOL=0 MAXIFL=0 NLOOP=0 NIF=0 OK=.TRUE. *** Update the prompt. CALL INPPRM('Loop','ADD') *** Carry on with the next line (passed on or read at end of loop). 10 CONTINUE *** Increment the line counter. NDOLIN=NDOLIN+1 IF(NDOLIN.GT.MXDLIN)THEN PRINT *,' !!!!!! INPRDO WARNING : DO loop contains too'// - ' many lines; increase MXDLIN.' OK=.FALSE. NDOLIN=MXDLIN ENDIF *** Usually no global variable definition. LINREF(NDOLIN,7)=0 LINREF(NDOLIN,8)=0 *** Count words. CALL INPNUM(NWORD) * Locate the THEN, if there is one. DO 270 I=1,NWORD IF(INPCMP(I,'THEN').NE.0)THEN ITHEN=I GOTO 280 ENDIF 270 CONTINUE ITHEN=0 280 CONTINUE *** Process an IF cond THEN (expr) part at the start of the line. IF(INPCMP(1,'IF')+INPCMP(1,'ELSEIF').NE.0.AND.ITHEN.NE.0)THEN * Be sure that the condition clause is not empty. IF(ITHEN.LE.2)THEN PRINT *,' !!!!!! INPRDO WARNING : Empty clause in'// - ' an IF or ELSEIF line; False assumed.' OK=.FALSE. ENDIF * Check an IF block does not begin here. IF(INPCMP(ITHEN+1,'IF')+INPCMP(ITHEN+1,'ELSE')+ - INPCMP(ITHEN+1,'ELSEIF')+ - INPCMP(ITHEN+1,'ENDIF').NE.0)THEN PRINT *,' !!!!!! INPRDO WARNING : Parts of an IF'// - ' block may not start on an IF line; use & (and).' OK=.FALSE. ENDIF * Check this is not an ENDDO. IF(INPCMP(ITHEN+1,'ENDDO').NE.0)THEN PRINT *,' !!!!!! INPRDO WARNING : A DO block may'// - ' not end on an IF line.' OK=.FALSE. ENDIF * Pick up the condition, translate and store the entry. IF(ITHEN.GT.2)THEN CALL INPSTR(2,ITHEN-1,STRING,NC) ELSE STRING='FALSE' NC=5 ENDIF CALL ALGPRE(STRING(1:NC),NC,GLBVAR,NGLB,NNRES,USE, - LINREF(NDOLIN,4),IFAIL) IF(IFAIL.NE.0.OR.NNRES.NE.1)THEN PRINT *,' !!!!!! INPRDO WARNING : Unable to'// - ' translate the condition.' OK=.FALSE. ENDIF * Get rid of the IF clause before carrying on. IF(NWORD.GT.ITHEN)THEN DO 290 I=ITHEN,1,-1 CALL INPDEL(I) 290 CONTINUE NWORD=NWORD-ITHEN ENDIF * Does not start with an IF condition. ELSE LINREF(NDOLIN,4)=0 ENDIF * Branching by default not used. LINREF(NDOLIN,5)=0 *** Start of a new DO loop. IF(INPCMP(NWORD,'DO').NE.0.AND.INPCMP(1,'FOR')+ - INPCMP(1,'WHILE')+INPCMP(1,'UNTIL')+INPCMP(1,'IN')+ - INPCMP(1,'STEP')+INPCMP(1,'DO').NE.0)THEN * Increment loop number, level counter and update calling tree. IF(NLOOP.GE.MXDLVL)THEN PRINT *,' !!!!!! INPRDO WARNING : Number of DO loops'// - ' exceeds storage capacity.' OK=.FALSE. ELSE NLOOP=NLOOP+1 ENDIF MAXDOL=MAX(MAXDOL,CDOLVL+1) IF(CDOLVL.GE.MXDLVL)THEN PRINT *,' !!!!!! INPRDO WARNING : DO nesting deeper'// - ' than length of loop trace.' OK=.FALSE. ELSE CDOLVL=CDOLVL+1 ENDIF TRACDO(CDOLVL)=NLOOP * Store the type of this line with the loop reference number. LINREF(NDOLIN,1)=1 LINREF(NDOLIN,3)=TRACDO(CDOLVL) LINREF(NDOLIN,6)=TRACIF(CIFLVL) * Save the information also in the DO loop control block. DOREF(NLOOP,6)=NDOLIN DOREF(NLOOP,7)=0 DOREF(NLOOP,8)=CDOLVL DOREF(NLOOP,10)=CIFLVL * Initial values for the loop control words. FOR=' ' NCFOR=1 FROM=' ' NCFROM=1 LFROM=.FALSE. STEP='1' NCSTEP=1 LSTEP=.FALSE. IN=' ' NCIN=1 LIN=.FALSE. WHILE='TRUE' NCWHIL=4 LWHILE=.FALSE. UNTIL='FALSE' NCUNTL=5 LUNTIL=.FALSE. TO=' ' NCTO=1 LTO=.FALSE. * Pick up the DO loop control words: FOR, FROM, STEP, WHILE, UNTIL. IF(NWORD.NE.1.AND.(NWORD-1).NE. - 2*INT(0.1+REAL(NWORD-1)/2.0))THEN PRINT *,' !!!!!! INPRDO WARNING : The number of'// - ' words on the DO line is incorrect.' OK=.FALSE. ENDIF DO 20 I=1,NWORD-2,2 * Read the loop variable name. IF(INPCMP(I,'FOR').NE.0)THEN CALL INPSTR(I+1,I+1,STRING,NC) * Check for illegal characters. ILLCHR=0 DO 30 J=1,NC IF(INDEX('+-*/&|<=#>^ ,.:;([{)]}''"`', - STRING(J:J)).NE.0)THEN ILLCHR=ILLCHR+1 OK=.FALSE. ENDIF 30 CONTINUE IF(INDEX('ABCDEFGHIJKLMNOPQRSTUVWXYZ', - STRING(1:1)).EQ.0)THEN CALL INPMSG(I+1,'Does not start with a letter. ') OK=.FALSE. ELSEIF(ILLCHR.EQ.1)THEN CALL INPMSG(I+1,'Contains an illegal character.') ELSEIF(ILLCHR.GT.1)THEN CALL INPMSG(I+1,'Contains illegal characters. ') * Check the name is not more than 10 characters long. ELSEIF(NC.GT.LEN(FOR))THEN CALL INPMSG(I+1,'Name longer than 10 characters') OK=.FALSE. * Check the name is not empty. ELSEIF(NC.LE.0)THEN CALL INPMSG(I+1,'Empty names are not permitted.') OK=.FALSE. * Store the name. ELSE FOR=STRING(1:NC) NCFOR=NC ENDIF * Starting value. ELSEIF(INPCMP(I,'FROM').NE.0)THEN CALL INPSTR(I+1,I+1,STRING,NC) IF(NC.GT.80)THEN CALL INPMSG(I+1,'Expression longer than 80 char') OK=.FALSE. ELSEIF(NC.LE.0)THEN CALL INPMSG(I+1,'Empty expression not permitted') OK=.FALSE. ELSE FROM=' ' FROM=STRING(1:NC) NCFROM=NC LFROM=.TRUE. ENDIF * Step size for the loop. ELSEIF(INPCMP(I,'STEP').NE.0)THEN CALL INPSTR(I+1,I+1,STRING,NC) IF(NC.GT.80)THEN CALL INPMSG(I+1,'Expression longer than 80 char') OK=.FALSE. ELSEIF(NC.LE.0)THEN CALL INPMSG(I+1,'Empty expression not permitted') OK=.FALSE. ELSE STEP=' ' STEP=STRING(1:NC) NCSTEP=NC LSTEP=.TRUE. ENDIF * Condition to be satisfied, check at start of loop. ELSEIF(INPCMP(I,'WHILE').NE.0)THEN CALL INPSTR(I+1,I+1,STRING,NC) IF(NC.GT.80)THEN CALL INPMSG(I+1,'Expression longer than 80 char') OK=.FALSE. ELSEIF(NC.LE.0)THEN CALL INPMSG(I+1,'Empty expression not permitted') OK=.FALSE. ELSE WHILE=' ' WHILE=STRING(1:NC) NCWHIL=NC LWHILE=.TRUE. ENDIF * Condition not to be satisfied, check at end of loop. ELSEIF(INPCMP(I,'UNTIL').NE.0)THEN CALL INPSTR(I+1,I+1,STRING,NC) IF(NC.GT.80)THEN CALL INPMSG(I+1,'Expression longer than 80 char') OK=.FALSE. ELSEIF(NC.LE.0)THEN CALL INPMSG(I+1,'Empty expression not permitted') OK=.FALSE. ELSE UNTIL=' ' UNTIL=STRING(1:NC) NCUNTL=NC LUNTIL=.TRUE. ENDIF * Final value of the loop variable. ELSEIF(INPCMP(I,'TO').NE.0)THEN CALL INPSTR(I+1,I+1,STRING,NC) IF(NC.GT.80)THEN CALL INPMSG(I+1,'Expression longer than 80 char') OK=.FALSE. ELSEIF(NC.LE.0)THEN CALL INPMSG(I+1,'Empty expression not permitted') OK=.FALSE. ELSE TO=' ' TO=STRING(1:NC) NCTO=NC LTO=.TRUE. ENDIF * Matrix or matrix expression to take elements from. ELSEIF(INPCMP(I,'IN').NE.0)THEN CALL INPSTR(I+1,I+1,STRING,NC) IF(NC.GT.80)THEN CALL INPMSG(I+1,'Expression longer than 80 char') OK=.FALSE. ELSEIF(NC.LE.0)THEN CALL INPMSG(I+1,'Empty expression not permitted') OK=.FALSE. ELSE IN=' ' IN=STRING(1:NC) NCIN=NC LIN=.TRUE. ENDIF * Anything else, not valid. ELSE CALL INPMSG(I,'Not a known DO control word. ') CALL INPMSG(I+1,'See preceding message. ') ENDIF 20 CONTINUE ** Take care of the DO loop variable name. IF(FOR.NE.' ')THEN * Locate the loop variable in the table. DO 40 I=1,NGLB IF(GLBVAR(I).EQ.FOR(1:NCFOR))THEN DOREF(NLOOP,9)=I GOTO 50 ENDIF 40 CONTINUE IF(NGLB.GE.MXVAR)THEN PRINT *,' !!!!!! INPRDO WARNING : Ran out of'// - ' storage space for global variables.' PRINT *,' Increase'// - ' MXVAR and recompile the program.' DOREF(NLOOP,9)=0 OK=.FALSE. ELSE NGLB=NGLB+1 GLBVAR(NGLB)=FOR(1:NCFOR) GLBMOD(NGLB)=0 DOREF(NLOOP,9)=NGLB ENDIF 50 CONTINUE * Make sure the loop variable was not used before. DO 60 I=1,NLOOP-1 IF(DOREF(I,9).LE.0.OR.DOREF(NLOOP,9).EQ.0)GOTO 60 IF(DOREF(I,6).LE.NDOLIN.AND. - (DOREF(I,7).EQ.0.OR.DOREF(I,7).GT.NDOLIN).AND. - GLBVAR(DOREF(I,9)).EQ.GLBVAR(DOREF(NLOOP,9)))THEN PRINT *,' !!!!!! INPRDO WARNING : The DO loop'// - ' variable '//FOR(1:NCFOR)//' is already'// - ' used for an enclosing loop.' OK=.FALSE. ENDIF 60 CONTINUE * Assign to the loop variable. IF(DOREF(NLOOP,9).GT.0)THEN GLBVAL(DOREF(NLOOP,9))=0 GLBMOD(DOREF(NLOOP,9))=0 ENDIF * No name specified, assign the dummy variable 0 to this loop. ELSE DOREF(NLOOP,9)=0 ENDIF ** Translate the various expressions. IF(DOREF(NLOOP,9).NE.0)THEN * Verify that not both an IN and an FROM-STEP-TO are present. IF(LIN.AND.(LFROM.OR.LSTEP.OR.LTO))THEN PRINT *,' !!!!!! INPRDO WARNING : The DO loop'// - ' with variable "'//GLBVAR(DOREF(NLOOP,9))// - ' has both an In and a From-Step-To.' OK=.FALSE. ENDIF * Default step size if needed. IF((.NOT.LIN).AND.STEP.EQ.' ')THEN PRINT *,' ------ INPRDO MESSAGE : Default'// - ' step size 1 used for the loop of the'// - ' variable "'//GLBVAR(DOREF(NLOOP,9))//'"' STEP='1' NCSTEP=1 ENDIF * Process the IN part. IF(IN.NE.' ')THEN CALL ALGPRE(IN,NCIN,GLBVAR,NGLB,NRES11,USE, - DOREF(NLOOP,11),IFAIL11) NRES1=1 IFAIL1=0 DOREF(NLOOP,1)=0 NRES2=1 IFAIL2=0 DOREF(NLOOP,2)=0 NRES5=1 IFAIL5=0 DOREF(NLOOP,5)=0 * Process the FROM, STEP and TO parts. ELSEIF(FROM.EQ.' '.OR.TO.EQ.' ')THEN PRINT *,' !!!!!! INPRDO WARNING : The DO loop'// - ' with variable "'//GLBVAR(DOREF(NLOOP,9))// - '" misses a FROM or a TO.' OK=.FALSE. NRES1=1 IFAIL1=0 DOREF(NLOOP,1)=0 NRES2=1 IFAIL2=0 DOREF(NLOOP,2)=0 NRES5=1 IFAIL5=0 DOREF(NLOOP,5)=0 NRES11=1 IFAIL11=0 DOREF(NLOOP,11)=0 ELSE CALL ALGPRE(FROM,NCFROM,GLBVAR,NGLB,NRES1,USE, - DOREF(NLOOP,1),IFAIL1) CALL ALGPRE(STEP,NCSTEP,GLBVAR,NGLB,NRES2,USE, - DOREF(NLOOP,2),IFAIL2) CALL ALGPRE(TO,NCTO,GLBVAR,NGLB,NRES5,USE, - DOREF(NLOOP,5),IFAIL5) NRES11=1 IFAIL11=0 DOREF(NLOOP,11)=0 ENDIF ELSE IFAIL1=0 IFAIL2=0 IFAIL5=0 IFAIL11=0 NRES1=1 NRES2=1 NRES5=1 NRES11=1 ENDIF * Process the WHILE and UNTIL parts. IF(WHILE.EQ.' ')THEN WHILE='TRUE' NCWHIL=4 ENDIF IF(UNTIL.EQ.' ')THEN UNTIL='FALSE' NCUNTL=5 ENDIF CALL ALGPRE(WHILE,NCWHIL,GLBVAR,NGLB,NRES3,USE, - DOREF(NLOOP,3),IFAIL3) CALL ALGPRE(UNTIL,NCUNTL,GLBVAR,NGLB,NRES4,USE, - DOREF(NLOOP,4),IFAIL4) IF(IFAIL1.NE.0.OR.IFAIL2.NE.0.OR.IFAIL3.NE.0.OR. - IFAIL4.NE.0.OR.IFAIL5.NE.0.OR.IFAIL11.NE.0)THEN PRINT *,' !!!!!! INPRDO WARNING : One or more of the'// - ' loop control expressions can''t be translated'// - ' into an algebra list.' OK=.FALSE. ENDIF IF(NRES1.NE.1.OR.NRES2.NE.1.OR.NRES3.NE.1.OR.NRES4.NE.1.OR. - NRES5.NE.1.OR.NRES11.NE.1)THEN PRINT *,' !!!!!! INPRDO WARNING : Incorrect number'// - ' of results returned by loop control expression.' OK=.FALSE. ENDIF *** Go for another iteration cycle. ELSEIF(INPCMP(1,'ITERATE')+INPCMP(1,'CONTINUE').NE.0)THEN LINREF(NDOLIN,1)=2 * First assign an invalid loop reference number to the statement. LINREF(NDOLIN,3)=0 * The IF block number is known. LINREF(NDOLIN,6)=TRACIF(CIFLVL) * Mark unused words. IF(NWORD.GT.2)THEN DO 130 I=3,NWORD CALL INPMSG(I,'Superfluous argument (ignored)') 130 CONTINUE OK=.FALSE. ENDIF * Figure out which loop we have to carry out again. IF(NWORD.GE.2)THEN CALL INPSTR(2,2,STRING,NC) DO 140 I=1,NLOOP IF(DOREF(I,9).EQ.0)GOTO 140 IF(GLBVAR(DOREF(I,9)).EQ. - STRING(1:MAX(1,MIN(10,NC))))LINREF(NDOLIN,3)=I 140 CONTINUE IF(LINREF(NDOLIN,3).EQ.0)THEN CALL INPMSG(2,'Unidentified loop variable. ') OK=.FALSE. ENDIF * No loop specified: carry out inner loop again. ELSE LINREF(NDOLIN,3)=TRACDO(CDOLVL) ENDIF * Check this loop is part of the calling trace. DO 180 I=1,CDOLVL IF(LINREF(NDOLIN,3).EQ.TRACDO(I))GOTO 190 180 CONTINUE PRINT *,' !!!!!! INPRDO WARNING : The loop to be'// - ' iterated is not part of the trace.' OK=.FALSE. 190 CONTINUE *** Leave the loop earlier. ELSEIF(INPCMP(1,'LEAVE')+INPCMP(1,'BREAK').NE.0)THEN LINREF(NDOLIN,1)=3 * First assign an invalid loop reference number to the statement. LINREF(NDOLIN,3)=0 * The IF block is known. LINREF(NDOLIN,6)=TRACIF(CIFLVL) * Mark unused words. IF(NWORD.GT.2)THEN DO 110 I=3,NWORD CALL INPMSG(I,'Superfluous argument (ignored)') 110 CONTINUE OK=.FALSE. ENDIF * Figure out which loop we have to leave. IF(NWORD.GE.2)THEN CALL INPSTR(2,2,STRING,NC) DO 120 I=1,NLOOP IF(DOREF(I,9).EQ.0)GOTO 120 IF(GLBVAR(DOREF(I,9)).EQ. - STRING(1:MAX(1,MIN(10,NC))))LINREF(NDOLIN,3)=I 120 CONTINUE IF(LINREF(NDOLIN,3).EQ.0)THEN CALL INPMSG(2,'Unidentified loop variable. ') OK=.FALSE. ENDIF * No loop specified: leave inner loop. ELSE LINREF(NDOLIN,3)=TRACDO(CDOLVL) ENDIF * Check this loop is part of the calling trace. DO 170 I=1,CDOLVL IF(LINREF(NDOLIN,3).EQ.TRACDO(I))GOTO 175 170 CONTINUE PRINT *,' !!!!!! INPRDO WARNING : The loop to be left'// - ' is not part of the trace.' OK=.FALSE. 175 CONTINUE *** End of the DO loop. ELSEIF(INPCMP(1,'ENDDO').NE.0)THEN * Check there is a DO loop open. IF(CDOLVL.LE.0)THEN PRINT *,' !!!!!! INPRDO WARNING : There is no open'// - ' DO loop, ENDDO invalid.' OK=.FALSE. * Check the IF levels. ELSEIF(CIFLVL.NE.DOREF(TRACDO(CDOLVL),10))THEN PRINT *,' !!!!!! INPRDO WARNING : Incorrect nesting'// - ' of an IF block and a DO loop.' OK=.FALSE. * OK. ELSE LINREF(NDOLIN,1)=4 LINREF(NDOLIN,3)=TRACDO(CDOLVL) LINREF(NDOLIN,6)=TRACIF(CIFLVL) DOREF(TRACDO(CDOLVL),7)=NDOLIN CDOLVL=CDOLVL-1 ENDIF *** Start of an IF block. ELSEIF(NWORD.EQ.ITHEN.AND.INPCMP(1,'IF').NE.0.AND.ITHEN.NE.0)THEN * Store the information about the input line. LINREF(NDOLIN,1)=11 LINREF(NDOLIN,3)=TRACDO(CDOLVL) * Check whether we can still increment the IF nesting. IF(NIF.GE.MXILVL)THEN PRINT *,' !!!!!! INPRDO WARNING : Number of IF'// - ' blocks exceeds storage capacity.' OK=.FALSE. ELSE NIF=NIF+1 ENDIF * Check whether we can keep track of this IF block in the trace. MAXIFL=MAX(MAXIFL,CIFLVL+1) IF(CIFLVL.GE.MXILVL)THEN PRINT *,' !!!!!! INPRDO WARNING : IF nesting deeper'// - ' than length of the trace.' OK=.FALSE. ELSE CIFLVL=CIFLVL+1 ENDIF * Store part of the IF block reference information. IFREF(NIF,1)=1 IFREF(NIF,2)=0 IFREF(NIF,3)=NDOLIN IFREF(NIF,4)=CDOLVL IFREF(NIF,5)=CIFLVL * Keep track of the IF trace. TRACIF(CIFLVL)=NIF LINREF(NDOLIN,6)=TRACIF(CIFLVL) *** Branch of the ELSEIF type. ELSEIF(NWORD.EQ.ITHEN.AND.INPCMP(1,'ELSEIF').NE.0.AND. - ITHEN.NE.0)THEN * Check that the usage of the IF structure is correct. IF(CIFLVL.EQ.0)THEN PRINT *,' !!!!!! INPRDO WARNING : No open IF block,'// - ' use of ELSEIF is not valid.' OK=.FALSE. ELSEIF(IFREF(TRACIF(CIFLVL),1).GE.3)THEN PRINT *,' !!!!!! INPRDO WARNING : An ELSEIF may not'// - ' be preceded by an ELSE in the same block.' OK=.FALSE. ELSEIF(CDOLVL.NE.IFREF(TRACIF(CIFLVL),4))THEN PRINT *,' !!!!!! INPRDO WARNING : Invalid nesting'// - ' of a DO loop and an IF block.' OK=.FALSE. ELSE * Line reference information. LINREF(NDOLIN,1)=12 LINREF(NDOLIN,3)=TRACDO(CDOLVL) LINREF(NDOLIN,6)=TRACIF(CIFLVL) * Update the jump part for the previous branch. LINREF(IFREF(TRACIF(CIFLVL),3),5)=NDOLIN * Prepare the next jump. IFREF(TRACIF(CIFLVL),3)=NDOLIN * And remember we saw an ENDIF. IFREF(TRACIF(CIFLVL),1)=2 ENDIF *** Branch of the ELSE type. ELSEIF(NWORD.EQ.1.AND.INPCMP(1,'ELSE').NE.0)THEN * Check that the usage of the IF structure is correct. IF(CIFLVL.EQ.0)THEN PRINT *,' !!!!!! INPRDO WARNING : No open IF block,'// - ' use of ELSE is not valid.' OK=.FALSE. ELSEIF(IFREF(TRACIF(CIFLVL),1).GE.3)THEN PRINT *,' !!!!!! INPRDO WARNING : Two ELSE parts'// - ' in the same block not allowed.' OK=.FALSE. ELSEIF(CDOLVL.NE.IFREF(TRACIF(CIFLVL),4))THEN PRINT *,' !!!!!! INPRDO WARNING : Invalid nesting'// - ' of a DO loop and an IF block.' OK=.FALSE. ELSE * Line reference information. LINREF(NDOLIN,1)=13 LINREF(NDOLIN,3)=TRACDO(CDOLVL) LINREF(NDOLIN,6)=TRACIF(CIFLVL) * Update the jump part for the previous branch. LINREF(IFREF(TRACIF(CIFLVL),3),5)=NDOLIN * Prepare the next jump. IFREF(TRACIF(CIFLVL),3)=NDOLIN * And remember we saw an ELSE. IFREF(TRACIF(CIFLVL),1)=3 ENDIF *** End of an IF block. ELSEIF(NWORD.EQ.1.AND.INPCMP(1,'ENDIF').NE.0)THEN * Check that the usage of the IF structure is correct. IF(CIFLVL.EQ.0)THEN PRINT *,' !!!!!! INPRDO WARNING : No open IF block,'// - ' use of ENDIF is not valid.' OK=.FALSE. ELSEIF(CDOLVL.NE.IFREF(TRACIF(CIFLVL),4))THEN PRINT *,' !!!!!! INPRDO WARNING : Invalid nesting'// - ' of a DO loop and an IF block.' OK=.FALSE. ELSE * Line reference information. LINREF(NDOLIN,1)=14 LINREF(NDOLIN,3)=TRACDO(CDOLVL) LINREF(NDOLIN,6)=TRACIF(CIFLVL) * Update the jump part for the previous branch. LINREF(IFREF(TRACIF(CIFLVL),3),5)=NDOLIN * Store the line of the ENDIF in the IF reference block. IFREF(TRACIF(CIFLVL),2)=NDOLIN * And remember we saw an ENDIF. IFREF(TRACIF(CIFLVL),1)=4 * Go back one step in the IF trace. CIFLVL=CIFLVL-1 ENDIF *** An ordinary line. ELSE * Reference information. LINREF(NDOLIN,1)=0 LINREF(NDOLIN,3)=TRACDO(CDOLVL) LINREF(NDOLIN,6)=TRACIF(CIFLVL) ENDIF *** Check also for global variables. IF(INPCMP(1,'GL#OBALS').NE.0.AND.NWORD.GE.2)THEN * Ensure that there is no evaluation in the statement anywhere. CALL INPSTR(2,NWORD,STRING,NC) IF(INDEX(STRING(1:NC),'{')+INDEX(STRING(1:NC),'}').NE.0) - GOTO 186 * Assign the line type. LINREF(NDOLIN,1)=21 ** Fetch the name of the variable. IGLB=0 CALL INPSTR(2,2,STRING,NC) * Find out whether this is a matrix indexing expression. IF(INDEX(STRING(1:NC),'[').GT.1.AND. - STRING(NC:NC).EQ.']')THEN NCSTR=INDEX(STRING(1:NC),'[')-1 INDSTR=STRING(NCSTR+1:NC) NCIND=NC-NCSTR ELSE NCSTR=NC INDSTR=' ' NCIND=0 ENDIF * Check for illegal characters. ILLCHR=0 DO 185 J=1,NCSTR IF(INDEX('+-*/&|<=#>^ ,.:;([{)]}''"`',STRING(J:J)).NE.0)THEN ILLCHR=ILLCHR+1 OK=.FALSE. ENDIF 185 CONTINUE IF(INDEX('ABCDEFGHIJKLMNOPQRSTUVWXYZ',STRING(1:1)).EQ.0)THEN CALL INPMSG(2,'Does not start with a letter. ') OK=.FALSE. ELSEIF(ILLCHR.EQ.1)THEN CALL INPMSG(2,'Contains an illegal character.') ELSEIF(ILLCHR.GT.1)THEN CALL INPMSG(2,'Contains illegal characters. ') * Check the name is not more than 10 characters long. ELSEIF(NCSTR.GT.10)THEN CALL INPMSG(2,'Name longer than 10 characters') OK=.FALSE. * Check the name is not empty. ELSEIF(NCSTR.LE.0)THEN CALL INPMSG(2,'Empty names are not permitted.') OK=.FALSE. ELSE * Figure out which variable to redefine. DO 150 I=1,NGLB IF(GLBVAR(I).EQ.STRING(1:NCSTR))THEN IGLB=I GOTO 160 ENDIF 150 CONTINUE * See whether there still is space to store a new global. IF(NGLB.GE.MXVAR)THEN PRINT *,' !!!!!! INPRDO WARNING : Unable to'// - ' store global variable "'//STRING(1:NCSTR)// - '"; increase MXVAR and recompile.' OK=.FALSE. GOTO 186 * Add the new global. ELSE NGLB=NGLB+1 GLBVAR(NGLB)=STRING(1:NCSTR) GLBMOD(NGLB)=0 ENDIF IGLB=NGLB 160 CONTINUE * Ensure that this variable is not a system variable. IF(IGLB.LE.4)THEN PRINT *,' !!!!!! INPRDO WARNING : '// - STRING(1:NCSTR)//' may not be redefined;'// - ' definition ignored.' OK=.FALSE. GOTO 186 ENDIF ENDIF * Store the reference, -1 for indexed assignments (list takes care). IF(NCIND.EQ.0)THEN LINREF(NDOLIN,7)=IGLB ELSE LINREF(NDOLIN,7)=-1 ENDIF ** Fetch the expression. IF(NWORD.GE.3)THEN CALL INPSTR(3,NWORD,STRING,NC) ELSE STRING='NILL' NC=4 ENDIF ** Translate the expression, first with indexing. IF(NCIND.NE.0)THEN CALL ALGPRE('('//STRING(1:NC)//')'//INDSTR(1:NCIND), - NC+NCIND+2,GLBVAR,NGLB,NNRES,USE,LINREF(NDOLIN,8), - IFAIL) * Check validity. IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! INPRDO WARNING : Unable to'// - ' process the indexing expression; global'// - ' not assigned.' OK=.FALSE. GOTO 186 ELSEIF(NNRES.NE.1)THEN PRINT *,' !!!!!! INPRDO WARNING : Formula'// - ' doesn''t lead to 1 result; global not'// - ' assigned.' OK=.FALSE. GOTO 186 ENDIF * Locate the entry point number. IENTNO=0 DO 70 I=1,NALGE IF(ALGENT(I,1).EQ.LINREF(NDOLIN,8).AND. - ALGENT(I,3).EQ.1)IENTNO=I 70 CONTINUE IF(IENTNO.EQ.0)THEN PRINT *,' !!!!!! INPRDO WARNING : No valid'// - ' indexing entry point found; global'// - ' not assigned.' OK=.FALSE. GOTO 186 ENDIF * Locate the final EXTRACT_SUBMATRIX call. DO 80 I=ALGENT(IENTNO,5)+ALGENT(IENTNO,6)-1, - ALGENT(IENTNO,5)+2,-1 IF(INS(I,1).EQ.-80.AND.INS(I,2).EQ.9.AND. - INS(I-1,2).EQ.8.AND.INS(I-2,2).EQ.8)THEN IEXTR=I GOTO 90 ENDIF 80 CONTINUE PRINT *,' !!!!!! INPRDO WARNING : Instruction list'// - ' tail not as expected.' OK=.FALSE. GOTO 186 90 CONTINUE * Store the location of the last instruction. ILAST=ALGENT(IENTNO,5)+ALGENT(IENTNO,6)-1 * Replace result and return by DELETE_MATRIX on temporary matrix. INS(ILAST-1,1)= 0 INS(ILAST-1,2)= 8 INS(ILAST-1,3)=INS(IEXTR-2,3) INS(ILAST-1,4)= 1 INS(ILAST ,1)=-86 INS(ILAST ,2)= 9 INS(ILAST ,3)= 1 INS(ILAST ,4)= 0 * Replace EXTRACT_SUBMATRIX by STORE_SUBMATRIX. INS(IEXTR ,1)=-81 * Exchange the in/out matrices, assign to global, fix protections. INS(IEXTR-1,1)= 3 INS(IEXTR-1,3)=INS(IEXTR-2,3) INS(IEXTR-2,1)= 0 INS(IEXTR-2,3)=IGLB *** In debug mode, print the list. IF(LDEBUG)THEN WRITE(LUNOUT,'('' ++++++ INPRDO DEBUG : List'', - '' after processing indexing calls:'')') CALL ALGPRT(ALGENT(IENTNO,5),ALGENT(IENTNO,5)+ - ALGENT(IENTNO,6)-1) ENDIF ** Translate for the case without indexing. ELSE CALL ALGPRE(STRING(1:NC),NC, - GLBVAR,NGLB,NNRES,USE,LINREF(NDOLIN,8),IFAIL) * Check validity. IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! INPRDO WARNING : Unable to'// - ' process the indexing expression; global'// - ' not assigned.' OK=.FALSE. ELSEIF(NNRES.NE.1)THEN PRINT *,' !!!!!! INPRDO WARNING : Formula'// - ' doesn''t lead to 1 result; global not'// - ' assigned.' OK=.FALSE. ENDIF ENDIF ** Resume here for non-translatable GLOBALs. 186 CONTINUE *** Declare variables used in VECTOR statements. ELSEIF(INPCMP(1,'VECT#ORS-#READ')+ - INPCMP(1,'R#EAD-VECT#OR').NE.0)THEN * Ensure that there is no evaluation in the statement anywhere. CALL INPSTR(2,NWORD,STRING,NC) IF(INDEX(STRING(1:NC),'{')+INDEX(STRING(1:NC),'}').NE.0) - GOTO 188 ** Loop over the vector names. DO 230 I=2,NWORD * Skip dummy fields. IF(INPCMP(I,'DUMMY').NE.0)GOTO 230 * Fetch the variable name. CALL INPSTR(I,I,STRING,NCSTR) * Check for illegal characters. ILLCHR=0 DO 240 J=1,NCSTR IF(INDEX('+-*/&|<=#>^ ,.:;([{)]}''"`',STRING(J:J)).NE.0)THEN ILLCHR=ILLCHR+1 OK=.FALSE. ENDIF 240 CONTINUE IF(INDEX('ABCDEFGHIJKLMNOPQRSTUVWXYZ',STRING(1:1)).EQ.0)THEN CALL INPMSG(I,'Does not start with a letter. ') OK=.FALSE. ELSEIF(ILLCHR.EQ.1)THEN CALL INPMSG(I,'Contains an illegal character.') ELSEIF(ILLCHR.GT.1)THEN CALL INPMSG(I,'Contains illegal characters. ') * Check the name is not more than 10 characters long. ELSEIF(NCSTR.GT.10)THEN CALL INPMSG(I,'Name longer than 10 characters') OK=.FALSE. * Check the name is not empty. ELSEIF(NCSTR.LE.0)THEN CALL INPMSG(I,'Empty names are not permitted.') OK=.FALSE. ELSE * Figure out whether this variable already exists. IGLB=0 DO 250 J=1,NGLB IF(GLBVAR(J).EQ.STRING(1:NCSTR))THEN IGLB=J GOTO 260 ENDIF 250 CONTINUE * See whether there still is space to store a new global. IF(NGLB.GE.MXVAR)THEN PRINT *,' !!!!!! INPRDO WARNING : Unable to'// - ' store global variable "'//STRING(1:NCSTR)// - '"; increase MXVAR and recompile.' OK=.FALSE. GOTO 230 * Add the new global. ELSE NGLB=NGLB+1 GLBVAR(NGLB)=STRING(1:NCSTR) GLBMOD(NGLB)=0 WRITE(LUNOUT,'('' ------ INPRDO MESSAGE : '',A, - '' declared as a global variable.'')') - STRING(1:NCSTR) ENDIF IGLB=NGLB 260 CONTINUE * Ensure that this variable is not a system variable. IF(IGLB.LE.4)THEN PRINT *,' !!!!!! INPRDO WARNING : '// - STRING(1:NCSTR)//' may not be redefined;'// - ' definition ignored.' OK=.FALSE. GOTO 230 ENDIF ENDIF * Next vector. 230 CONTINUE * Skip if there are { }. 188 CONTINUE *** And for procedure calls. ELSEIF(INPCMP(1,'CALL').NE.0.AND.NWORD.GE.2)THEN * Ensure that there is no evaluation in the statement anywhere. CALL INPSTR(2,NWORD,STRING,NC) IF(INDEX(STRING(1:NC),'{')+INDEX(STRING(1:NC),'}').NE.0) - GOTO 187 * Assign the line type. LINREF(NDOLIN,1)=22 * Generate an entry point. CALL INPCAL('STORE',LINREF(NDOLIN,8),IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! INPRDO WARNING : CALL statement'// - ' could not be processed.' OK=.FALSE. ENDIF * Resume here for non-translatable CALLs. 187 CONTINUE ENDIF *** Ensure there is no input-redirect CALL INPSTR(1,1,STRING,NC) IF(STRING(1:1).EQ.'<')THEN PRINT *,' !!!!!! INPRDO WARNING : Input redirection is'// - ' not permitted inside a loop; loop rejected.' OK=.FALSE. ENDIF *** Store the line in the buffer, no matter the contents. CALL INPRAW(STRING) DO 300 I=MXINCH,1,-1 IF(STRING(I:I).NE.' ')THEN I1=I GOTO 310 ENDIF 300 CONTINUE I1=1 310 CONTINUE DO 320 I=1,I1 IF(STRING(I:I).NE.' ')THEN I0=I GOTO 330 ENDIF 320 CONTINUE I0=1 330 CONTINUE CALL STRBUF('STORE',LINREF(NDOLIN,2),STRING(I0:I1),I1-I0+1,IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! INPRDO WARNING : Unable to store an'// - ' input line.' OK=.FALSE. ENDIF *** Dump the error messages. CALL INPERR *** And read the next line, if we're still in the loop nest. IF(CDOLVL.GT.0)THEN * Format the prompt. PROMPT=' ' IF(CIFLVL.GT.0.AND.CDOLVL.GT.0)THEN WRITE(PROMPT,'(''Do_'',I3,''_If_'',I3)') CDOLVL,CIFLVL ELSEIF(CDOLVL.GT.0)THEN WRITE(PROMPT,'(''Do_'',I3)') CDOLVL ELSEIF(CIFLVL.GT.0)THEN WRITE(PROMPT,'(''If_'',I3)') CIFLVL ELSE PROMPT='Loop' ENDIF NCPRM=0 DO 400 I=1,13 IF(PROMPT(I:I).NE.' ')THEN NCPRM=NCPRM+1 PROMPT(NCPRM:NCPRM)=PROMPT(I:I) ENDIF 400 CONTINUE CALL INPPRM(' ','BACK') CALL INPPRM(PROMPT(1:MAX(1,NCPRM)),'ADD') * Read the new line. CALL INPGET GOTO 10 ENDIF *** End of the loop nest has been reached, debugging output. IF(LDEBUG)THEN * Header. WRITE(LUNOUT,'(/2X,''OVERVIEW OF THE DO LOOP NEST''// - 2X,''Number of input lines: '',I3/ - 2X,''Deepest nesting level: '',I3,'' / '',I3//, - 2X,''Line Type Loop Cond Jump'', - '' If Glb Entr Contents'')') - NDOLIN,MAXDOL,MAXIFL * Listing. BLANK=' ' CIFLVL=0 CDOLVL=0 DO 200 I=1,NDOLIN CALL STRBUF('READ',LINREF(I,2),STRING,NC,IFAIL) IF(LINREF(I,1).EQ.4)CDOLVL=CDOLVL-1 IF(LINREF(I,1).EQ.12.OR.LINREF(I,1).EQ.13.OR. - LINREF(I,1).EQ.14)CIFLVL=CIFLVL-1 IF(LINREF(I,1).EQ.0)THEN TYPE=' ' ELSEIF(LINREF(I,1).EQ.1)THEN TYPE='Do-block' ELSEIF(LINREF(I,1).EQ.2)THEN TYPE='Iterate ' ELSEIF(LINREF(I,1).EQ.3)THEN TYPE='Leave ' ELSEIF(LINREF(I,1).EQ.4)THEN TYPE='Enddo ' ELSEIF(LINREF(I,1).EQ.11)THEN TYPE='If-block' ELSEIF(LINREF(I,1).EQ.12)THEN TYPE='Elseif ' ELSEIF(LINREF(I,1).EQ.13)THEN TYPE='Else ' ELSEIF(LINREF(I,1).EQ.14)THEN TYPE='Endif ' ELSEIF(LINREF(I,1).EQ.21)THEN TYPE='Global ' ELSEIF(LINREF(I,1).EQ.22)THEN TYPE='Call ' ELSE TYPE='Unknown ' ENDIF IF(IFAIL.EQ.0)THEN WRITE(LUNOUT,'(1X,I5,1X,A8,6I5,5X,A)') - I,TYPE,(LINREF(I,J),J=3,8), - BLANK(1:MIN(80,MAX(1,1+3*(CDOLVL+CIFLVL))))// - STRING(1:NC) ELSE WRITE(LUNOUT,'(1X,I5,1X,A8,6I5,5X, - ''# Unable to retrieve'')') - I,TYPE,(LINREF(I,J),J=3,8) ENDIF IF(LINREF(I,1).EQ.1)CDOLVL=CDOLVL+1 IF(LINREF(I,1).EQ.11.OR.LINREF(I,1).EQ.12.OR. - LINREF(I,1).EQ.13)CIFLVL=CIFLVL+1 200 CONTINUE * DO loops. IF(NLOOP.GE.1)THEN WRITE(LUNOUT,'(/2X,''DO LOOP INDEX''//2X, - '' No Variable Init Step While Until To'', - '' First Last Level If In''/)') DO 210 I=1,NLOOP IF(DOREF(I,9).GT.0)THEN WRITE(LUNOUT,'(2X,I3,1X,A10,10I6)') I, - GLBVAR(DOREF(I,9)),(DOREF(I,J),J=1,8), - DOREF(I,10),DOREF(I,11) ELSE WRITE(LUNOUT,'(2X,I3,1X,A10,12X,2I6,6X,4I6)') I, - ' < none > ',(DOREF(I,J),J=3,4), - (DOREF(I,J),J=6,8),DOREF(I,10) ENDIF 210 CONTINUE ELSE WRITE(LUNOUT,'(/2X,''NO DO LOOPS''/)') ENDIF * IF blocks. IF(NIF.GE.1)THEN WRITE(LUNOUT,'(/2X,''IF BLOCK INDEX''//2X, - '' No State Last Do lvl If lvl'' - /)') DO 220 I=1,NIF WRITE(LUNOUT,'(2X,I3,5I10)') I,IFREF(I,1),IFREF(I,2), - IFREF(I,4),IFREF(I,5) 220 CONTINUE ELSE WRITE(LUNOUT,'(/2X,''NO IF BLOCKS''/)') ENDIF ENDIF *** Normal end of the routine. IF(OK)THEN IFAIL=0 ISTATE=0 ELSE PRINT *,' !!!!!! INPRDO WARNING : The DO loop nest is not'// - ' executable as a result of the above errors.' IFAIL=1 ISTATE=-1 CALL INPCDO ENDIF * Reset the prompt. CALL INPPRM(' ','BACK') END +DECK,INPRDR. SUBROUTINE INPRDR(IWRD,VAL,DEF) *----------------------------------------------------------------------- * INPRDR - Reads word IWRD into VAL, using the default DEF if the * word is empty and if it contains a *. * (Last changed on 1/ 7/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,INPUT. CHARACTER*25 AUX INTEGER IWRD REAL VAL,DEF *** Out of range ? IF(IWRD.LE.0.OR.IWRD.GT.NWORD.OR. - WORD(IWRD).EQ.' '.OR.WORD(IWRD).EQ.'*')THEN VAL=DEF RETURN ENDIF *** Read the value. AUX=WORD(IWRD)(1:NCHAR(IWRD)) READ(AUX,'(BN,F25.13)') VAL END +DECK,INPRIC. SUBROUTINE INPRIC(INSTR,IVAL,IDEF,IFAIL) *----------------------------------------------------------------------- * INPRIC - Checks that INSTR contains one integer, reads it into IVAL * taking IDEF instead if necessary and returns IFAIL=1 * if serious errors were detected by INPCHK. *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,INPUT. CHARACTER*(*) INSTR CHARACTER*(MXWORD) WRDRES CHARACTER*30 ECDRES LOGICAL ERRRES INTEGER IVAL,IDEF,IFAIL *** First store all data on word 1 and remember the number of words. WRDRES=WORD(1) ECDRES=ERRCDE(1) ERRRES=ERRPRT(1) NCHRES=NCHAR(1) NWRRES=NWORD *** Store the word to be checked in word 1 and check it. NWORD=1 WORD(1)=INSTR CALL INPCHK(1,1,IFAIL) CALL INPRDI(1,IVAL,IDEF) *** Print the error message, if any. IF(ERRPRT(1))THEN PRINT *,' !!!!!! INPRIC WARNING : ',INSTR, - ' was changed into '//WORD(1)(1:NCHAR(1)) PRINT *,' Reason: '//ERRCDE(1) PRINT *,' Value assigned : ',IVAL ENDIF *** Restore the old word 1 in its place. WORD(1) =WRDRES ERRCDE(1)=ECDRES ERRPRT(1)=ERRRES NCHAR(1) =NCHRES NWORD =NWRRES END +DECK,INPRRC. SUBROUTINE INPRRC(INSTR,VAL,DEF,IFAIL) *----------------------------------------------------------------------- * INPRRC - Checks that INSTR contains one real, reads it into VAL * taking DEF instead if necessary and returns IFAIL=1 * if serious errors were detected by INPCHK. * (Last changed on 23/ 8/95.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,INPUT. CHARACTER*(*) INSTR CHARACTER*(MXWORD) WRDRES CHARACTER*30 ECDRES LOGICAL ERRRES REAL VAL,DEF INTEGER IFAIL,NCHRES,NWRRES *** First store all data on word 1 and remember the number of words. WRDRES=WORD(1) ECDRES=ERRCDE(1) ERRRES=ERRPRT(1) NCHRES=NCHAR(1) NWRRES=NWORD *** Store the word to be checked in word 1. NWORD=1 WORD(1)=INSTR ERRPRT(1)=.FALSE. ERRCDE(1)=' ' NCHAR(1)=LEN(INSTR) *** Check the word and read it. CALL INPCHK(1,2,IFAIL) CALL INPRDR(1,VAL,DEF) *** Print the error message, if any. IF(ERRPRT(1))THEN PRINT *,' !!!!!! INPRRC WARNING : ',INSTR, - ' was changed into '//WORD(1)(1:NCHAR(1)) PRINT *,' Reason: '//ERRCDE(1) PRINT *,' Value assigned : ',VAL ENDIF *** Restore the old word 1 in its place. WORD(1) =WRDRES ERRCDE(1)=ECDRES ERRPRT(1)=ERRRES NCHAR(1) =NCHRES NWORD =NWRRES END +DECK,INPSTR. SUBROUTINE INPSTR(IWRD1,IWRD2,OUT,NC) *----------------------------------------------------------------------- * INPSTR - Returns in OUT the words IWRD1 through IWRD2 + total length * (Last changed on 9/10/07.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,INPUT. +SEQ,PRINTPLOT. CHARACTER*(*) OUT INTEGER IWRD1,IWRD2,NC,I1,I2,LENOUT *** Store length of output string. LENOUT=LEN(OUT) OUT=' ' NC=0 *** Return with an empty string if the arguments are clearly wrong. IF(IWRD1.GT.NWORD.OR.IWRD1.GT.MXWORD.OR.IWRD2.LT.1.OR. - IWRD1.GT.IWRD2)RETURN *** Find index of first word to be returned. IF(IWRD1.LT.1)THEN I1=INDWRD(1) ELSE I1=INDWRD(IWRD1) ENDIF *** Find index of last word to be returned. IF(IWRD2.LE.NWORD.AND.IWRD2.LE.MXWORD)THEN I2=INDWRD(IWRD2)+NCHAR(IWRD2)-1 ELSE I2=INDWRD(NWORD)+NCHAR(NWORD)-1 ENDIF *** Debugging. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ INPSTR DEBUG : I1='',I5, - '', I2='',I5,'', LEN(OUT)='',I5)') I1,I2,LENOUT *** Check the setting of I1, I2. IF(I1.LT.1.OR.I2.LT.1.OR.I2-I1+1.GT.LENOUT)THEN PRINT *,' !!!!!! INPSTR WARNING : String is longer'// - ' than calling routine thought; truncated.' IF(I1.LT.1)I1=1 IF(I2-I1+1.GT.LENOUT)I2=I1+LENOUT-1 IF(I2.LT.1)I2=1 ENDIF *** Set the output string and the number of characters. IF(I2.LT.I1)THEN NC=0 OUT(1:1)=' ' ELSE NC=MIN(I2-I1+1,LENOUT) OUT(1:NC)=STRING(I1:I2) ENDIF END +DECK,INPSUB. SUBROUTINE INPSUB(STR,NC,IFAIL) *----------------------------------------------------------------------- * INPSUB - Evaluates global variables and substitutes them. * (Last changed on 15/ 2/11.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,INPUT. +SEQ,GLOBALS. +SEQ,PRINTPLOT. CHARACTER*(*) STR CHARACTER*(MXINCH) OUT,AUX LOGICAL USE(MXVAR) REAL RES(100) INTEGER MODRES(100),I,J,K,NCOUT,NC,IFAIL,INEXT,IENTRY,NRES,NCRES *** Identify the routine if requested. IF(LIDENT)PRINT *,' /// ROUTINE INPSUB ///' *** Initial values. INEXT=1 NCOUT=0 OUT=' ' IFAIL=0 *** Scan the string. DO 10 I=1,NC IF(I.LT.INEXT.OR.STR(I:I).NE.'{'.OR. - (I.GT.1.AND.STR(MAX(1,I-1):I).EQ.ESCAPE//'{'))GOTO 10 *** Copy the string up to the bracket. IF(I-1.GE.INEXT)THEN IF(NCOUT+I-INEXT.GT.LEN(STR).OR. - NCOUT+I-INEXT.GT.LEN(OUT))GOTO 3000 OUT(NCOUT+1:NCOUT+I-INEXT)=STR(INEXT:I-1) NCOUT=NCOUT+I-INEXT ENDIF *** Scan for the closing bracket. DO 20 J=I+1,NC * Make sure we don't see a new open before this one is closed. IF(STR(J:J).EQ.'{'.AND. - (J.GT.1.AND.STR(MAX(1,J-1):J).NE.ESCAPE//'{'))THEN PRINT *,' !!!!!! INPSUB WARNING : No nesting of'// - ' substitution brackets allowed; no substitution.' IFAIL=1 RETURN ENDIF * Skip until the closing bracket is seen. IF(STR(J:J).NE.'}'.OR. - (J.GT.1.AND.STR(MAX(1,J-1):J).EQ.ESCAPE//'}'))GOTO 20 INEXT=J+1 * String is empty. IF(J.LE.I+1)GOTO 10 * String is not empty, translate. CALL ALGPRE(STR(I+1:J-1),J-I-1,GLBVAR,NGLB,NRES,USE,IENTRY, - IFAIL) IF(IFAIL.NE.0.OR.NRES.GT.100)THEN PRINT *,' !!!!!! INPSUB WARNING : The string "', - STR(I+1:J-1),'" can not be translated'// - ' or produces too many results.' IF(NCOUT+1.GT.LEN(STR).OR.NCOUT+1.GT.LEN(OUT))GOTO 3000 OUT(NCOUT+1:NCOUT+1)='?' NCOUT=NCOUT+1 CALL ALGCLR(IENTRY) GOTO 10 ENDIF * Execute. CALL TIMEL(GLBVAL(1)) CALL AL2EXE(IENTRY,GLBVAL,GLBMOD,NGLB,RES,MODRES,NRES,IFAIL) CALL ALGERR IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! INPSUB WARNING : The expression "', - STR(I+1:J-1),'" is syntax-wise correct'// - ' but can not be evaluated.' CALL ALGCLR(IENTRY) DO 40 K=1,NRES CALL ALGREU(NINT(RES(K)),MODRES(K),1) 40 CONTINUE IF(NCOUT+1.GT.LEN(STR).OR.NCOUT+1.GT.LEN(OUT))GOTO 3000 OUT(NCOUT+1:NCOUT+1)='?' NCOUT=NCOUT+1 GOTO 10 ENDIF * Remove the entry point. CALL ALGCLR(IENTRY) * Format each of the resulting numbers. DO 30 K=1,NRES CALL OUTFMT(RES(K),MODRES(K),AUX,NCRES,'LEFT') CALL ALGREU(NINT(RES(K)),MODRES(K),1) IF(NCOUT+NCRES.GT.LEN(STR).OR. - NCOUT+NCRES.GT.LEN(OUT))GOTO 3000 OUT(NCOUT+1:NCOUT+NCRES)=AUX(1:NCRES) NCOUT=NCOUT+NCRES IF(K.NE.NRES.AND.NRES.GT.1)THEN IF(NCOUT+2.GT.LEN(STR).OR.NCOUT+2.GT.LEN(OUT))GOTO 3000 OUT(NCOUT+1:NCOUT+2)=', ' NCOUT=NCOUT+2 ENDIF 30 CONTINUE *** Next component. GOTO 10 20 CONTINUE *** Arrive here if the bracket is not closed. PRINT *,' !!!!!! INPSUB WARNING : Substitution bracket is not'// - ' closed ; no substitution.' IFAIL=1 RETURN 10 CONTINUE *** Copy the remainder. IF(NC.GE.INEXT)THEN IF(NCOUT+NC-INEXT+1.GT.LEN(STR).OR. - NCOUT+NC-INEXT+1.GT.LEN(OUT))GOTO 3000 OUT(NCOUT+1:NCOUT+NC-INEXT+1)=STR(INEXT:NC) NCOUT=NCOUT+NC-INEXT+1 ENDIF *** Debugging output. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ INPSUB DEBUG : In ="'',A, - ''"''/26X,''Out="'',A,''"'')') - STR(1:MIN(LEN(STR),MAX(1,NC))), - OUT(1:MIN(LEN(OUT),MAX(1,NCOUT))) *** Send the string back. NC=NCOUT STR=OUT(1:MAX(1,MIN(MXINCH,LEN(STR),LEN(OUT),NCOUT))) IFAIL=0 RETURN *** Error because the resulting string is too long. 3000 CONTINUE PRINT *,' !!!!!! INPSUB WARNING : Substitution results in a'// - ' string that is too long; no substitution.' IFAIL=1 END +DECK,INPSWI. SUBROUTINE INPSWI(STREAM) *----------------------------------------------------------------------- * INPSWI - Switches input stream. * (Last changed on 13/12/07.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,INPUT. +SEQ,GLOBALS. CHARACTER*(*) STREAM LOGICAL DOXRES,RES,LINRES INTEGER LUNRES +SELF,IF=SAVE. SAVE LUNRES,LINRES,DOXRES,RES +SELF. DATA LUNRES/5/, DOXRES/.FALSE./, RES/.FALSE./, LINRES/.FALSE./ *** Switch to terminal input. IF(STREAM.EQ.'TERMINAL')THEN LUNRES=LUN LUN=5 GLBVAL(6)=LUNSTR(LUN,1) DOXRES=DOEXEC DOEXEC=.FALSE. LINRES=LINREC LINREC=.FALSE. RES=.TRUE. *** Switch to data file on unit 12. ELSEIF(STREAM.EQ.'UNIT12')THEN LUNRES=LUN LUN=12 GLBVAL(6)=LUNSTR(LUN,1) DOXRES=DOEXEC DOEXEC=.FALSE. LINRES=LINREC LINREC=.FALSE. RES=.TRUE. *** Restore the previous state. ELSEIF(STREAM.EQ.'RESTORE'.OR.STREAM.EQ.'RESTORE-QUIET')THEN IF(RES)THEN LUN=LUNRES GLBVAL(6)=LUNSTR(LUN,1) DOEXEC=DOXRES LINREC=LINRES RES=.FALSE. ELSEIF(STREAM.EQ.'RESTORE')THEN PRINT *,' !!!!!! INPSWI WARNING : No state stored'// - ' to be restored (program bug - please report).' ENDIF *** Other parameters are not valid. ELSE PRINT *,' !!!!!! INPSWI WARNING : Invalid stream ',STREAM, - ' value received (program bug - please report).' ENDIF END +DECK,INPTMP. SUBROUTINE INPTMP(STRING,NCSTR,FORMAT,NCFMT,EXEC,IFAIL) *----------------------------------------------------------------------- * INPTMP - Studies the template and the input string to assign the * global variables for the Parse instruction. * (Last changed on 10/11/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,GLOBALS. +SEQ,PRINTPLOT. CHARACTER*(*) STRING,FORMAT CHARACTER*5 AUXSTR INTEGER MXELEM PARAMETER(MXELEM=100) REAL RES(1) INTEGER NCSTR,NCFMT,LIST(MXELEM,3),MODRES(1),IFAIL,NELEM,I0,I,I1, - ILAST,INEXT,IOK,J,JSTART,JEND,JNEXT,NRES,IFAIL1,IENTRY,K, - IGLB,IREF,IMODE LOGICAL USE(MXVAR),EXEC *** Identify the routine for tracing purposes. IF(LIDENT)PRINT *,' /// ROUTINE INPTMP ///' *** Initial debugging output. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ INPTMP DEBUG : String: "'', - A,''",''/26X,''Format: "'',A,''".'')') - STRING(1:NCSTR),FORMAT(1:NCFMT) *** Initialise. NELEM=0 IFAIL=0 *** Read the fragments of the format. INEXT=1 DO 10 I0=1,NCFMT ** Skip if we have read further already. IF(I0.LT.INEXT)GOTO 10 ** Skip blanks. IF(FORMAT(I0:I0).EQ.' ')THEN GOTO 10 ** Full stop. ELSEIF(FORMAT(I0:I0).EQ.'.')THEN NELEM=NELEM+1 IF(NELEM.GE.MXELEM)GOTO 3010 LIST(NELEM,1)=3 LIST(NELEM,2)=I0 LIST(NELEM,3)=I0 INEXT=I0+1 ** Start of a quoted portion. ELSEIF(FORMAT(I0:I0).EQ.''''.OR. - FORMAT(I0:I0).EQ.'"'.OR. - FORMAT(I0:I0).EQ.'`')THEN * Locate the end of the string. DO 20 I=I0+1,NCFMT IF(FORMAT(I:I).EQ.FORMAT(I0:I0))THEN I1=I INEXT=I1+1 GOTO 30 ENDIF 20 CONTINUE INEXT=NCFMT+1 I1=NCFMT+1 30 CONTINUE * Make sure that the quoted portion is not empty. IF(I0+1.GT.I1-1)GOTO 10 * Store the string. NELEM=NELEM+1 IF(NELEM.GE.MXELEM)GOTO 3010 LIST(NELEM,1)=2 LIST(NELEM,2)=I0+1 LIST(NELEM,3)=I1-1 ** Start of a variable name. ELSE DO 40 I1=I0+1,NCFMT IF(INDEX(' .''"`',FORMAT(I1:I1)).NE.0)THEN ILAST=I1-1 INEXT=I1 GOTO 50 ENDIF 40 CONTINUE ILAST=NCFMT INEXT=NCFMT+1 50 CONTINUE * Check validity of the name. IOK=1 * Check the name starts with a character. IF(INDEX('ABCDEFGHIJKLMNOPQRSTUVWXYZ', - FORMAT(I0:I0)).EQ.0)THEN PRINT *,' !!!!!! INPTMP WARNING : The variable name '// - '"',FORMAT(I0:ILAST),'" does not start with'// - ' an uppercase letter.' IFAIL=1 IOK=0 ENDIF * Check for illegal characters. DO 60 I=I0,ILAST IF(INDEX('+-*/&|<=#>^ ,.:;([{)]}''"`',FORMAT(I:I)).NE.0)THEN PRINT *,' !!!!!! INPTMP WARNING : The variable name '// - '"',FORMAT(I0:ILAST),'" contains the illegal'// - ' character "',FORMAT(I:I),'".' IFAIL=1 IOK=0 ENDIF 60 CONTINUE * Make sure the name is not empty. IF(FORMAT(I0:ILAST).EQ.' '.OR.ILAST.LT.I0)THEN PRINT *,' !!!!!! INPTMP WARNING : A variable name'// - ' is empty.' IFAIL=1 IOK=0 ENDIF * Warn if the name is longer than 10 characters. IF(ILAST-I0+1.GT.10)PRINT *,' !!!!!! INPTMP WARNING :'// - ' The variable name "',FORMAT(I0:ILAST),'" is'// - ' truncated to the first 10 characters.' * Store the string. IF(IOK.EQ.1)THEN NELEM=NELEM+1 IF(NELEM.GE.MXELEM)GOTO 3010 LIST(NELEM,1)=1 LIST(NELEM,2)=I0 LIST(NELEM,3)=ILAST ELSE PRINT *,' !!!!!! INPTMP WARNING : Variable "', - FORMAT(I0:ILAST),'" won''t be assigned a value.' NELEM=NELEM+1 IF(NELEM.GE.MXELEM)GOTO 3010 LIST(NELEM,1)=3 LIST(NELEM,2)=I0 LIST(NELEM,3)=ILAST ENDIF ENDIF ** Next character. 10 CONTINUE *** End of loop over the format. 100 CONTINUE *** Add an end-of-list marker just past the end of the list. LIST(MIN(NELEM+1,MXELEM),1)=4 LIST(MIN(NELEM+1,MXELEM),2)=1 LIST(MIN(NELEM+1,MXELEM),3)=NCFMT *** Print the structure of the string. IF(LDEBUG)THEN WRITE(LUNOUT,'('' ++++++ INPTMP DEBUG : Structure of'', - '' the format |'',A,''|: '')') FORMAT(1:NCFMT) DO 170 I=1,NELEM IF(LIST(I,1).EQ.1)THEN WRITE(LUNOUT,'(9X,''Variable: |'',A,''|'')') - FORMAT(LIST(I,2):LIST(I,3)) ELSEIF(LIST(I,1).EQ.2)THEN WRITE(LUNOUT,'(9X,''String: |'',A,''|'')') - FORMAT(LIST(I,2):LIST(I,3)) ELSEIF(LIST(I,1).EQ.3)THEN WRITE(LUNOUT,'(9X,''Ignore: |'',A,''|'')') - FORMAT(LIST(I,2):LIST(I,3)) ELSE WRITE(LUNOUT,'(9X,''# Unknown: |'',A,''| #'')') - FORMAT(LIST(I,2):LIST(I,3)) IFAIL=1 ENDIF 170 CONTINUE ENDIF *** Find the start of the input string. DO 210 J=1,NCSTR IF(STRING(J:J).NE.' ')THEN JNEXT=J GOTO 220 ENDIF 210 CONTINUE JNEXT=NCSTR+1 220 CONTINUE *** Loop over the elements to be assigned. DO 110 I=1,NELEM ** Make sure we're not yet past the end of the string. IF(JNEXT.GT.NCSTR)THEN DO 160 J=I,NELEM IF(LIST(J,1).EQ.1)THEN IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ INPTMP DEBUG :'', - '' Variable '',A,'' not assigned.'')') - FORMAT(LIST(J,2):LIST(J,3)) * Locate the global variable and clear it if it is in use. DO 230 K=1,NGLB IF(GLBVAR(K).EQ.FORMAT(LIST(J,2):LIST(J,3)))THEN IGLB=K CALL ALGREU(NINT(GLBVAL(IGLB)),GLBMOD(IGLB),0) GOTO 240 ENDIF 230 CONTINUE IF(NGLB.GE.MXVAR)THEN PRINT *,' !!!!!! INPTMP WARNING : No room for'// - ' a new global variable; definition of', - FORMAT(LIST(J,2):LIST(J,3)),' ignored.' IFAIL=1 GOTO 160 ENDIF NGLB=NGLB+1 IGLB=NGLB GLBVAR(NGLB)=FORMAT(LIST(J,2):LIST(J,3)) GLBMOD(NGLB)=0 * Ensure that this variable is not a system variable. 240 CONTINUE IF(IGLB.LE.7)THEN PRINT *,' !!!!!! INPTMP WARNING : Variable ', - FORMAT(LIST(J,2):LIST(J,3)),' may not be'// - ' modified by the user.' IFAIL=1 GOTO 160 ENDIF * Assign to the global variable. GLBVAL(IGLB)=0 GLBMOD(IGLB)=0 ENDIF 160 CONTINUE GOTO 200 ENDIF ** Element is a variable name or a dot. IF(LIST(I,1).EQ.1.OR.LIST(I,1).EQ.3)THEN * Case 1: the variable is followed by a string. IF(LIST(I+1,1).EQ.2)THEN * Locate the string. JEND=INDEX(STRING(JNEXT:NCSTR), - FORMAT(LIST(I+1,2):LIST(I+1,3))) IF(JEND.EQ.0)THEN JEND=NCSTR ELSE JEND=JEND+JNEXT-2 ENDIF * Case 2: the variable is followed by another variable or a dot. ELSEIF(LIST(I+1,1).EQ.1.OR.LIST(I+1,1).EQ.3)THEN * Locate the blank separating the two variables. JEND=INDEX(STRING(JNEXT:NCSTR),' ') IF(JEND.EQ.0)THEN JEND=NCSTR ELSE JEND=JEND+JNEXT-2 ENDIF * Case 3: the variable is not followed by anything. ELSEIF(LIST(I+1,1).EQ.4)THEN * Take all that remains. JEND=NCSTR * Other cases: should not occur. ELSE PRINT *,' !!!!!! INPTMP WARNING : Unrecognised'// - ' format code received.' JEND=NCSTR IFAIL=1 ENDIF * Evaluate the expression. IF((LIST(I+1,1).GE.1.AND.LIST(I+1,1).LE.4).AND. - LIST(I,1).EQ.1)THEN * Start with debugging output. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ INPTMP DEBUG :'', - '' Evaluating '',A,'' for assignment to '',A, - ''.'')') STRING(JNEXT:JEND), - FORMAT(LIST(I,2):LIST(I,3)) ** In execution mode, evaluate the input expression. IF(EXEC)THEN * Translation step. CALL ALGPRE(STRING(JNEXT:JEND),JEND-JNEXT+1, - GLBVAR,NGLB,NRES,USE,IENTRY,IFAIL1) * Make sure that the formula was OK. IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! INPTMP WARNING :'// - ' Translating ',STRING(JNEXT:JEND), - ' failed; ',FORMAT(LIST(I,2):LIST(I,3)), - ' not assigned.' IFAIL=1 CALL ALGCLR(IENTRY) GOTO 300 * Verify that we get indeed only one result. ELSEIF(NRES.NE.1)THEN PRINT *,' !!!!!! INPTMP WARNING :'// - ' Translating ',STRING(JNEXT:JEND), - ' does not yield 1 result;', - FORMAT(LIST(I,2):LIST(I,3)), - ' not assigned.' CALL ALGCLR(IENTRY) IFAIL=1 GOTO 300 ENDIF * Set the execution time. CALL TIMEL(GLBVAL(1)) * Evaluate the formula. CALL ALGEXE(IENTRY,GLBVAL,GLBMOD,NGLB,RES, - MODRES,1,IFAIL1) * Check the return code of the evaluation. IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! INPTMP WARNING :'// - ' Evaluation of'// - ' expression ',STRING(JNEXT:JEND), - ' failed; ',FORMAT(LIST(I,2):LIST(I,3)), - ' not assigned.' CALL ALGCLR(IENTRY) IFAIL=1 GOTO 300 ENDIF * Print any evaluation errors. CALL ALGERR * Remove the entry point of the formula. CALL ALGCLR(IENTRY) ** In non-execution mode, store the result according to type. ELSE * Determine the type. CALL ALGTYP(STRING(JNEXT:JEND),IMODE) * Take care of Undefined. IF(IMODE.EQ.0)THEN RES(1)=0.0 * Take care of strings. ELSEIF(IMODE.EQ.1)THEN CALL STRBUF('STORE',IREF,STRING(JNEXT:JEND), - JEND-JNEXT+1,IFAIL1) RES(1)=REAL(IREF) IF(IFAIL1.NE.0)PRINT *,' !!!!!! INPTMP'// - ' WARNING : Unable to store the', - ' String ',STRING(JNEXT:JEND),'.' * Take care of numbers. ELSEIF(IMODE.EQ.2)THEN CALL INPRRC(STRING(JNEXT:JEND),RES(1),0.0, - IFAIL1) IF(IFAIL1.NE.0)PRINT *,' !!!!!! INPTMP'// - ' WARNING : ',STRING(JNEXT:JEND), - ' is not a valid Number.' * Take care of logicals. ELSEIF(IMODE.EQ.3)THEN AUXSTR=STRING(JNEXT:JEND) CALL CLTOU(AUXSTR) IF(AUXSTR.EQ.'TRUE ')THEN RES(1)=1.0 ELSEIF(AUXSTR.EQ.'FALSE')THEN RES(1)=0.0 ELSE IF(IFAIL1.NE.0)PRINT *,' !!!!!! INPTMP'// - ' WARNING : ',STRING(JNEXT:JEND), - ' is not a valid Logical.' RES(1)=-6 IMODE=0 ENDIF * All the rest, we assign as Undefined. ELSE RES(1)=-6 IMODE=0 IF(IFAIL1.NE.0)PRINT *,' !!!!!! INPTMP'// - ' WARNING : ',STRING(JNEXT:JEND), - ' is not of a type valid with Parse.' ENDIF MODRES(1)=IMODE ENDIF ** Locate the global variable and clear it if it is in use. DO 180 K=1,NGLB IF(GLBVAR(K).EQ.FORMAT(LIST(I,2):LIST(I,3)))THEN IGLB=K CALL ALGREU(NINT(GLBVAL(IGLB)),GLBMOD(IGLB),0) GOTO 190 ENDIF 180 CONTINUE IF(NGLB.GE.MXVAR)THEN PRINT *,' !!!!!! INPTMP WARNING : No room for'// - ' a new global variable; definition of', - FORMAT(LIST(I,2):LIST(I,3)),' ignored.' IFAIL=1 GOTO 300 ENDIF NGLB=NGLB+1 IGLB=NGLB GLBVAR(NGLB)=FORMAT(LIST(I,2):LIST(I,3)) GLBMOD(NGLB)=0 * Ensure that this variable is not a system variable. 190 CONTINUE IF(IGLB.LE.7)THEN PRINT *,' !!!!!! INPTMP WARNING : Variable ', - FORMAT(LIST(I,2):LIST(I,3)),' may not be'// - ' modified by the user.' IFAIL=1 GOTO 300 ENDIF * Assign to the global variable. GLBVAL(IGLB)=RES(1) GLBMOD(IGLB)=MODRES(1) ELSE IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ INPTMP DEBUG :'', - '' Ignoring '',A,''.'')') STRING(JNEXT:JEND) ENDIF * Update the pointer. 300 CONTINUE DO 140 J=JEND+1,NCSTR IF(STRING(J:J).NE.' ')THEN JNEXT=J GOTO 150 ENDIF 140 CONTINUE JNEXT=NCSTR+1 150 CONTINUE ** Element is a string. ELSEIF(LIST(I,1).EQ.2)THEN * Locate the string. JSTART=INDEX(STRING(JNEXT:NCSTR), - FORMAT(LIST(I,2):LIST(I,3))) IF(JSTART.EQ.0)THEN JSTART=NCSTR ELSE JSTART=JSTART+JNEXT-2 ENDIF * Update pointer. DO 120 J=JSTART+LIST(I,3)-LIST(I,2)+2,NCSTR IF(STRING(J:J).NE.' ')THEN JNEXT=J GOTO 130 ENDIF 120 CONTINUE JNEXT=NCSTR+1 130 CONTINUE ** Anything else is not valid. ELSE PRINT *,' !!!!!! INPTMP WARNING : Invalid format code'// - ' received.' IFAIL=1 ENDIF 110 CONTINUE *** End of the loop over the format elements. 200 CONTINUE *** Normally the end of the routine. RETURN *** Handle table overflow. 3010 CONTINUE * Print error message. PRINT *,' !!!!!! INPTMP WARNING : Too many elements in the'// - ' format; excess ignored.' * Remember that something went wrong. IFAIL=1 * Reduce element counter by 1. NELEM=MXELEM-1 * Place an end-of-list marker in element MXELEM LIST(MXELEM,1)=4 LIST(MXELEM,2)=1 LIST(MXELEM,3)=NCFMT * With this truncated list, identify the words. GOTO 100 END +DECK,INPTRA. SUBROUTINE INPTRA(STR,NC) *----------------------------------------------------------------------- * INPTRA - Translation of an input string. * INPTRG - Reads a translation table from a dataset. * INPTRR - Reads new translation entries. * INPTRW - Writes a table to a dataset. * (Last changed on 15/ 2/11.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,INPUT. +SEQ,PRINTPLOT. INTEGER TABLE(0:255),CHRIN,CHROUT,INPCMP,NCYCLE,ICYC,NCYCR, - NCFILE,NCMEMB,NCREM,IFAIL,IFAIL1,IKEY,IOS,INEXT,INIT,NMOD, - NCAUX,NC,I,J CHARACTER*(*) STR CHARACTER*(MXNAME) FILE CHARACTER*80 HEADER,AUX CHARACTER*29 REMARK CHARACTER*8 DATE,TIME,MEMBER CHARACTER*3 IN,OUT LOGICAL DSNCMP,EXIS,EXMEMB EXTERNAL INPCMP,DSNCMP +SELF,IF=SAVE. SAVE INIT,TABLE,NCYCLE +SELF. DATA NCYCLE /1/ *** Carry out a translation. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ INPTRA DEBUG : In ="'',A, - ''"'')') STR(1:MAX(1,MIN(NC,LEN(STR)))) DO 80 ICYC=1,NCYCLE DO 50 I=1,NC IF(I.GT.1.AND.STR(MAX(1,I-1):MAX(1,I-1)).EQ.ESCAPE)GOTO 50 STR(I:I)=CHAR(TABLE(ICHAR(STR(I:I)))) 50 CONTINUE 80 CONTINUE IF(LDEBUG)WRITE(LUNOUT,'(26X,''Out="'',A,''"'')') - STR(1:MIN(NC,100)) RETURN *** Read the translation table to a file. ENTRY INPTRG(IFAIL) * Initial values. FILE=' ' NCFILE=8 MEMBER='*' NCMEMB=1 IFAIL=1 IKEY=1 ** First decode the argument string: only one argument: file name. IF(NWORD.GE.IKEY+1) - CALL INPSTR(IKEY+1,IKEY+1,FILE,NCFILE) * If there's a second argument, it is the member name. IF(NWORD.GE.IKEY+2) - CALL INPSTR(IKEY+2,IKEY+2,MEMBER,NCMEMB) * Check the various lengths. IF(NCFILE.GT.MXNAME)THEN PRINT *,' !!!!!! INPTRG WARNING : The file name is'// - ' truncated to MXNAME (=',MXNAME,') characters.' NCFILE=MIN(NCFILE,MXNAME) ENDIF IF(NCMEMB.GT.8)THEN PRINT *,' !!!!!! INPTRG WARNING : The member name is'// - ' shortened to '//MEMBER//', first 8 characters.' NCMEMB=MIN(NCMEMB,8) ELSEIF(NCMEMB.LE.0)THEN PRINT *,' !!!!!! INPTRG WARNING : The member'// - ' name has zero length, replaced by "*".' MEMBER='*' NCMEMB=1 ENDIF * Reject the empty file name case. IF(FILE.EQ.' '.OR.NWORD.EQ.1)THEN PRINT *,' !!!!!! INPTRG WARNING : GET must be at least'// - ' followed by a dataset name ; no table is read.' RETURN ENDIF * If there are even more args, warn they are ignored. IF(NWORD.GT.IKEY+2)PRINT *,' !!!!!! INPTRG WARNING : GET takes'// - ' at most two arguments (dataset and member); rest ignored.' ** Open the dataset and inform DSNLOG. CALL DSNOPN(FILE,NCFILE,12,'READ-LIBRARY',IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! INPTRG WARNING : Opening ',FILE(1:NCFILE), - ' failed ; translation table not read.' RETURN ENDIF CALL DSNLOG(FILE,'Translate ','Sequential','Read only ') IF(LDEBUG)PRINT *,' ++++++ INPTRG DEBUG : Dataset', - FILE(1:NCFILE),' opened on unit 12 for seq read.' * Locate the pointer on the header of the requested member. CALL DSNLOC(MEMBER,NCMEMB,'TRANSLAT',12,EXIS,'RESPECT') IF(.NOT.EXIS)THEN CALL DSNLOC(MEMBER,NCMEMB,'TRANSLAT',12,EXIS,'IGNORE') IF(EXIS)THEN PRINT *,' ###### INPTRG ERROR : The translation'// - ' table '//MEMBER(1:NCMEMB)//' has been deleted'// - ' from '//FILE(1:NCFILE),'; not read.' ELSE PRINT *,' ###### INPTRG ERROR : Translation table'// - MEMBER(1:NCMEMB)//' not found on '// - FILE(1:NCFILE)//'.' ENDIF CLOSE(UNIT=12,IOSTAT=IOS,ERR=2030) RETURN ENDIF ** Check that the member is acceptable date wise. READ(12,'(A80)',END=2000,IOSTAT=IOS,ERR=2010) HEADER IF(LDEBUG)THEN PRINT *,' ++++++ INPTRG DEBUG : Dataset header'// - ' record follows:' PRINT *,HEADER ENDIF IF(DSNCMP('06-06-90',HEADER(11:18)))THEN PRINT *,' !!!!!! INPTRG WARNING : Member '//HEADER(32:39)// - ' can not be read because of a change in format.' CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) RETURN ENDIF WRITE(LUNOUT,'('' Member '',A8,'' was created on '',A8, - '' at '',A8/'' Remarks: '',A29)') - HEADER(32:39),HEADER(11:18),HEADER(23:30),HEADER(51:79) * Read the actual data. READ(12,'(8X,BN,I3)',END=2000,ERR=2010,IOSTAT=IOS) NCYCLE DO 60 I=1,8 READ(12,'(1X,32I4)',END=2000,ERR=2010,IOSTAT=IOS) - (TABLE(32*I+J-32),J=0,31) 60 CONTINUE ** Close the file after the operation. CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) CALL TIMLOG('Reading an input translation table: ') IFAIL=0 RETURN *** Initial table. ENTRY INPTRI DATA INIT/0/ IF(INIT.EQ.0)THEN * Original table is 1 to 1 on most machines. DO 10 I=0,255 TABLE(I)=I 10 CONTINUE +SELF,IF=UNIX,VAX,CYGWIN. * On Vax, tabs should become blanks. TABLE(9)=32 TABLE(13)=32 +SELF. * Number of cycles. NCYCLE=1 * Remember we set the table. INIT=1 ENDIF RETURN *** Change table entries. ENTRY INPTRR CALL INPNUM(NWORD) * Display current settings if arguments are absent. IF(NWORD.EQ.1)THEN WRITE(LUNOUT,'('' INPUT TRANSLATION TABLE:''/)') NMOD=0 DO 40 I=0,255 IF(TABLE(I).NE.I)THEN IN=' '//CHAR(I)//' ' OUT=' '//CHAR(TABLE(I))//' ' IF(INDEX('ABCDEFGHIJKLMNOPQRSTUVWXYZ'// - 'abcdefghijklmnopqrstuvwxyz'// - '0123456789~!@#$%^&*()_-+={[}]:;"''|\\,.?/><', - CHAR(I)).EQ.0)IN='---' IF(INDEX('ABCDEFGHIJKLMNOPQRSTUVWXYZ'// - 'abcdefghijklmnopqrstuvwxyz'// - '0123456789~!@#$%^&*()_-+={[}]:;"''|\\,.?/><', - CHAR(TABLE(I))).EQ.0)OUT='---' WRITE(LUNOUT,'(2X,I3,'' ('',A3,'') --> '',I3,'' ('',A3, - '')'')') I,IN,TABLE(I),OUT NMOD=NMOD+1 ENDIF 40 CONTINUE IF(NMOD.EQ.0) - WRITE(LUNOUT,'('' All characters unchanged.'')') WRITE(LUNOUT,'(/'' Number of cycles: '',I3,''.''/)') NCYCLE RETURN ENDIF * Loop over the input words. INEXT=1 DO 20 I=2,NWORD IF(I.LT.INEXT)GOTO 20 * Number of cycles. IF(INPCMP(I,'CYC#LES').NE.0)THEN IF(I+1.GT.NWORD)THEN CALL INPMSG(I,'Number of cycles is missing. ') GOTO 30 ENDIF CALL INPCHK(I+1,1,IFAIL1) CALL INPRDI(I+1,NCYCR,NCYCLE) IF(IFAIL1.EQ.0.AND.(NCYCR.LT.0.OR.NCYCR.GT.256))THEN CALL INPMSG(I+1,'Invalid number of cycles. ') ELSE NCYCLE=NCYCR ENDIF INEXT=I+2 GOTO 20 ENDIF * Pick up the character to be translated. CHRIN=-1 IF(INPCMP(I,'INT#EGER').NE.0)THEN IF(I+1.GT.NWORD)THEN CALL INPMSG(I,'Character code is missing. ') GOTO 30 ENDIF CALL INPCHK(I+1,1,IFAIL1) CALL INPRDI(I+1,CHRIN,-1) IF(IFAIL1.EQ.0.AND.(CHRIN.LT.0.OR.CHRIN.GT.255))THEN CALL INPMSG(I+1,'Character not within range. ') CHRIN=-1 ENDIF INEXT=I+2 ELSEIF(INPCMP(I,'HEX#ADECIMAL').NE.0)THEN IF(I+1.GT.NWORD)THEN CALL INPMSG(I,'Character code is missing. ') GOTO 30 ENDIF CALL INPCHK(I+1,3,IFAIL1) CALL INPRDH(I+1,CHRIN,-1) IF(IFAIL1.EQ.0.AND.(CHRIN.LT.0.OR.CHRIN.GT.255))THEN CALL INPMSG(I+1,'Character not within range. ') CHRIN=-1 ENDIF INEXT=I+2 ELSE CALL INPSTR(I,I,AUX,NCAUX) IF(NCAUX.GT.1)THEN CALL INPMSG(I,'Specify only one character. ') CHRIN=-1 ELSE CHRIN=ICHAR(AUX(1:1)) ENDIF INEXT=I+1 ENDIF * Ensure there is an output specification. IF(INEXT.GT.NWORD)THEN CALL INPMSG(I,'Output character is missing. ') GOTO 30 ENDIF * Pick up the output character. CHROUT=-1 IF(INPCMP(INEXT,'INT#EGER').NE.0)THEN IF(INEXT+1.GT.NWORD)THEN CALL INPMSG(INEXT,'Character code is missing. ') GOTO 30 ENDIF CALL INPCHK(INEXT+1,1,IFAIL1) CALL INPRDI(INEXT+1,CHROUT,-1) IF(IFAIL1.EQ.0.AND.(CHROUT.LT.0.OR.CHROUT.GT.255))THEN CALL INPMSG(INEXT+1,'Character not within range. ') CHROUT=-1 ENDIF INEXT=INEXT+2 ELSEIF(INPCMP(INEXT,'HEX#ADECIMAL').NE.0)THEN IF(INEXT+1.GT.NWORD)THEN CALL INPMSG(INEXT,'Character code is missing. ') GOTO 30 ENDIF CALL INPCHK(INEXT+1,3,IFAIL1) CALL INPRDH(INEXT+1,CHROUT,-1) IF(IFAIL1.EQ.0.AND.(CHROUT.LT.0.OR.CHROUT.GT.255))THEN CALL INPMSG(INEXT+1,'Character not within range. ') CHROUT=-1 ENDIF INEXT=INEXT+2 ELSE CALL INPSTR(INEXT,INEXT,AUX,NCAUX) IF(NCAUX.GT.1)THEN CALL INPMSG(INEXT,'Specify only one character. ') CHROUT=-1 ELSE CHROUT=ICHAR(AUX(1:1)) ENDIF INEXT=INEXT+1 ENDIF * Update the translation table. IF(CHRIN.GE.0.AND.CHROUT.GE.0.AND. - CHRIN.LE.255.AND.CHROUT.LE.255)TABLE(CHRIN)=CHROUT 20 CONTINUE 30 CONTINUE * Dump error messages. CALL INPERR RETURN *** Write the translation table to a file. ENTRY INPTRW(IFAIL) * Initial settings. FILE=' ' NCFILE=1 MEMBER='< none >' NCMEMB=8 REMARK='none' NCREM=4 IFAIL=1 IKEY=1 * First decode the argument string. CALL INPNUM(NWORD) * Make sure there is at least one argument. IF(NWORD.EQ.IKEY)THEN PRINT *,' !!!!!! INPTRW WARNING : WRITE takes at least one', - ' argument (a dataset name); data will not be written.' RETURN * Check whether keywords have been used. ELSEIF(INPCMP(IKEY+1,'D#ATASET')+ - INPCMP(IKEY+1,'R#EMARK').NE.0)THEN INEXT=IKEY+1 DO 410 I=IKEY+1,NWORD IF(I.LT.INEXT)GOTO 410 IF(INPCMP(I,'DATA#SET').NE.0)THEN IF(INPCMP(I+1,'REM#ARK').NE.0.OR.I+1.GT.NWORD)THEN CALL INPMSG(I,'The dataset name is missing. ') INEXT=I+1 ELSE CALL INPSTR(I+1,I+1,FILE,NCFILE) INEXT=I+2 IF(INPCMP(I+2,'R#EMARK').EQ.0.AND. - I+2.LE.NWORD)THEN CALL INPSTR(I+2,I+2,MEMBER,NCMEMB) INEXT=I+3 ENDIF ENDIF ELSEIF(INPCMP(I,'REM#ARK').NE.0)THEN IF(INPCMP(I+1,'D#ATASET').NE.0.OR.I+1.GT.NWORD)THEN CALL INPMSG(I,'The remark is missing. ') INEXT=I+1 ELSE CALL INPSTR(I+1,I+1,REMARK,NCREM) INEXT=I+2 ENDIF ELSE CALL INPMSG(I,'The parameter is not known. ') ENDIF 410 CONTINUE * Otherwise the string is interpreted as a file name (+ member name). ELSE CALL INPSTR(IKEY+1,IKEY+1,FILE,NCFILE) IF(NWORD.GE.IKEY+2) - CALL INPSTR(IKEY+2,IKEY+2,MEMBER,NCMEMB) IF(NWORD.GE.IKEY+3) - CALL INPSTR(IKEY+3,NWORD,REMARK,NCREM) ENDIF * Print error messages. CALL INPERR IF(NCFILE.GT.MXNAME)PRINT *,' !!!!!! INPTRW WARNING : The file', - ' name is truncated to MXNAME (=',MXNAME,') characters.' IF(NCMEMB.GT.8)PRINT *,' !!!!!! INPTRW WARNING : The member', - ' name is shortened to ',MEMBER,', first 8 characters.' IF(NCREM.GT.29)PRINT *,' !!!!!! INPTRW WARNING : The remark', - ' shortened to ',REMARK,', first 29 characters.' NCFILE=MIN(NCFILE,MXNAME) NCMEMB=MIN(NCMEMB,8) NCREM=MIN(NCREM,29) * Check whether the member already exists. CALL DSNREM(FILE(1:NCFILE),MEMBER(1:NCMEMB),'TRANSLAT',EXMEMB) IF(JEXMEM.EQ.2.AND.EXMEMB)THEN PRINT *,' ------ INPTRW MESSAGE : A copy of the member'// - ' exists; new member will be appended.' ELSEIF(JEXMEM.EQ.3.AND.EXMEMB)THEN PRINT *,' !!!!!! INPTRW WARNING : A copy of the member'// - ' exists already; member will not be written.' RETURN ENDIF * Print some debugging output if requested. IF(LDEBUG)THEN PRINT *,' ++++++ INPTRW DEBUG : File= '//FILE(1:NCFILE)// - ', member= '//MEMBER(1:NCMEMB) PRINT *,' Remark= '//REMARK(1:NCREM) ENDIF ** Open the dataset for sequential write and inform DSNLOG. CALL DSNOPN(FILE,NCFILE,12,'WRITE-LIBRARY',IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! INPTRW WARNING : Opening '//FILE(1:NCFILE), - ' failed ; the translation table is not written.' RETURN ENDIF CALL DSNLOG(FILE,'Translate ','Sequential','Write ') IF(LDEBUG)PRINT *,' ++++++ INPTRW DEBUG : Dataset ', - FILE(1:NCFILE),' opened on unit 12 for seq write.' * Now write a heading record to the file. CALL DATTIM(DATE,TIME) WRITE(HEADER,'(''% Created '',A8,'' At '',A8,1X,A8,'' TRANSLAT'', - 1X,''"'',A29,''"'')') DATE,TIME,MEMBER,REMARK WRITE(12,'(A80)',IOSTAT=IOS,ERR=2010) HEADER IF(LDEBUG)THEN PRINT *,' ++++++ INPTRW DEBUG : Dataset heading record:' PRINT *,HEADER ENDIF * Write the translation table. WRITE(12,'(''Cycles: '',I3)',ERR=2010,IOSTAT=IOS) NCYCLE DO 70 I=1,8 WRITE(12,'(1X,32I4)',ERR=2010,IOSTAT=IOS) - (TABLE(32*I+J-32),J=0,31) 70 CONTINUE * Close the file after the operation. CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) CALL TIMLOG('Writing out a translation table: ') IFAIL=0 RETURN *** I/O error handling. 2000 CONTINUE PRINT *,' ###### INPTRG ERROR : Premature EOF ecountered on '// - FILE(1:NCFILE)//' read via unit 12 ; no valid data read.' CALL INPIOS(IOS) CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) RETURN 2010 CONTINUE PRINT *,' ###### INPTRA ERROR : I/O error accessing '// - FILE(1:NCFILE)//' via unit 12 ; no data read or written.' CALL INPIOS(IOS) CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) RETURN 2030 CONTINUE PRINT *,' ###### INPTRA ERROR : Dataset '//FILE(1:NCFILE)// - ' unit 12 cannot be closed ; results not predictable' CALL INPIOS(IOS) END +DECK,INPTYP. INTEGER FUNCTION INPTYP(IW) *----------------------------------------------------------------------- * INPTYP - Determines the type of word IW, 0=character string, * 1=integer, 2=real, 3=hex, 4=asterisk, -1=invalid argument. * (Last changed on 25/ 3/06.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,INPUT. INTEGER IW,STRTYP EXTERNAL STRTYP *** First handle the case of incorrect arguments. IF(IW.LT.1.OR.IW.GT.NWORD)THEN INPTYP=-1 RETURN ENDIF *** Find type INPTYP=STRTYP(WORD(IW),NCHAR(IW)) END +DECK,INPWRD. SUBROUTINE INPWRD(NNWORD) *----------------------------------------------------------------------- * INPWRD - Asks INPGET to read a record, checks whether it contains * any special characters, takes appropriate action if * required and returns otherwise. * VARIABLES : NNWORD : =NWORD * (Last changed on 19/11/06.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,INPUT. +SEQ,PRINTPLOT. +SEQ,GLOBALS. CHARACTER*(MXINCH) FILE,LINE CHARACTER*(MXNAME) AUX CHARACTER*29 REMARK CHARACTER*8 DATE,TIME,MEMBER CHARACTER ESCAUX C LOGICAL EXMEMB,USE(MXVAR) INTEGER NCMEMB,NCREM,NCFILE,NC,IFILE,LUNTRY,IEOF,NCAUX,IFAIL, - IKEY,I,IOS,IDOLLR,NNWORD,INPCMP,IDUMMY,NCESC,NREXP C INTEGER IENTRY EXTERNAL INPCMP +SELF,IF=UNIX,CYGWIN. integer systemf,ierr external systemf +SELF,IF=VAX. INTEGER LIB$SPAWN,IERR EXTERNAL LIB$SPAWN +SELF,IF=CMS. INTEGER IRC +SELF,IF=APOLLO. character*256 args integer*2 iargs(128),connection(3) equivalence(args,iargs) integer pointer(2) %include '/sys/ins/base.ins.ftn' %include '/sys/ins/pgm.ins.ftn' +SELF. *** Identify the routine if requested. IF(LIDENT)PRINT *,' /// ROUTINE INPWRD ///' *** Return here if the command has been recognised as global. 1000 CONTINUE *** Next read a line from the input. CALL INPGET *** Pick up the first word to see whether there is an escape character. CALL INPSTR(1,1,LINE,NC) *** Open a unit if input is to continue from an external file. IF(NWORD.GE.1.AND.LINE(1:1).EQ.'<'.AND.NC.GE.1)THEN IF(LDEBUG)PRINT *,' ++++++ INPWRD DEBUG : Statement is'// - ' an alternate input request.' * Decode the file name. IF(NC.EQ.1.AND.NWORD.EQ.1)THEN PRINT *,' !!!!!! INPWRD WARNING : A file name must'// - ' be specified on a "<" line; no file opened.' GOTO 1000 ELSEIF(NC.EQ.1)THEN IFILE=2 CALL INPSTR(2,2,FILE,NCFILE) ELSE IFILE=1 FILE=LINE(2:) NCFILE=NC-1 ENDIF * Check whether there is perhaps also an EOF string. IF(IFILE.LT.NWORD)CALL INPSTR(IFILE+1,IFILE+1,LINE,NC) IF(LINE(1:2).EQ.'<<'.AND.NWORD.GT.IFILE.AND.NC.GE.2)THEN IF(NC.GT.2)THEN EOFSTR=LINE(3:) NCEOF=NC-2 IEOF=IFILE+1 ELSEIF(NWORD.GE.IFILE+2)THEN CALL INPSTR(IFILE+2,IFILE+2,EOFSTR,NCEOF) IEOF=IFILE+2 ELSE PRINT *,' INPWRD WARNING : The "<<" sign must'// - ' be followed by a label; no file opened.' GOTO 1000 ENDIF ELSE EOFSTR='EOF' NCEOF=3 IEOF=IFILE ENDIF * All remaining arguments should go to the arguments string. IF(NWORD.GT.IEOF)THEN CALL INPSTR(IEOF+1,NWORD,ARGSTR,NCARG) ELSE ARGSTR=' ' NCARG=1 ENDIF * Fetch old file name for printing error messages, CALL STRBUF('READ',LUNSTR(LUN,1),AUX,NCAUX,IFAIL) * Increment the LUN by one. IF(LUN.GE.20)LUNTRY=LUN+1 IF(LUN.EQ.5 )LUNTRY=20 IF(LUNTRY.GT.MXLUN)THEN PRINT *,' !!!!!! INPWRD WARNING : Maximum number of'// - ' open I/O units reached ; input resumed from'// - AUX(1:NCAUX)//'.' GOTO 1000 ENDIF * Open the file and register the opening with DSNLOG. CALL DSNOPN(FILE,NCFILE,LUNTRY,'READ-FILE',IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! INPWRD WARNING : Opening '// - FILE(1:NCFILE)//' failed; input resumed'// - ' from '//AUX(1:NCAUX)//'.' GOTO 1000 ENDIF CALL DSNLOG(FILE,'Input ','Sequential','Read only ') IF(LDEBUG)PRINT *,' ++++++ INPWRD DEBUG : '// - FILE(1:NCFILE)//' opened on unit ',LUNTRY * Store the logical unit. LUN=LUNTRY * Store file name, EOF label and arguments for reference purposes. CALL STRBUF('STORE',LUNSTR(LUN,1),FILE(1:NCFILE), - NCFILE,IFAIL) CALL STRBUF('STORE',LUNSTR(LUN,2),EOFSTR(1:NCEOF), - NCEOF,IFAIL) GLBVAL(6)=LUNSTR(LUN,1) CALL STRBUF('STORE',LUNSTR(LUN,3),ARGSTR(1:NCARG), - NCARG,IFAIL) *** Recording requests. ELSEIF(NWORD.GE.1.AND.LINE(1:2).EQ.'>>')THEN IF(LDEBUG)PRINT *,' ++++++ INPWRD DEBUG : Statement is'// - ' a recording request.' * First of all close the present recording file. IF(LINREC)CLOSE(UNIT=18,STATUS='KEEP', - IOSTAT=IOS,ERR=2030) * Next find the new file name. CALL INPSTR(1,1,LINE,NC) IF(NWORD.EQ.1.AND.NC.GT.2)THEN FILE=LINE(3:)//' ' IKEY=1 NCFILE=NC-2 ELSEIF(NWORD.EQ.1.AND.NC.EQ.2)THEN IF(.NOT.LINREC)PRINT *,' !!!!!! INPWRD WARNING :'// - ' Input recording was not active.' LINREC=.FALSE. GOTO 1000 ELSEIF(NWORD.GT.1.AND.NC.EQ.2)THEN CALL INPSTR(2,2,FILE,NCFILE) IKEY=2 ENDIF * Open a file on unit 18 for recording. CALL DSNOPN(FILE,NCFILE,18,'WRITE-FILE',IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! INPWRD WARNING : Recording on '// - FILE(1:NCFILE)//' cancelled because of an'// - ' error while opening the file.' LINREC=.FALSE. GOTO 1000 ENDIF CALL DSNLOG(FILE,'Recording ','Sequential','Write ') * And set the recording flag to active. LINREC=.TRUE. *** Redirect output if requested. ELSEIF(NWORD.GE.1.AND.LINE(1:1).EQ.'>')THEN IF(LDEBUG)PRINT *,' ++++++ INPWRD DEBUG : Statement is'// - ' an alternate output request.' * First of all close the present output file, if connected to unit 8. IF(LUNOUT.EQ.8)CLOSE(UNIT=8,STATUS='KEEP', - IOSTAT=IOS,ERR=2030) * Next find the new file name. CALL INPSTR(1,1,LINE,NC) IF(NWORD.EQ.1.AND.NC.GT.1)THEN FILE=LINE(2:)//' ' IKEY=1 NCFILE=NC-1 ELSEIF(NWORD.EQ.1.AND.NC.EQ.1)THEN IF(LUNOUT.EQ.6)PRINT *,' !!!!!! INPWRD WARNING : No'// - ' output rerouting was in effect.' CALL STRSAV('Standard output','OUTPUT',IFAIL) LUNOUT=6 GOTO 1000 ELSEIF(NWORD.GT.1.AND.NC.EQ.1)THEN CALL INPSTR(2,2,FILE,NCFILE) IKEY=2 ENDIF * And find the member name, if present. IF(NWORD.GE.IKEY+1)THEN CALL INPSTR(IKEY+1,IKEY+1,LINE,NCMEMB) MEMBER=LINE(1:8) ELSE MEMBER='< none >' NCMEMB=8 ENDIF * All that remains, is taken to be the remark. IF(NWORD.GE.IKEY+2)THEN CALL INPSTR(IKEY+2,NWORD,LINE,NCREM) REMARK=LINE(1:29) ELSE REMARK='Printed output' NCREM=14 ENDIF * Print warnings for too long member names and remarks. IF(NCMEMB.GT.8)THEN PRINT *,' !!!!!! INPWRD WARNING : The member name is'// - ' truncated to '//MEMBER//', first 8 characters.' NCMEMB=8 ENDIF IF(NCREM.GT.29)THEN PRINT *,' !!!!!! INPWRD WARNING : The remark is'// - ' truncated to "'//REMARK//'" (29 characters).' NCREM=29 ENDIF * Check whether the member already exists. C CALL DSNREM(FILE(1:NCFILE),MEMBER(1:NCMEMB),'OUTPUT',EXMEMB) C IF(JEXMEM.EQ.2.AND.EXMEMB)THEN C PRINT *,' ------ INPWRD MESSAGE : A copy of the'// C - ' member exists; output will be appended.' C ELSEIF(JEXMEM.EQ.3.AND.EXMEMB)THEN C PRINT *,' !!!!!! INPWRD WARNING : A copy of the'// C - ' member exists already; output not redirected.' C GOTO 1000 C ENDIF * Open a file on unit 8 for the output. CALL DSNOPN(FILE,NCFILE,8,'WRITE-LIBRARY',IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! INPWRD WARNING : The output can not'// - ' be rerouted to '//FILE(1:NCFILE)//' due to an'// - ' error while opening the file.' GOTO 1000 ENDIF CALL DSNLOG(FILE,'Output ','Sequential','Write ') * Now write a heading record to the file ... CALL DATTIM(DATE,TIME) WRITE(LINE,'(''% Created '',A8,'' At '',A8,1X,A8,1X, - ''OUTPUT '',1X,''"'',A29,''"'')') DATE,TIME,MEMBER, - REMARK WRITE(8,'(A80)',IOSTAT=IOS,ERR=2010) LINE * and set the new output logical file number. LUNOUT=8 * Set the name of the output stream. CALL STRSAV(FILE(1:NCFILE),'OUTPUT',IFAIL) *** Algebra debugging. ELSEIF(LINE(1:1).EQ.'@')THEN NREXP=0 CALL ALGINP C CALL ALGEDT(GLBVAR,NGLB,IENTRY,USE,NREXP) C CALL ALGCLR(IENTRY) *** String buffer dump. ELSEIF(INPCMP(1,'DUMP-ST#RING-#BUFFER').NE.0)THEN CALL STRBUF('DUMP',0,' ',1,IFAIL) *** Pass command to the environment if the line starts with a $. ELSEIF(NWORD.GE.1.AND.LINE(1:1).EQ.'$')THEN CALL INPSTR(1,NWORD,LINE,NC) IDOLLR=INDEX(LINE,'$') IF(IDOLLR.NE.0)LINE(IDOLLR:IDOLLR)=' ' +SELF,IF=APOLLO. * Set up the I/O stream connection - assuming SR10.x. connection(1)=ios_$stdin connection(2)=ios_$stdout connection(3)=ios_$stderr * Prepare the arguments. iargs(1)=2 args(3:5)='sh' pointer(1)=iaddr(args(1:1)) * If arguments are absent, put the user in an Aegis shell. if(nc.eq.1)then print *,' ------ INPWRD MESSAGE : You enter a'// - ' sub-shell, type RETURN to get back.' call pgm_$invoke('/com/sh',int2(7),int2(1), - pointer,int2(3),connection,pgm_$wait, - ihandle,istat) print *,' ------ INPWRD MESSAGE : You are back'// - ' inside Garfield.' * If arguments are present, execute the command in Aegis. else iargs(3)=min(250,nc) args(7:)=line(:iargs(3)) pointer(2)=iaddr(args(5:5)) call pgm_$invoke('/com/sh',int2(7),int2(2), - pointer,int2(3),connection,pgm_$wait, - ihandle,istat) endif * Check the shell return code. if(istat.ne.status_$ok)then print *,' !!!!!! INPWRD WARNING : The shell command'// - ' did not complete successfully; details follow.' call error_$print(istat) endif +SELF,IF=CDC. PRINT *,' !!!!!! INPWRD WARNING : Not yet available.' +SELF,IF=CMS. IF(NC.EQ.1.AND.NWORD.EQ.1)THEN PRINT *,' ------ INPWRD MESSAGE : You enter CMS'// - ' SUBSET mode, type RETURN to get back.' CALL VMCMS('SUBSET',IRC) PRINT *,' ------ INPWRD MESSAGE : You are back'// - ' inside Garfield.' ELSE CALL VMCMS(LINE,IRC) IF(IRC.EQ.0)THEN PRINT *,' Command successfully executed.' ELSEIF(IRC.EQ.-1)THEN PRINT *,' Your command is not known to CP.' ELSEIF(IRC.EQ.-2)THEN PRINT *,' Your command can not be run in SUBSET.' ELSEIF(IRC.EQ.-3)THEN PRINT *,' Your command is not known to CMS.' ELSEIF(IRC.EQ.4)THEN PRINT *,' Warning issued during execution.' ELSEIF(IRC.EQ.8)THEN PRINT *,' Error issued during execution.' ELSEIF(IRC.EQ.20)THEN PRINT *,' File identifier incorrectly spelled.' ELSEIF(IRC.EQ.24)THEN PRINT *,' Error in the command line.' ELSEIF(IRC.EQ.28)THEN PRINT *,' File not found, not accessible etc.' ELSEIF(IRC.EQ.36)THEN PRINT *,' Disk not correctly accessed.' ELSEIF(IRC.EQ.41)THEN PRINT *,' Not enough storage.' ELSEIF(IRC.EQ.801)THEN PRINT *,' EXEC file not found.' ELSE PRINT *,' CMS return code for the command: ',IRC ENDIF ENDIF +SELF,IF=MVS. PRINT *,' !!!!!! INPWRD WARNING : Routing of commands'// - ' to the internal reader is not yet available.' +SELF,IF=UNIX. *** Unix version courtesy Francois Marabelle. IF(NC.EQ.1.AND.NWORD.EQ.1)THEN PRINT *,' ------ INPWRD MESSAGE : You enter a'// - ' subprocess, type exit to get back.' IERR=SYSTEMF(SHELL(1:NCSH)) IF(IERR.NE.0)PRINT *,' !!!!!! INPWRD'// - ' WARNING : The subprocess did not complete'// - ' successfully.' PRINT *,' ------ INPWRD MESSAGE : You are back'// - ' inside Garfield.' ELSE IF(LDEBUG)PRINT *,' ++++++ INPWRD DEBUG : Spawn "'// - LINE(1:NC)//'".' IERR=SYSTEMF(SHELL(1:NCSH)//' -c "'//LINE(1:NC)//'"') IF(IERR.NE.0)PRINT *,' !!!!!! INPWRD'// - ' WARNING : The '//SHELL(1:NCSH)//' command did'// - ' not complete successfully.' ENDIF +SELF,IF=CYGWIN. *** Cygwin version. IF(NC.EQ.1.AND.NWORD.EQ.1)THEN PRINT *,' ------ INPWRD MESSAGE : You enter a'// - ' subprocess, type exit to get back.' IERR=SYSTEMF(SHELL(1:NCSH)) IF(IERR.NE.0)PRINT *,' !!!!!! INPWRD'// - ' WARNING : The subprocess did not complete'// - ' successfully.' PRINT *,' ------ INPWRD MESSAGE : You are back'// - ' inside Garfield.' ELSE IF(LDEBUG)PRINT *,' ++++++ INPWRD DEBUG : Spawn "'// - LINE(1:NC)//'".' IERR=SYSTEMF(SHELL(1:NCSH)//' /C "'//LINE(1:NC)//'"') IF(IERR.NE.0)PRINT *,' !!!!!! INPWRD'// - ' WARNING : The '//SHELL(1:NCSH)//' command did'// - ' not complete successfully.' ENDIF +SELF,IF=VAX. IF(NC.EQ.1.AND.NWORD.EQ.1)THEN PRINT *,' ------ INPWRD MESSAGE : You enter a'// - ' subprocess, type LOGOUT to get back.' IERR=LIB$SPAWN() IF(IERR.EQ.2*INT(IERR/2.0))PRINT *,' !!!!!! INPWRD'// - ' WARNING : The subprocess did not complete'// - ' successfully.' PRINT *,' ------ INPWRD MESSAGE : You are back'// - ' inside Garfield.' ELSE IF(LDEBUG)PRINT *,' ++++++ INPWRD DEBUG : Spawn "'// - LINE(1:NC)//'".' IERR=LIB$SPAWN(LINE(1:NC)) IF(IERR.EQ.2*INT(IERR/2.0))PRINT *,' !!!!!! INPWRD'// - ' WARNING : The DCL command did not complete'// - ' successfully.' ENDIF +SELF. *** Skip comment lines, starting with a '*'. ELSEIF(NWORD.GE.1.AND.LINE(1:1).EQ.'*')THEN GOTO 1000 *** Check for help lines, starting with ?. ELSEIF(NWORD.GE.1.AND.(LINE(1:1).EQ.'?'.OR.INPCMP(1,'HELP')+ - INPCMP(1,'INFO#RMATION').NE.0))THEN +SELF,IF=HELP. CALL HLPINP +SELF,IF=-HELP. PRINT *,' !!!!!! INPWRD WARNING : The help subsection'// - ' has not been compiled; no help available.' +SELF. *** Graphics options are lines starting with a !. ELSEIF(NWORD.GE.1.AND.LINE(1:1).EQ.'!')THEN CALL GRAINP *** Dataset commands are lines starting with a %. ELSEIF(NWORD.GE.1.AND.LINE(1:1).EQ.'%')THEN CALL DSNINP *** List current options. ELSEIF(INPCMP(1,'OPT#IONS').NE.0.AND.NWORD.EQ.1)THEN WRITE(LUNOUT,'( - '' GLOBAL OPTIONS CURRENTLY IN EFFECT:''// - '' Routine identifiers printed (IDENTIFICATION): '', - L1/ - '' Debugging output is generated (DEBUG): '', - L1/ - '' Echoing of the input lines (INPUT-LISTING): '', - L1/ - '' Record input from terminal (RECORDING): '', - L1/ - '' Inform about progress (PROGRESS-PRINT): '', - L1)') LIDENT,LDEBUG,LINPUT,LINREC,LPROPR IF(JFAIL.EQ.1)WRITE(LUNOUT,'( - '' Action to be taken in case of input errors: '', - ''carry on with defaults.'')') IF(JFAIL.EQ.2)WRITE(LUNOUT,'( - '' Action to be taken in case of input errors: '', - ''skip the instruction.'')') IF(JFAIL.EQ.3)WRITE(LUNOUT,'( - '' Action to be taken in case of input errors: '', - ''terminate execution.'')') IF(JEXMEM.EQ.1)WRITE(LUNOUT,'( - '' If a member to be written exists already: '', - ''mark existing member for deletion.'')') IF(JEXMEM.EQ.2)WRITE(LUNOUT,'( - '' If a member to be written exists already: '', - ''issue a warning, and append new member.'')') IF(JEXMEM.EQ.3)WRITE(LUNOUT,'( - '' If a member to be written exists already: '', - ''issue a warning, do not write new member.'')') IF(LGSTOP)THEN WRITE(LUNOUT,'( - '' In case of a graphics error: '', - '' dump data and quit.'')') ELSE WRITE(LUNOUT,'( - '' In case of a graphics error: '', - '' print a warning.'')') ENDIF NNWORD=1 RETURN * Update options. ELSEIF(INPCMP(1,'OPT#IONS').NE.0)THEN I=2 NNWORD=NWORD 10 CONTINUE * Trace routine calls or not. IF(INPCMP(I,'ID#ENTIFICATION').NE.0)THEN LIDENT=.TRUE. CALL INPDEL(I) GOTO 10 ELSEIF(INPCMP(I,'NOID#ENTIFICATION').NE.0)THEN LIDENT=.FALSE. CALL INPDEL(I) GOTO 10 * Debug output. ELSEIF(INPCMP(I,'DEB#UGGING').NE.0)THEN LDEBUG=.TRUE. CALL INPDEL(I) GOTO 10 ELSEIF(INPCMP(I,'NODEB#UGGING').NE.0)THEN LDEBUG=.FALSE. CALL INPDEL(I) GOTO 10 * Input echoing. ELSEIF(INPCMP(I,'IN#PUT-#LISTING').NE.0)THEN LINPUT=.TRUE. CALL INPDEL(I) GOTO 10 ELSEIF(INPCMP(I,'NOIN#PUT-#LISTING').NE.0)THEN LINPUT=.FALSE. CALL INPDEL(I) GOTO 10 * Synchronisation output. ELSEIF(INPCMP(I,'SYN#CHRONISE').NE.0)THEN LSYNCH=.TRUE. CALL INPDEL(I) GOTO 10 ELSEIF(INPCMP(I,'NOSYN#CHRONISE').NE.0)THEN LSYNCH=.FALSE. CALL INPDEL(I) GOTO 10 * Record terminal input. ELSEIF(INPCMP(I,'REC#ORDING').NE.0)THEN * First of all close the present recording file. IF(LINREC)CLOSE(UNIT=18,STATUS='KEEP', - IOSTAT=IOS,ERR=2030) * Next set the new file name. +SELF,IF=UNIX,CYGWIN. FILE='garflast.dat' NCFILE=12 +SELF,IF=CMS. FILE='GARFLAST.INPUT' NCFILE=14 +SELF,IF=-UNIX,IF=-CMS,IF=-CYGWIN. FILE='GARFLAST.DAT' NCFILE=12 +SELF. * Open a file on unit 18 for recording. CALL DSNOPN(FILE,NCFILE,18,'WRITE-FILE',IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! INPWRD WARNING : Recording on '// - FILE(1:NCFILE)//' cancelled because of an'// - ' error while opening the file.' LINREC=.FALSE. GOTO 10 ENDIF CALL DSNLOG(FILE,'Recording ','Sequential', - 'Write ') * And set the recording flag to active. LINREC=.TRUE. CALL INPDEL(I) GOTO 10 ELSEIF(INPCMP(I,'NOREC#ORDING').NE.0)THEN LINREC=.FALSE. CALL INPDEL(I) GOTO 10 * Keep informed about progress. ELSEIF(INPCMP(I,'PRO#GRESS-#PRINT').NE.0)THEN LPROPR=.TRUE. CALL INPDEL(I) GOTO 10 ELSEIF(INPCMP(I,'NOPRO#GRESS-#PRINT').NE.0)THEN LPROPR=.FALSE. CALL INPDEL(I) GOTO 10 * Handling of errors. ELSEIF(INPCMP(I,'ON-E#RROR-C#ONTINUE').NE.0)THEN JFAIL=1 CALL INPDEL(I) GOTO 10 ELSEIF(INPCMP(I,'ON-E#RROR-S#KIP').NE.0)THEN JFAIL=2 CALL INPDEL(I) GOTO 10 ELSEIF(INPCMP(I,'ON-E#RROR-T#ERMINATE').NE.0)THEN JFAIL=3 CALL INPDEL(I) GOTO 10 * Graphics error handling. ELSEIF(INPCMP(I,'DUMP-ON-GR#APHICS-#ERROR').NE.0)THEN LGSTOP=.TRUE. CALL INPDEL(I) GOTO 10 ELSEIF(INPCMP(I,'NODUMP-ON-GR#APHICS-#ERROR').NE.0)THEN LGSTOP=.FALSE. CALL INPDEL(I) GOTO 10 * Handling of existing members. ELSEIF(INPCMP(I,'DEL#ETE-OLD-MEM#BER').NE.0)THEN JEXMEM=1 CALL INPDEL(I) GOTO 10 ELSEIF(INPCMP(I,'WARN-BUT-WR#ITE')+ - INPCMP(I,'WR#ITE-BUT-WARN').NE.0)THEN JEXMEM=2 CALL INPDEL(I) GOTO 10 ELSEIF(INPCMP(I,'WARN-AND-NOWR#ITE')+ - INPCMP(I,'NOWR#ITE-AND-WARN').NE.0)THEN JEXMEM=3 CALL INPDEL(I) GOTO 10 ENDIF I=I+1 IF(I.LE.NWORD)GOTO 10 IF(NNWORD.GT.1.AND.NWORD.EQ.1)GOTO 1000 NNWORD=NWORD RETURN *** Escape character handling. ELSEIF(INPCMP(1,'ESC#APE').NE.0)THEN IF(NWORD.EQ.1)THEN WRITE(LUNOUT,'(/'' Current escape character is '', - A1,'' ('',I3,'').''/)') ESCAPE,ICHAR(ESCAPE) ELSE CALL INPSTR(2,2,ESCAUX,NCESC) IF(INDEX('''"` ,=',ESCAUX).NE.0)THEN PRINT *,' !!!!!! INPWRD WARNING : The escape'// - ' character can not be an accent or a'// - ' word separator ; not redefined.' ELSEIF(INDEX('!%&#<>$*?@',ESCAUX).NE.0)THEN PRINT *,' !!!!!! INPWRD WARNING : The escape'// - ' character can not be a (sub-)section'// - ' header ; not redefined.' ELSEIF(INDEX('{}[]()',ESCAUX).NE.0)THEN PRINT *,' !!!!!! INPWRD WARNING : The escape'// - ' character can not be a parenthesis ;'// - ' not redefined.' ELSEIF(NCESC.LE.0)THEN PRINT *,' !!!!!! INPWRD WARNING : The escape'// - ' character can not be a null string ;'// - ' not redefined.' ELSE IF(NCESC.GT.1)PRINT *,' ------ INPWRD MESSAGE :'// - ' Only first character of escape used.' ESCAPE=ESCAUX ENDIF ENDIF +SELF,IF=UNIX,CYGWIN. *** Shell. ELSEIF(INPCMP(1,'SH#ELL').NE.0)THEN IF(NWORD.EQ.1)THEN WRITE(LUNOUT,'(/'' Current shell is '', - A,''.''/)') SHELL(1:NCSH) ELSE CALL INPSTR(2,2,SHELL,NCSH) ENDIF +SELF. *** Input translation commands. ELSEIF(INPCMP(1,'TRAN#SLATE').NE.0)THEN CALL INPTRR ELSEIF(INPCMP(1,'GET-TRAN#SLATION-#TABLE').NE.0)THEN CALL INPTRG(IFAIL) ELSEIF(INPCMP(1,'WR#ITE-TRAN#SLATION-#TABLE').NE.0)THEN CALL INPTRW(IFAIL) *** CERN library error messages. ELSEIF(INPCMP(1,'ERR#OR-#HANDLING').NE.0)THEN CALL CRNERR *** Read some vectors. ELSEIF(INPCMP(1,'R#EAD-VEC#TORS')+ - INPCMP(1,'VEC#TORS-#READ').NE.0)THEN CALL MATVCR(IFAIL) *** Start of a DO loop. ELSEIF(INPCMP(1,'FOR')+INPCMP(1,'WHILE')+INPCMP(1,'UNTIL')+ - INPCMP(1,'DO')+INPCMP(1,'IF')+INPCMP(1,'STEP').NE.0.AND. - INPCMP(NWORD,'DO').NE.0)THEN DOREAD=.TRUE. CALL INPRDO(IFAIL) DOREAD=.FALSE. IF(IFAIL.EQ.0)THEN DOEXEC=.TRUE. ELSE PRINT *,' !!!!!! INPWRD WARNING : Reading the DO'// - ' loop failed; normal input resumed.' ENDIF *** Global variables. ELSEIF(INPCMP(1,'GL#OBALS').NE.0)THEN CALL INPGLB *** Read a line. ELSEIF(INPCMP(1,'PARSE').NE.0)THEN CALL INPPAR(IFAIL) *** Echo a line. ELSEIF(INPCMP(1,'SAY').NE.0)THEN CALL INPSTR(2,NWORD,LINE,NC) WRITE(LUNOUT,'(2X,A)') LINE(1:NC) *** Procedure calls. ELSEIF(INPCMP(1,'CALL').NE.0)THEN CALL INPCAL('EXECUTE',IDUMMY,IFAIL) *** Return because it's apparently not a special command. ELSE NNWORD=NWORD RETURN ENDIF GOTO 1000 *** Handle I/O problems. 2010 CONTINUE PRINT *,' !!!!!! INPWRD WARNING : Error writing the'// - ' heading record ; output not rerouted.' CALL INPIOS(IOS) CLOSE(UNIT=8,IOSTAT=IOS,ERR=2030) GOTO 1000 2030 CONTINUE PRINT *,' !!!!!! INPWRD WARNING : Closing the unit failed,'// - ' rerouting the output will no longer be possible.' CALL INPIOS(IOS) GOTO 1000 END +DECK,INPXDO. SUBROUTINE INPXDO(STRING,NC,IFLAG) *----------------------------------------------------------------------- * INPXDO - Executes a DO loop and returns commands. * (Last changed on 2/11/01.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,DOLOOP. +SEQ,GLOBALS. +SEQ,MATDATA. +SEQ,PRINTPLOT. CHARACTER*(*) STRING REAL RES(11) INTEGER NC,IFLAG,OLDLVL,MODRES(11),ILOOP,IFAIL1,IFAIL2,IFAIL3, - IFAIL4,IFAIL5,IFAIL11,IFAIL,IBLOCK,I,MATSLT,IREF LOGICAL IFCOND EXTERNAL MATSLT *** Be sure this routine is entered legally. IF(NDOLIN.LE.0.OR.NLOOP.LE.0.OR.ISTATE.LT.0)THEN PRINT *,' ###### INPXDO ERROR : No valid DO loop'// - ' stored; routine should not have been called.' IFLAG=-1 RETURN ENDIF *** Initial settings. IF(ISTATE.EQ.0)THEN CURLIN=0 CDOLVL=0 ISTATE=1 ENDIF *** Return at this point if a new line has to be read. 10 CONTINUE *** Increment line counter. CURLIN=CURLIN+1 * Check we're still in the loop. IF(CURLIN.GT.NDOLIN)THEN PRINT *,' ------ INPXDO MESSAGE : End of loop reached.' CALL ALGERR IFLAG=+2 IF(CDOLVL.NE.0)THEN PRINT *,' ###### INPXDO ERROR : The loop is left'// - ' at a non-zero level: ',CDOLVL,'.' PRINT *,' Program bug -'// - ' please report; all loops ended.' IFLAG=-1 ENDIF GOTO 3000 ENDIF * Evaluate the IF condition, if present. IF(LINREF(CURLIN,4).GT.0)THEN CALL TIMEL(GLBVAL(1)) CALL ALGEXE(LINREF(CURLIN,4),GLBVAL,GLBMOD,NGLB, - RES,MODRES,1,IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! INPXDO WARNING : Failure to'// - ' figure out the value of the IF condition.' IFCOND=.TRUE. ELSEIF(ABS(RES(1)).LT.1.0E-5)THEN IFCOND=.FALSE. ELSEIF(ABS(1.0-RES(1)).LT.1.0E-5)THEN IFCOND=.TRUE. ELSE PRINT *,' !!!!!! INPXDO WARNING : The IF'// - ' condition does not evaluate to a logical.' IFCOND=.TRUE. ENDIF ELSE IFCOND=.TRUE. ENDIF * Make sure the line number is not negative. IF(CURLIN.LE.0)THEN PRINT *,' ###### INPXDO ERROR : Negative line number'// - ' encountered: ',CURLIN,'.' PRINT *,' Program bug -'// - ' please report; all loops ended.' IFLAG=-1 GOTO 3000 ENDIF *** Ordinary line, return to have it executed. IF(LINREF(CURLIN,1).EQ.0.AND.IFCOND)THEN CALL STRBUF('READ',LINREF(CURLIN,2),STRING,NC,IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' ###### INPXDO ERROR : Error retrieving'// - ' a line of the DO loop nest; all loops ended.' IFLAG=-1 GOTO 3000 ENDIF IF(LINREF(CURLIN,4).EQ.0)THEN IFLAG=0 ELSE IFLAG=+1 ENDIF RETURN *** Ordinary line, not to be executed. ELSEIF(LINREF(CURLIN,1).EQ.0)THEN GOTO 10 *** Start of a DO loop. ELSEIF(LINREF(CURLIN,1).EQ.1)THEN * Pick up the index of this DO loop. ILOOP=LINREF(CURLIN,3) * Maybe the whole DO loop shouldn't be executed. IF(.NOT.IFCOND)THEN CURLIN=DOREF(ILOOP,7) GOTO 10 ENDIF * We will almost certainly need the time left. CALL TIMEL(GLBVAL(1)) ** In case of an In loop over a matrix, set initial value. IF(DOREF(ILOOP,9).GT.0.AND.DOREF(ILOOP,11).GT.0)THEN * Evaluate the matrix. CALL ALGEXE(DOREF(ILOOP,11),GLBVAL,GLBMOD,NGLB, - RES(11),MODRES(11),1,IFAIL11) IF(IFAIL11.NE.0)THEN PRINT *,' ###### INPXDO ERROR : Error'// - ' evaluating the In matrix;'// - ' all loops ended.' IFLAG=-1 GOTO 3000 ELSEIF(MODRES(11).NE.5)THEN PRINT *,' ###### INPXDO ERROR : In'// - ' does not evaluate to a matrix;'// - ' all loops ended.' IFLAG=-1 GOTO 3000 ENDIF * Store the initial matrix pointer. DOREF(ILOOP,12)=1 * Compute the matrix reference. IREF=MATSLT(NINT(RES(11))) * Ensure this value is within the matrix. IF(DOREF(ILOOP,12).GT.MLEN(IREF))THEN CURLIN=DOREF(ILOOP,7) GOTO 10 ENDIF * Store the initial value. GLBVAL(DOREF(ILOOP,9))=MVEC(MORG(IREF)+DOREF(ILOOP,12)) GLBMOD(DOREF(ILOOP,9))=2 ** In case of a From-Step-To loop with variable, handle initial value. ELSEIF(DOREF(ILOOP,9).GT.0)THEN * Evaluate initial value, step size and final value. CALL ALGEXE(DOREF(ILOOP,1),GLBVAL,GLBMOD,NGLB, - RES(1),MODRES(1),1,IFAIL1) CALL ALGEXE(DOREF(ILOOP,2),GLBVAL,GLBMOD,NGLB, - RES(2),MODRES(2),1,IFAIL2) CALL ALGEXE(DOREF(ILOOP,5),GLBVAL,GLBMOD,NGLB, - RES(5),MODRES(5),1,IFAIL5) IF(IFAIL1.NE.0.OR.IFAIL2.NE.0.OR.IFAIL5.NE.0)THEN PRINT *,' ###### INPXDO ERROR : Error'// - ' evaluating From, Step and To;'// - ' all loops ended.' IFLAG=-1 GOTO 3000 ELSEIF(MODRES(1).NE.2.OR.MODRES(2).NE.2.OR. - MODRES(5).NE.2)THEN PRINT *,' ###### INPXDO ERROR : From, Step'// - ' or To does not evaluate to a number;'// - ' all loops ended.' IFLAG=-1 GOTO 3000 ENDIF * Store initial value. GLBVAL(DOREF(ILOOP,9))=RES(1) GLBMOD(DOREF(ILOOP,9))=MODRES(1) * Check that we are between From and To. IF((GLBVAL(DOREF(ILOOP,9)).GT.RES(5).AND. - RES(2).GT.0.0).OR. - (GLBVAL(DOREF(ILOOP,9)).LT.RES(5).AND. - RES(2).LT.0.0))THEN CURLIN=DOREF(ILOOP,7) GOTO 10 ENDIF ENDIF ** Evaluate the WHILE condition. CALL ALGEXE(DOREF(ILOOP,3),GLBVAL,GLBMOD,NGLB, - RES(3),MODRES(3),1,IFAIL3) IF(IFAIL3.NE.0)THEN PRINT *,' ###### INPXDO ERROR : Error evaluating'// - ' While; all loops ended.' IFLAG=-1 GOTO 3000 ELSEIF(MODRES(3).NE.3)THEN PRINT *,' ###### INPXDO ERROR : While condition'// - ' does not evaluate to a logical; loops ended.' IFLAG=-1 GOTO 3000 ENDIF * Check WHILE is still satisfied. IF(ABS(RES(3)).LT.1.0E-3)THEN CURLIN=DOREF(ILOOP,7) GOTO 10 ENDIF * Increment the level counter and keep the trace. CDOLVL=CDOLVL+1 TRACDO(CDOLVL)=LINREF(CURLIN,3) * Read the first line of the loop. GOTO 10 *** LEAVE the loop altogether and condition satisfied. ELSEIF(LINREF(CURLIN,1).EQ.3.AND.IFCOND)THEN * Decrease the level counter. OLDLVL=CDOLVL DO 20 I=OLDLVL,1,-1 IF(TRACDO(I).NE.LINREF(CURLIN,3))THEN CDOLVL=CDOLVL-1 ELSE GOTO 30 ENDIF 20 CONTINUE PRINT *,' !!!!!! INPXDO WARNING : LEAVE fails, the'// - ' loop to be left is not in the stack.' IFLAG=-1 GOTO 3000 30 CONTINUE CDOLVL=CDOLVL-1 * Also set the new IF level. CIFLVL=DOREF(LINREF(CURLIN,3),10) * Next line to be read is just after the ENDDO. CURLIN=DOREF(LINREF(CURLIN,3),7) * Read that line. GOTO 10 *** LEAVE but IF condition not satisfied. ELSEIF(LINREF(CURLIN,1).EQ.3)THEN GOTO 10 *** Next iteration, either via an ITERATE or an ENDDO. ELSEIF((LINREF(CURLIN,1).EQ.2.AND.IFCOND).OR. - LINREF(CURLIN,1).EQ.4)THEN * Decrease the level counter in case of an ITERATE. IF(LINREF(CURLIN,1).EQ.2)THEN OLDLVL=CDOLVL DO 40 I=OLDLVL,1,-1 IF(TRACDO(I).NE.LINREF(CURLIN,3))THEN CDOLVL=CDOLVL-1 ELSE GOTO 50 ENDIF 40 CONTINUE PRINT *,' !!!!!! INPXDO WARNING : ITERATE fails,'// - ' loop to be returned to is not in the stack.' IFLAG=-1 GOTO 3000 50 CONTINUE ENDIF * Pick up the target loop index. ILOOP=LINREF(CURLIN,3) * Also set the new IF level. CIFLVL=DOREF(ILOOP,10) * We will almost certainly need the time left. CALL TIMEL(GLBVAL(1)) ** In-Loop with variable. IF(DOREF(ILOOP,9).GT.0.AND.DOREF(ILOOP,11).GT.0)THEN * Evaluate the matrix. CALL ALGEXE(DOREF(ILOOP,11),GLBVAL,GLBMOD,NGLB, - RES(11),MODRES(11),1,IFAIL11) IF(IFAIL11.NE.0)THEN PRINT *,' ###### INPXDO ERROR : Error'// - ' evaluating the In matrix;'// - ' all loops ended.' IFLAG=-1 GOTO 3000 ELSEIF(MODRES(11).NE.5)THEN PRINT *,' ###### INPXDO ERROR : In'// - ' does not evaluate to a matrix;'// - ' all loops ended.' IFLAG=-1 GOTO 3000 ENDIF * Increment the matrix pointer. DOREF(ILOOP,12)=DOREF(ILOOP,12)+1 * Compute the matrix reference. IREF=MATSLT(NINT(RES(11))) * Ensure this value is within the matrix. IF(DOREF(ILOOP,12).GT.MLEN(IREF))THEN CURLIN=DOREF(ILOOP,7) CDOLVL=CDOLVL-1 GOTO 10 ENDIF * Store the new value. GLBVAL(DOREF(ILOOP,9))=MVEC(MORG(IREF)+DOREF(ILOOP,12)) GLBMOD(DOREF(ILOOP,9))=2 * Loop with variable: handle the loop variable. ELSEIF(DOREF(ILOOP,9).GT.0)THEN * Additionally evaluate increment and final value. CALL ALGEXE(DOREF(ILOOP,2),GLBVAL,GLBMOD,NGLB, - RES(2),MODRES(2),1,IFAIL2) CALL ALGEXE(DOREF(ILOOP,5),GLBVAL,GLBMOD,NGLB, - RES(5),MODRES(5),1,IFAIL5) IF(IFAIL2.NE.0.OR.IFAIL5.NE.0)THEN PRINT *,' ###### INPXDO ERROR : Error'// - ' evaluating Step and To; all loops ended.' IFLAG=-1 GOTO 3000 ELSEIF(MODRES(2).NE.2.OR.MODRES(5).NE.2)THEN PRINT *,' ###### INPXDO ERROR : Step'// - ' or To does not evaluate to a number;'// - ' all loops ended.' IFLAG=-1 GOTO 3000 ENDIF * Increment the loop variable. GLBVAL(DOREF(ILOOP,9))=GLBVAL(DOREF(ILOOP,9))+RES(2) * Check the final value is not yet exceeded. IF((GLBVAL(DOREF(ILOOP,9)).GT.RES(5).AND. - RES(2).GT.0.0).OR. - (GLBVAL(DOREF(ILOOP,9)).LT.RES(5).AND. - RES(2).LT.0.0))THEN CURLIN=DOREF(ILOOP,7) CDOLVL=CDOLVL-1 GOTO 10 ENDIF ENDIF * Evaluate the WHILE and UNTIL portions, which are always needed. CALL ALGEXE(DOREF(ILOOP,3),GLBVAL,GLBMOD,NGLB, - RES(3),MODRES(3),1,IFAIL3) CALL ALGEXE(DOREF(ILOOP,4),GLBVAL,GLBMOD,NGLB, - RES(4),MODRES(4),1,IFAIL4) IF(IFAIL3.NE.0.OR.IFAIL4.NE.0)THEN PRINT *,' ###### INPXDO ERROR : Error evaluating'// - ' While and Until; all loops ended.' IFLAG=-1 GOTO 3000 ELSEIF(MODRES(3).NE.3.OR.MODRES(4).NE.3)THEN PRINT *,' ###### INPXDO ERROR : While or Until'// - ' does not evaluate to a logical; loops ended.' IFLAG=-1 GOTO 3000 ENDIF * Check the WHILE and UNTIL control expressions. IF(ABS(RES(3)).LT.1.0E-3.OR.ABS(RES(4)-1.0).LT.1.0E-3)THEN CURLIN=DOREF(ILOOP,7) CDOLVL=CDOLVL-1 GOTO 10 ENDIF * Return to the first line of the loop if all else fails. CURLIN=DOREF(ILOOP,6) GOTO 10 *** ITERATE but condition not satisfied. ELSEIF(LINREF(CURLIN,1).EQ.2.AND..NOT.IFCOND)THEN GOTO 10 *** Start of an IF block. ELSEIF(LINREF(CURLIN,1).EQ.11)THEN * Pick up the block number for easier reference. IBLOCK=LINREF(CURLIN,6) * Set the new line depending on the value of the IF condition. IF(IFCOND)THEN IFREF(IBLOCK,3)=1 ELSE IFREF(IBLOCK,3)=0 CURLIN=LINREF(CURLIN,5)-1 ENDIF * We always go up by one level in the IF tree. CIFLVL=CIFLVL+1 TRACIF(CIFLVL)=IBLOCK GOTO 10 *** An ELSEIF branch. ELSEIF(LINREF(CURLIN,1).EQ.12)THEN * Pick up the block number for easier reference. IBLOCK=LINREF(CURLIN,6) * Check whether we have already done one branch. IF(IFREF(IBLOCK,3).EQ.1)THEN CURLIN=IFREF(IBLOCK,2)-1 GOTO 10 ENDIF * Set the new line depending on the value of the IF condition. IF(IFCOND)THEN IFREF(IBLOCK,3)=1 ELSE IFREF(IBLOCK,3)=0 CURLIN=LINREF(CURLIN,5)-1 ENDIF GOTO 10 *** An ELSE branch. ELSEIF(LINREF(CURLIN,1).EQ.13)THEN * Pick up the block number for easier reference. IBLOCK=LINREF(CURLIN,6) * Check whether we have already done one branch. IF(IFREF(IBLOCK,3).EQ.1)THEN CURLIN=IFREF(IBLOCK,2)-1 GOTO 10 ENDIF * The next part should be executed anyhow. IFREF(IBLOCK,3)=1 GOTO 10 *** The ENDIF part of the IF block, just decrement. ELSEIF(LINREF(CURLIN,1).EQ.14)THEN CIFLVL=CIFLVL-1 GOTO 10 *** A GLOBAL variable is redefined. ELSEIF(LINREF(CURLIN,1).EQ.21)THEN * Check IF condition. IF(.NOT.IFCOND)GOTO 10 * If satisfied, evaluate the Global. CALL TIMEL(GLBVAL(1)) CALL ALGEXE(LINREF(CURLIN,8),GLBVAL,GLBMOD,NGLB, - RES,MODRES,1,IFAIL) IF(LINREF(CURLIN,7).LE.0)THEN IF(IFAIL.NE.0)PRINT *,' !!!!!! INPXDO WARNING :'// - ' Sub-matrix assignment in Global statement'// - ' has failed.' ELSEIF(IFAIL.NE.0)THEN PRINT *,' !!!!!! INPXDO WARNING : Error evaluating'// - ' a GLOBAL expression; set to Undefined.' CALL ALGREU(NINT(GLBVAL(LINREF(CURLIN,7))), - GLBMOD(LINREF(CURLIN,7)),0) GLBVAL(LINREF(CURLIN,7))=0 GLBMOD(LINREF(CURLIN,7))=0 ELSE CALL ALGREU(NINT(GLBVAL(LINREF(CURLIN,7))), - GLBMOD(LINREF(CURLIN,7)),0) GLBVAL(LINREF(CURLIN,7))=RES(1) GLBMOD(LINREF(CURLIN,7))=MODRES(1) ENDIF GOTO 10 *** A CALL statement. ELSEIF(LINREF(CURLIN,1).EQ.22)THEN * Check IF condition. IF(.NOT.IFCOND)GOTO 10 * If satisfied, execute the Call. CALL TIMEL(GLBVAL(1)) CALL ALGEXE(LINREF(CURLIN,8),GLBVAL,GLBMOD,NGLB, - RES,MODRES,1,IFAIL) IF(IFAIL.NE.0)PRINT *,' !!!!!! INPXDO WARNING : Error'// - ' executing a CALL statement.' GOTO 10 *** Unrecognised instruction. ELSE PRINT *,' !!!!!! INPXDO WARNING : Unrecognised line'// - ' type seen; loop is left.' IFLAG=-1 GOTO 3000 ENDIF *** End of loop cleanup. 3000 CONTINUE CALL INPCDO END +PATCH,DATASET. +DECK,DSNCMP. LOGICAL FUNCTION DSNCMP(DATE1,DATE2) *----------------------------------------------------------------------- * DSNCMP - Returns .TRUE. if the date DATE2 precedes DATE1. * (Last changed on 10/11/09.) *----------------------------------------------------------------------- implicit none CHARACTER*8 DATE1,DATE2 INTEGER IDAY1,IDAY2,IMON1,IMON2,IYEAR1,IYEAR2 *** Decode the date strings. READ(DATE1,'(BN,I2,1X,I2,1X,I2)') IDAY1,IMON1,IYEAR1 IF(IYEAR1.LT.84)THEN IYEAR1=IYEAR1+2000 ELSE IYEAR1=IYEAR1+1900 ENDIF READ(DATE2,'(BN,I2,1X,I2,1X,I2)') IDAY2,IMON2,IYEAR2 IF(IYEAR2.LT.84)THEN IYEAR2=IYEAR2+2000 ELSE IYEAR2=IYEAR2+1900 ENDIF *** Compare. DSNCMP=.TRUE. IF(IYEAR1.GT.IYEAR2)RETURN IF(IYEAR1.EQ.IYEAR2.AND.IMON1.GT.IMON2)RETURN IF(IYEAR1.EQ.IYEAR2.AND.IMON1.EQ.IMON2.AND.IDAY1.GT.IDAY2)RETURN DSNCMP=.FALSE. END +DECK,DSNFMTUX,IF=UNIX,CYGWIN. SUBROUTINE DSNFMT(F_IN,NC_IN,F_OUT,NC_OUT,ACCESS,IFAIL) *----------------------------------------------------------------------- * DSNFMT - Searches for the full file name specification, taking the * environment variables into account. * (Last changed on 7/12/95.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. CHARACTER*(MXNAME) F_OUT CHARACTER*80 AUX CHARACTER*(*) F_IN,ACCESS INTEGER INPCMP,NC_IN,NC_OUT,IFAIL,I,J,INEXT,IEND,ICASE EXTERNAL INPCMP *** Identify the routine if requested. IF(LIDENT)PRINT *,' /// ROUTINE DSNFMT (Unix+Cygwin) ///' IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DSNFMT DEBUG : Input'', - '' file name: '',A,'' (length='',I3,'').'')') - F_IN(1:MAX(1,NC_IN)),NC_IN *** Initialisation. F_OUT=' ' NC_OUT=0 IFAIL=0 *** Loop over the input string. INEXT=1 DO 10 I=1,NC_IN ** Skip parts already processed. IF(I.LT.INEXT)THEN GOTO 10 ** Skip blanks. ELSEIF(F_IN(I:I).EQ.' ')THEN GOTO 10 ** Look for back slashes (copy the next character literally). ELSEIF(F_IN(I:I).EQ.'\\')THEN IF(I+1.LT.NC_IN)THEN F_OUT(NC_OUT+1:NC_OUT+1)=F_IN(I+1:I+1) NC_OUT=NC_OUT+1 INEXT=I+2 ENDIF ** Look for an initial tilde. ELSEIF(F_IN(I:I).EQ.'~'.AND.NC_OUT.EQ.0)THEN * Get hold of the HOME environment variable. CALL GETENV('HOME',AUX) * Determine how the tilde should be interpreted. IF(I.GE.NC_IN)THEN ICASE=1 ELSEIF(F_IN(I+1:I+1).NE.'/')THEN ICASE=2 ELSE ICASE=1 ENDIF * Get rid of blanks and copy the relevant part. DO 20 J=LEN(AUX),1,-1 IF(AUX(J:J).NE.' ')THEN IF((ICASE.EQ.1.AND.NC_OUT+J.GT.LEN(F_OUT)).OR. - (ICASE.EQ.2.AND.NC_OUT+J+9.GT.LEN(F_OUT)))THEN PRINT *,' !!!!!! DSNFMT WARNING : Receiving'// - ' string to short for substitutions.' IFAIL=1 RETURN ELSEIF(ICASE.EQ.1)THEN F_OUT=AUX(1:J) NC_OUT=J GOTO 10 ELSE F_OUT=AUX(1:J)//'/../../'//F_IN(I+1:I+1)//'/' NC_OUT=J+9 GOTO 10 ENDIF ENDIF 20 CONTINUE * Warn if HOME is empty. PRINT *,' !!!!!! DSNFMT WARNING : The HOME environment'// - ' variable is blank or absent; tilde not substituted.' IFAIL=1 ** Look for dollars. ELSEIF(F_IN(I:I).EQ.'$')THEN * Search for the end of the environment variable. DO 30 J=I+1,NC_IN IF(INDEX('/$ ',F_IN(J:J)).NE.0)THEN IF(J.LE.I+1)THEN PRINT *,' !!!!!! DSNFMT WARNING : No name found'// - ' between $ and delimiter ; no substitution.' IFAIL=1 INEXT=J GOTO 10 ELSE IEND=J-1 INEXT=J GOTO 40 ENDIF ENDIF 30 CONTINUE * If no end found, take until end of string. IF(NC_IN.LT.I+1)THEN PRINT *,' !!!!!! DSNFMT WARNING : No name found'// - ' between $ and end-of-string ; no substitution.' IFAIL=1 INEXT=NC_IN+1 GOTO 10 ELSE IEND=NC_IN INEXT=NC_IN+1 ENDIF * Retrieve the environment variable. 40 CONTINUE CALL GETENV(F_IN(I+1:IEND),AUX) * Get rid of blanks and copy the relevant bit. DO 50 J=LEN(AUX),1,-1 IF(AUX(J:J).NE.' ')THEN IF(NC_OUT+J.GT.LEN(F_OUT))THEN PRINT *,' !!!!!! DSNFMT WARNING : Receiving'// - ' string too short for substitutions.' IFAIL=1 RETURN ELSE F_OUT(NC_OUT+1:NC_OUT+J)=AUX(1:J) NC_OUT=NC_OUT+J GOTO 10 ENDIF ENDIF 50 CONTINUE * Warn if the variable is empty or not known. PRINT *,' !!!!!! DSNFMT WARNING : The ', - F_IN(I+1:IEND),' environment variable is'// - ' blank or absent; not substituted.' IFAIL=1 ** Anything else should simply be copied. ELSE IF(NC_OUT+1.GT.LEN(F_OUT))THEN PRINT *,' !!!!!! DSNFMT WARNING : Receiving'// - ' string to short to receive file name.' IFAIL=1 RETURN ELSE F_OUT(NC_OUT+1:NC_OUT+1)=F_IN(I:I) NC_OUT=NC_OUT+1 INEXT=I+1 GOTO 10 ENDIF ENDIF ** Next character. 10 CONTINUE *** Debugging output. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DSNFMT DEBUG : Output'', - '' file name: '',A,'' (length='',I3,'').'')') - F_OUT(1:MAX(1,NC_OUT)),NC_OUT END +DECK,DSNFMTVX,IF=VAX. SUBROUTINE DSNFMT(F_IN,NC_IN,F_OUT,NC_OUT,ACCESS,IFAIL) *----------------------------------------------------------------------- * DSNFMT - Searches for the full file name specification, taking the * default string into account. Checks whether two files match * the same wildcard. *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. CHARACTER*(MXNAME) F_OUT,F_DEFAULT CHARACTER*(*) F_IN,ACCESS INTEGER INPCMP EXTERNAL INPCMP +SELF,IF=SAVE. SAVE F_DEFAULT,ITERMAX,NC_DEF +SELF. DATA F_DEFAULT /'.DAT'/, ITERMAX /500/, NC_DEF /4/ *** Identify the routine if requested. IF(LIDENT)PRINT *,' /// ROUTINE DSNFMT (Vax) ///' *** Preset the IFAIL flag to 0, i.e. OK. IFAIL=0 *** Make sure the response is always at least meaningful. F_OUT=F_IN NC_OUT=NC_IN *** Count how many files match. NFOUND=0 CONTEXT=0 10 CONTINUE * Check status code searching for the next. IST=LIB$FIND_FILE(F_IN(1:NC_IN),F_OUT,CONTEXT, - F_DEFAULT(1:NC_DEF),,,) * If odd, file found. IF(IST.NE.2*INT(REAL(IST)/2.0))THEN NFOUND=NFOUND+1 IF(NFOUND.GT.ITERMAX)THEN PRINT *,' !!!!!! DSNFMT WARNING : Number of'// - ' candidate files exceeds maximum; check'// - ' default file specification.' IFAIL=1 RETURN ELSE GOTO 10 ENDIF ENDIF * If even, last file seen: clear the buffer used to list the files. IST=LIB$FIND_FILE_END(CONTEXT) *** Check that there is precisely one file matching. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DSNFMT DEBUG : Number of'', - '' files matching the wildcard: '',I3,''.'')') NFOUND IF(NFOUND.LE.1)THEN IFAIL=0 DO 20 I=MXNAME,1,-1 IF(F_OUT(I:I).NE.' ')THEN NC_OUT=I GOTO 100 ENDIF 20 CONTINUE NC_OUT=1 ELSEIF(NFOUND.GT.1)THEN WRITE(*,'(1X,A,I3,A/26X,A,A)') ' !!!!!! DSNFMT WARNING : ', - NFOUND,' files match the specification ',F_IN(1:NC_IN), - ' ; The file is marked as non-existing.' IFAIL=1 F_OUT=' ' NC_OUT=1 ENDIF *** End of this part. 100 CONTINUE IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DSNFMT DEBUG : Expanded'', - '' file name = '',A,'', failure flag = '',I2,''.'')') - F_OUT(1:NC_OUT),IFAIL RETURN *** Update of the default file specification. ENTRY DSNFMD * Figure out where the key is located. CALL INPNUM(NWORD) IF(INPCMP(1,'%').NE.0)THEN IKEY=2 ELSE IKEY=1 ENDIF * See whether this is an inquiry or an update. IF(IKEY.EQ.NWORD)THEN WRITE(LUNOUT,'(/1X,A/)') ' The current default file'// - ' specification is "'//F_DEFAULT(1:NC_DEF)//'".' ELSE CALL INPSTR(IKEY+1,IKEY+1,F_DEFAULT,NC_DEF) IF(NC_DEF.LE.0)THEN PRINT *,' !!!!!! DSNFMD WARNING : Null string not'// - ' acceptable as default; set to .DAT' F_DEFAULT='.DAT' NC_DEF=4 ENDIF IF(LDEBUG)WRITE(LUNOUT,*) ' ++++++ DSNFMD DEBUG : New'// - ' default: '//F_DEFAULT(1:NC_DEF) ENDIF END +DECK,DSNINP. SUBROUTINE DSNINP *----------------------------------------------------------------------- * DSNINP - Handles dataset information requests like INDEX, LIST, * DELETE etc. * VARIABLES : STRING : Used for various character manipulations. * FILE, MEMBER: Obvious. * EXFILE, EXMEMB: Indicate whether file resp memb exist. * LOOP : .TRUE. if one should remain in here. * (Last changed on 5/ 6/08.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. CHARACTER*133 LINE CHARACTER*20 AUX1,AUX2 CHARACTER*(MXCHAR) STRING,FILE CHARACTER*8 MEMBER,DELETE,TYPE CHARACTER CHAR LOGICAL EXMEMB,LOOP,LIST,MATMEM,MATTYP INTEGER NWORD,NC,IFAIL,IKEY,NCFILE,NCMEMB,NCTYPE,NMEMB,NMALL, - NPURGE,I,IOS,NC1,NC2,INPCMP,STRLEN EXTERNAL INPCMP,STRLEN +SELF,IF=AST. EXTERNAL ASTCCH +SELF. *** Identify the subroutine if requested. IF(LIDENT)PRINT *,' /// ROUTINE DSNINP ///' *** First pick up the number of words and the first word. CALL INPNUM(NWORD) CALL INPSTR(1,1,STRING,NC) *** Check it is a dataset command. IF(STRING(1:1).NE.'%')RETURN *** Determine whether it is a single command or not. IF(NWORD.EQ.1.AND.NC.EQ.1)THEN LOOP=.TRUE. PRINT *,' ' PRINT *,' ------------------------------------------------' PRINT *,' ---------- Dataset subsection ----------' PRINT *,' ------------------------------------------------' PRINT *,' ' CALL INPPRM('Dataset','ADD-PRINT') ELSE LOOP=.FALSE. ENDIF *** Return here if LOOP is .TRUE. 1000 CONTINUE IF(LOOP)THEN CALL INPGET CALL INPNUM(NWORD) +SELF,IF=AST. *** Set up ASTCCH as the condition handler. CALL LIB$ESTABLISH(ASTCCH) +SELF. ENDIF CALL INPSTR(1,1,STRING,NC) *** Skip blank lines and warn for section headers. IF(STRING(1:1).EQ.'&')THEN PRINT *,' !!!!!! DSNINP WARNING : The section cannot be'// - ' left at this point; first type EXIT.' GOTO 1000 ELSEIF(INDEX('$!?><@',STRING(1:1)).NE.0)THEN PRINT *,' !!!!!! DSNINP WARNING : This command cannot be'// - ' executed at the present level; first type EXIT.' GOTO 1000 ELSEIF(STRING(1:1).EQ.'*')THEN GOTO 1000 ENDIF IF(LOOP.AND.(NWORD.EQ.0.OR.(NWORD.EQ.1.AND.NC.EQ.1.AND. - STRING(1:1).EQ.'%')))GOTO 1000 IF(.NOT.LOOP.AND.NC.EQ.1.AND.NWORD.EQ.1)RETURN +SELF,IF=CMS,VAX. ** Look for file DEFAULTs. IF(INPCMP(1,'%DEF#AULT')+INPCMP(2,'DEF#AULT').NE.0)THEN CALL DSNFMD GOTO 1020 ENDIF +SELF. *** Prepare a help file if the command is PACK-HELP-FILE. IF(INPCMP(1,'%PAC#K-H#ELP-#FILE')+INPCMP(2,'PAC#K-H#ELP-#FILE') - .NE.0)THEN +SELF,IF=APOLLO,CMS,UNIX,CYGWIN,IF=HELP. CALL HLPPAC(IFAIL) IF(IFAIL.NE.0)PRINT *,' !!!!!! DSNINP WARNING : Packed'// - ' help file not produced.' +SELF,IF=-HELP. PRINT *,' !!!!!! DSNINP WARNING : The help section has'// - ' not been compiled; command ignored.' +SELF. GOTO 1020 ENDIF *** Dump the help file if the command is DUMP-HELP-FILE. IF(INPCMP(1,'%DUMP-H#ELP-#FILE')+INPCMP(2,'DUMP-H#ELP-#FILE') - .NE.0)THEN +SELF,IF=APOLLO,CMS,UNIX,CYGWIN,IF=HELP. CALL HLPDEB +SELF,IF=VAX. PRINT *,' !!!!!! DSNINP WARNING : This command should'// - ' not be used on a Vax; command ignored.' +SELF,IF=-HELP. PRINT *,' !!!!!! DSNINP WARNING : The help section has'// - ' not been compiled; command ignored.' +SELF. GOTO 1020 ENDIF *** Set the position of the command. IF(NC.EQ.1.AND.STRING(1:1).EQ.'%')THEN IKEY=2 ELSE IKEY=1 ENDIF *** Find the dataset and the member name. FILE=' ' MEMBER=' ' * Start with the dataset name, check it has been specified. IF(INPCMP(IKEY,'EX#IT')+INPCMP(IKEY,'%EX#IT').NE.0)THEN PRINT *,' ' PRINT *,' ------------------------------------------------' PRINT *,' ---------- Dataset subsection end ----------' PRINT *,' ------------------------------------------------' PRINT *,' ' CALL INPPRM(' ','BACK-PRINT') RETURN ELSEIF(IKEY+1.LE.NWORD)THEN CALL INPSTR(IKEY+1,IKEY+1,STRING,NC) FILE=STRING NCFILE=NC ELSE PRINT *,' !!!!!! DSNINP WARNING : All dataset commands'// - ' have a dataset name as first argument; ignored.' GOTO 1020 ENDIF * Return immediately if the file does not exist or is corrupt. CALL DSNOPN(FILE,NCFILE,12,'RW-LIBRARY',IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! DSNINP WARNING : '//FILE(1:NCFILE)// - ' could not be opened; no action.' GOTO 1020 ENDIF * Next the member name, no checks except for length. IF(NWORD.GE.IKEY+2)THEN CALL INPSTR(IKEY+2,IKEY+2,STRING,NCMEMB) MEMBER=STRING IF(NCMEMB.GT.LEN(MEMBER))THEN PRINT *,' !!!!!! DSNINP WARNING : The member name '// - STRING(1:NCMEMB)//' is too long; truncated.' NCMEMB=LEN(MEMBER) ENDIF ELSE MEMBER='*' NCMEMB=1 ENDIF * Finally the TYPE argument. IF(NWORD.GE.IKEY+3)THEN CALL INPSTR(IKEY+3,IKEY+3,STRING,NCTYPE) TYPE=STRING(1:NCTYPE) ELSE TYPE='*' NCTYPE=1 ENDIF *** Identify the instruction, start with DELETE. IF(INPCMP(IKEY,'%DEL#ETE')+INPCMP(IKEY,'DEL#ETE')+ - INPCMP(IKEY,'%SCR#ATCH')+INPCMP(IKEY,'SCR#ATCH').NE.0)THEN IF(IKEY+2.GT.NWORD)THEN PRINT *,' !!!!!! DSNINP WARNING : A member must be'// - ' specified on a DELETE command.' GOTO 1010 ENDIF * Read through the dataset and mark, then copy to scratch. EXMEMB=.FALSE. +SELF,IF=CMS. CALL VMCMS('FILEDEF FT09F001 DISK GARFTEMP COPYFILE'// - ' (RECFM F LRECL 133',IRC) +SELF. OPEN(UNIT=9,STATUS='SCRATCH',IOSTAT=IOS,ERR=2025) READ(12,'(A133)',IOSTAT=IOS,ERR=2010,END=110) LINE 100 CONTINUE READ(12,'(A133)',IOSTAT=IOS,ERR=2010,END=110) LINE IF(LINE(1:1).EQ.'%')THEN CALL WLDCRD(LINE(32:39),MEMBER(1:NCMEMB),.FALSE., - MATMEM) CALL WLDCRD(LINE(41:48),TYPE(1:NCTYPE),.FALSE., - MATTYP) ELSE MATMEM=.FALSE. MATTYP=.FALSE. ENDIF IF(LINE(1:1).EQ.'%'.AND.LINE(2:2).NE.'X'.AND. - MATMEM.AND.MATTYP)THEN EXMEMB=.TRUE. LINE(2:2)='X' PRINT *,' Member '//MEMBER(1:NCMEMB)//' of type '// - LINE(41:48)//' marked for deletion.' ENDIF WRITE(9,'(A133)',IOSTAT=IOS,ERR=2015) LINE GOTO 100 110 CONTINUE * Print an error message if the member has not been found. IF(.NOT.EXMEMB)THEN PRINT *,' !!!!!! DSNINP WARNING : '//MEMBER(1:NCMEMB)// - ' does not exist or has already been deleted.' CALL DSNLOG(FILE,'% Search ','Sequential', - 'Read only ') ELSE * Close the file on unit 12, deleting it at the same time. CLOSE(UNIT=12,STATUS='DELETE',IOSTAT=IOS,ERR=2030) * Create a new file with the same name. CALL DSNOPN(FILE,NCFILE,12,'WRITE-LIBRARY',IFAIL) IF(IFAIL.EQ.1)THEN PRINT *,' ###### DSNINP ERROR : Unable to'// - ' create the file again ; dataset lost.' +SELF,IF=CMS. PRINT *,' The data may'// - ' still be stored in GARFTEMP COPYFILE A.' +SELF. CLOSE(UNIT=9,IOSTAT=IOS,ERR=2035) CALL DSNLOG(FILE,'% Delete ','Sequential', - 'Deleted !!') CALL DSNLOG('< intermediate file for copying >', - 'Dataset ','Sequential','Read/Write') GOTO 1020 ENDIF * And copy the whole file back to the original file. REWIND(UNIT=9,IOSTAT=IOS,ERR=2055) 120 CONTINUE READ(9,'(A133)',IOSTAT=IOS,ERR=2015,END=130) LINE WRITE(12,'(A)',IOSTAT=IOS,ERR=2010) - LINE(1:STRLEN(LINE)) GOTO 120 130 CONTINUE CALL DSNLOG(FILE,'% Delete ','Sequential', - 'Read/Write') ENDIF * Close the scratch file and log its use. CLOSE(UNIT=9,IOSTAT=IOS,ERR=2035) CALL DSNLOG('< intermediate file for copying >', - 'Dataset ','Sequential','Read/Write') ** Look for the keyword DIRECTORY. ELSEIF(INPCMP(IKEY,'%DIR#ECTORY')+INPCMP(IKEY,'DIR#ECTORY')+ - INPCMP(IKEY,'%IND#EX')+INPCMP(IKEY,'IND#EX').NE.0)THEN * Print a heading for the table. WRITE(LUNOUT,'(/'' Index for '',A,//,'' Member '', - ''Type Date Time Deleted Remarks''/)') - FILE(1:NCFILE) * Read it record by record, printing if it's a header. NMEMB=0 NMALL=0 10 CONTINUE READ(12,'(A1)',END=20,IOSTAT=IOS,ERR=2010) CHAR IF(CHAR.EQ.'%')THEN NMALL=NMALL+1 BACKSPACE(UNIT=12,IOSTAT=IOS,ERR=2040) READ(12,'(A80)',END=20,IOSTAT=IOS,ERR=2010) STRING CALL WLDCRD(STRING(32:39),MEMBER(1:NCMEMB),.FALSE., - MATMEM) CALL WLDCRD(STRING(41:48),TYPE(1:NCTYPE),.FALSE., - MATTYP) IF(.NOT.(MATMEM.AND.MATTYP))GOTO 10 NMEMB=NMEMB+1 IF(STRING(2:2).EQ.'X')THEN DELETE='Yes ' ELSE DELETE='No ' ENDIF WRITE(LUNOUT,'(1X,5(1X,A8),1X,A29)') STRING(32:39), - STRING(41:48),STRING(11:18),STRING(23:30),DELETE, - STRING(51:79) ENDIF GOTO 10 * Finished, close the unit, log access and print number of members. 20 CONTINUE CALL OUTFMT(REAL(NMALL),2,AUX1,NC1,'LEFT') CALL OUTFMT(REAL(NMEMB),2,AUX2,NC2,'LEFT') WRITE(LUNOUT,'(/'' Out of the '',A,'' members in the'', - '' file, '',A,'' match.'')') AUX1(1:NC1),AUX2(1:NC2) CALL DSNLOG(FILE,'% Index ','Sequential','Read only ') ** Look for the keyword LIST. ELSEIF(INPCMP(IKEY,'%L#IST')+INPCMP(IKEY,'L#IST')+ - INPCMP(IKEY,'%T#YPE')+INPCMP(IKEY,'T#YPE').NE.0)THEN * Read through the dataset, listing if LIST is on. EXMEMB=.FALSE. LIST=.FALSE. 200 CONTINUE READ(12,'(A133)',IOSTAT=IOS,ERR=2010,END=210) LINE IF(LIST)THEN IF(LINE(1:1).EQ.'%')GOTO 230 DO 220 I=133,1,-1 IF(LINE(I:I).NE.' ')THEN WRITE(LUNOUT,'(1X,A)') LINE(1:I) GOTO 230 ENDIF 220 CONTINUE WRITE(LUNOUT,'('' '')') 230 CONTINUE ENDIF * Switch LIST on and off depending on the header records. IF(LINE(1:1).EQ.'%')THEN CALL WLDCRD(LINE(32:39),MEMBER(1:NCMEMB),.FALSE., - MATMEM) CALL WLDCRD(LINE(41:48),TYPE(1:NCTYPE),.FALSE., - MATTYP) ELSE MATMEM=.FALSE. MATTYP=.FALSE. ENDIF IF(LINE(1:2).EQ.'% '.AND.MATMEM.AND.MATTYP)THEN EXMEMB=.TRUE. LIST=.TRUE. WRITE(LUNOUT,'('' Listing of member '',A8, - '' of type '',A8,'', created on '',A8, - '' at '',A8)') LINE(32:39),LINE(41:48), - LINE(11:18),LINE(23:30) IF(LINE(51:79).NE.' ')WRITE(LUNOUT,'('' Remarks: '', - A29)') LINE(51:79) WRITE(LUNOUT,'('' '')') ELSEIF(LINE(1:1).EQ.'%'.AND..NOT.MATMEM)THEN LIST=.FALSE. ENDIF GOTO 200 210 CONTINUE * Print an error message if the member has not been found. IF(.NOT.EXMEMB)THEN PRINT *,' !!!!!! DSNINP WARNING : '//MEMBER(1:NCMEMB)// - ' either does not exist or has been deleted.' CALL DSNLOG(FILE,'% Search ','Sequential', - 'Read only ') ELSE CALL DSNLOG(FILE,'% List ','Sequential', - 'Read only ') ENDIF ** Look for the keyword PURGE. ELSEIF(INPCMP(IKEY,'%PUR#GE')+INPCMP(IKEY,'PUR#GE')+INPCMP - (IKEY,'%COND#ENSE')+INPCMP(IKEY,'COND#ENSE').NE.0)THEN IF(NWORD.GT.IKEY+1)THEN PRINT *,' !!!!!! DSNINP WARNING : No member must be'// - ' specified on a PURGE command; do not mix up' PRINT *,' with DELETE, this'// - ' statement hurts ! (not executed).' GOTO 1010 ENDIF * Read through the dataset copying the non-marked members. +SELF,IF=CMS. CALL VMCMS('FILEDEF FT09F001 DISK GARFTEMP COPYFILE'// - ' (RECFM F LRECL 133',IRC) +SELF. OPEN(UNIT=9,STATUS='SCRATCH',IOSTAT=IOS,ERR=2025) LIST=.TRUE. NPURGE=0 READ(12,'(A133)',IOSTAT=IOS,ERR=2010,END=410) LINE 400 CONTINUE READ(12,'(A133)',IOSTAT=IOS,ERR=2010,END=410) LINE IF(LINE(1:1).EQ.'%'.AND.LINE(2:2).EQ.'X')THEN LIST=.FALSE. NPURGE=NPURGE+1 PRINT *,' Removing member '//LINE(32:39)//' (type '// - LINE(41:48)//'),' PRINT *,' created on '//LINE(11:18)//' at '// - LINE(23:30)//', remarks: '//LINE(51:79) PRINT *,' ' ELSEIF(LINE(1:1).EQ.'%')THEN LIST=.TRUE. ENDIF IF(LIST)WRITE(9,'(A133)',IOSTAT=IOS,ERR=2015) LINE GOTO 400 410 CONTINUE IF(NPURGE.GT.0)THEN PRINT *,' A total of ',NPURGE,' members were removed.' ELSE PRINT *,' No members were marked for deletion.' ENDIF * Close the file on unit 12, deleting it at the same time. CLOSE(UNIT=12,STATUS='DELETE',IOSTAT=IOS,ERR=2030) * Create a new file with the same name. CALL DSNOPN(FILE,NCFILE,12,'WRITE-LIBRARY',IFAIL) IF(IFAIL.EQ.1)THEN PRINT *,' ###### DSNINP ERROR : Unable to'// - ' create the file again ; dataset lost.' +SELF,IF=CMS. PRINT *,' The data might'// - ' still be stored in GARFTEMP COPYFILE A.' +SELF. CLOSE(UNIT=9,IOSTAT=IOS,ERR=2035) CALL DSNLOG(FILE,'% Purge ','Sequential', - 'Deleted !!') CALL DSNLOG('< intermediate file for copying >', - 'Dataset ','Sequential','Read/Write') GOTO 1020 ENDIF * And copy the whole file back to the original file. REWIND(UNIT=9,IOSTAT=IOS,ERR=2055) 420 CONTINUE READ(9,'(A133)',IOSTAT=IOS,ERR=2015,END=430) LINE WRITE(12,'(A)',IOSTAT=IOS,ERR=2010) LINE(1:STRLEN(LINE)) GOTO 420 430 CONTINUE * Close the scratch file and log its use. CLOSE(UNIT=9,IOSTAT=IOS,ERR=2035) CALL DSNLOG('< intermediate file for copying >', - 'Dataset ','Sequential','Read/Write') CALL DSNLOG(FILE,'% Purge ','Sequential', - 'Read/Write') ** Look for the keyword RECOVER. ELSEIF(INPCMP(IKEY,'%REC#OVER')+INPCMP(IKEY,'REC#OVER')+ - INPCMP(IKEY,'%RES#CUE')+INPCMP(IKEY,'RES#CUE').NE.0)THEN IF(IKEY+2.GT.NWORD)THEN PRINT *,' !!!!!! DSNINP WARNING : A member must be'// - ' specified on a RECOVER command.' GOTO 1010 ENDIF * Read through the dataset and mark, then copy to scratch. EXMEMB=.FALSE. +SELF,IF=CMS. CALL VMCMS('FILEDEF FT09F001 DISK GARFTEMP COPYFILE'// - ' (RECFM F LRECL 133',IRC) +SELF. OPEN(UNIT=9,STATUS='SCRATCH',IOSTAT=IOS,ERR=2025) 300 CONTINUE READ(12,'(A133)',IOSTAT=IOS,ERR=2010,END=310) LINE IF(LINE(1:2).EQ.'%X')THEN CALL WLDCRD(LINE(32:39),MEMBER(1:NCMEMB),.FALSE., - MATMEM) CALL WLDCRD(LINE(41:48),TYPE(1:NCTYPE),.FALSE., - MATTYP) ELSE MATMEM=.FALSE. MATTYP=.FALSE. ENDIF IF(LINE(1:2).EQ.'%X'.AND.MATMEM.AND.MATTYP)THEN EXMEMB=.TRUE. LINE(2:2)=' ' PRINT *,' Member '//MEMBER(1:NCMEMB)//' of type '// - LINE(41:48)//' recovered.' ENDIF WRITE(9,'(A133)',IOSTAT=IOS,ERR=2015) LINE GOTO 300 310 CONTINUE * Print an error message if the member has not been found. IF(.NOT.EXMEMB)THEN PRINT *,' !!!!!! DSNINP WARNING : '//MEMBER(1:NCMEMB)// - ' does not exist or has already been recovered.' CALL DSNLOG(FILE,'% Search ','Sequential', - 'Read only ') ELSE * Close the file on unit 12, deleting it at the same time. CLOSE(UNIT=12,STATUS='DELETE',IOSTAT=IOS,ERR=2030) * Create a new file with the same name. CALL DSNOPN(FILE,NCFILE,12,'WRITE-LIBRARY',IFAIL) IF(IFAIL.EQ.1)THEN PRINT *,' ###### DSNINP ERROR : Unable to'// - ' create the file again ; dataset lost.' +SELF,IF=CMS. PRINT *,' The data may'// - ' still be stored in GARFTEMP COPYFILE A.' +SELF. CLOSE(UNIT=9,IOSTAT=IOS,ERR=2035) CALL DSNLOG(FILE,'% Recover ','Sequential', - 'Delete !!!') CALL DSNLOG('< intermediate file for copying >', - 'Dataset ','Sequential','Read/Write') GOTO 1020 ENDIF * And copy the whole file back to the original file. REWIND(UNIT=9,IOSTAT=IOS,ERR=2055) 320 CONTINUE READ(9,'(A133)',IOSTAT=IOS,ERR=2015,END=330) LINE WRITE(12,'(A)',IOSTAT=IOS,ERR=2010) - LINE(1:STRLEN(LINE)) GOTO 320 330 CONTINUE CALL DSNLOG(FILE,'% Recover ','Sequential', - 'Read/Write') ENDIF * Close the scratch file and log its use. CLOSE(UNIT=9,IOSTAT=IOS,ERR=2035) CALL DSNLOG('< intermediate file for copying >', - 'Dataset ','Sequential','Read/Write') ** Keyword not known. ELSE CALL INPSTR(IKEY,IKEY,STRING,NC) PRINT *,' !!!!!! DSNINP WARNING : The instruction '// - STRING(1:NC)//' is not valid; ignored.' CALL DSNLOG(FILE,'% Illegal ','Open/Close','None ') ENDIF *** Close the I/O unit. 1010 CONTINUE CLOSE(UNIT=12,IOSTAT=IOS,ERR=2030) 1020 CONTINUE IF(LOOP)GOTO 1000 RETURN *** Handle error conditions. 2010 CONTINUE PRINT *,' ###### DSNINP ERROR : I/O error reading dataset'// - ' "'//FILE(1:NCFILE)//'" via LUN 12 ; attempt to close.' CALL INPIOS(IOS) GOTO 1010 2015 CONTINUE PRINT *,' !!!!!! DSNINP WARNING : I/O error to a temporary'// - ' file on LUN 9; operation not completed, attempt to close.' CALL INPIOS(IOS) CLOSE(UNIT=9,IOSTAT=IOS,ERR=2035) GOTO 1010 2025 CONTINUE PRINT *,' !!!!!! DSNINP WARNING : Error opening a temporary'// - ' file on LUN 12 ; operation not started.' CALL INPIOS(IOS) GOTO 1020 2030 CONTINUE PRINT *,' ###### DSNINP ERROR : Error closing '// - FILE(1:NCFILE)//' on LUN 12 ; results unpredictable.' CALL INPIOS(IOS) GOTO 1020 2035 CONTINUE PRINT *,' !!!!!! DSNINP WARNING : Error closing a temporary'// - ' file on LUN 12 ; results unpredictable.' CALL INPIOS(IOS) GOTO 1020 2040 CONTINUE PRINT *,' ###### DSNINP ERROR : Error during backspace on '// - FILE(1:NCFILE)//', via LUN 12 ; attempt to close.' CALL INPIOS(IOS) GOTO 1010 2055 CONTINUE PRINT *,' !!!!!! DSNINP WARNING : Error during a rewind of a'// - ' temporary file on LUN 12 ; attempt to close.' CALL INPIOS(IOS) CLOSE(UNIT=9,IOSTAT=IOS,ERR=2035) GOTO 1010 END +DECK,DSNINQVM,IF=CMS. SUBROUTINE DSNINQ(FILE,NC,EXIST) *----------------------------------------------------------------------- * DSNINQ - Determines on VM/CMS systems whether a file exists. * VARIABLES : FILE : The name of the file to be opened. * NC : Number of characters in FILE. * EXIST : .TRUE. if the file exists * (Last changed on 25/ 4/95.) *----------------------------------------------------------------------- CHARACTER*(*) FILE CHARACTER*1191 EXEC INTEGER NC LOGICAL EXIST *** Create the exec file. EXEC( 1: 550)= - '/* Origin: DSNINQ EXEC */Signal on Syntax;Signal on Nov'// - 'alue;Signal on Halt;Address Command;Arg file;fileout=""'// - ';last=".";ndot=0;Do i=1 To "LENGTH"(file);char="SUBSTR"'// - '(file,i,1);If char=" " Then Do;If last^="." Then last="'// - 'B";End;Else If char="." Then Do;fileout=fileout||".";nd'// - 'ot=ndot+1;last=".";End;Else Do;If last="B" Then Do;file'// - 'out=fileout||"."||char;ndot=ndot+1;End;Else;fileout=fil'// - 'eout||char;last="C";End;End;Parse var fileout fn"."ft".'// - '"fm"."junk;If ndot>2 Then;Say " !!!!!! DSNINQ EXECWRN :'// - ' Too many components in the file name; ignoring """junk' EXEC( 551:1100)= - '""".";If fn='''' | ft='''' Then Do;Say " !!!!!! DSNINQ '// - 'EXECWRN : Please specify at least file name and type; n'// - 'o inquiry done.";Exit 1;End;If fm='''' Then fm=''*'';"S'// - 'ET CMSTYPE HT";"MAKEBUF";n_old = "QUEUED"();"LISTFILE" '// - 'fn ft fm "(STACK FIFO ALL";rclist = rc;"SET CMSTYPE RT"'// - ';n_new = "QUEUED"();''DROPBUF'';If rclist = 24 Then Do;'// - 'Say " !!!!!! DSNINQ EXECWRN : Your file specification" '// - 'fn ft fm "contains an invalid character.";Exit 1;End;El'// - 'se If rclist = 36 Then Do;Say " !!!!!! DSNINQ EXECWRN :'// - ' No disk has been accessed under mode letter" "LEFT"(fm' EXEC(1101:1191)= - ',1)".";Exit 1;End;Else If rclist = 28 Then Do;Exit 1;En'// - 'd;Else;n_files = n_new-n_old;Exit 0;' *** Execute an EXEC file to do most of the job. CALL DSNVMX(EXEC,FILE(1:NC),IRC,IFAIL) *** Handle error conditions. IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! DSNINQ WARNING : Failure to have the'// - ' REXX exec executed that checks VM files.' RETURN ENDIF *** Return code of EXEC is 0 for exist, 1 for non-existent. IF(IRC.NE.0)THEN EXIST=.FALSE. ELSE EXIST=.TRUE. ENDIF END +DECK,DSNINQUX,IF=UNIX,CYGWIN. SUBROUTINE DSNINQ(FILE,NC,EXIST) *----------------------------------------------------------------------- * DSNINQ - Determines on Unix whether a file exists. * (Last changed on 18/ 4/96.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. CHARACTER*(*) FILE CHARACTER*(MXNAME) F_OUT LOGICAL EXIST *** Identify the routine, if required. IF(LIDENT)PRINT *,' /// ROUTINE DSNINQ (Unix+Cygwin) ///' IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DSNINQ DEBUG : Input'', - '' file name: '',A,'' (length='',I3,'').'')') - FILE(1:MAX(1,NC)),NC *** Expand the file name. CALL DSNFMT(FILE,NC,F_OUT,NC_OUT,'ANY',IFAIL) IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DSNINQ DEBUG : Expanded'', - '' name: '',A,'' (length='',I3,'').'')') - F_OUT(1:MAX(1,NC_OUT)),NC_OUT IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! DSNINQ WARNING : File name expansion'// - ' failed ; file declared non-existing.' EXIST=.FALSE. RETURN ENDIF *** Now check existence. INQUIRE(FILE=F_OUT(1:NC_OUT),EXIST=EXIST) IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DSNINQ DEBUG : Exist='', - L1)') EXIST END +DECK,DSNINQVX,IF=VAX. SUBROUTINE DSNINQ(FILE,NC,EXIST) *----------------------------------------------------------------------- * DSNINQ - Determines on a Vax whether a file exists. * (Last changed on 25/ 4/95.) *----------------------------------------------------------------------- CHARACTER*(*) FILE CHARACTER*255 F_OUT LOGICAL EXIST *** Count how many files match. NFOUND=0 CONTEXT=0 10 CONTINUE * Check status code searching for the next. IST=LIB$FIND_FILE(FILE(1:NC),F_OUT,CONTEXT,,,,) * If odd, file found. IF(IST.NE.2*INT(REAL(IST)/2.0))THEN NFOUND=NFOUND+1 GOTO 10 ENDIF * If even, last file seen: clear the buffer used to list the files. IST=LIB$FIND_FILE_END(CONTEXT) *** Check that there is at least one file matching. IF(NFOUND.GT.0)THEN EXIST=.TRUE. ELSE EXIST=.FALSE. ENDIF END +DECK,DSNINQOT,IF=-CMS,IF=-UNIX,IF=-VAX,IF=-CYGWIN. SUBROUTINE DSNINQ(FILE,NC,EXIST) *----------------------------------------------------------------------- * DSNINQ - Determines whether a file exists. * (Last changed on 25/ 4/95.) *----------------------------------------------------------------------- CHARACTER*(*) FILE LOGICAL EXIST *** Issue an INQUIRE to find out whether the file exists. INQUIRE(FILE=FILE(1:NC),EXIST=EXIST) END +DECK,DSNLOC. SUBROUTINE DSNLOC(MEMBER,NC,TYPE,LUN,EXIS,OPER) *----------------------------------------------------------------------- * DSNLOC - Places the pointer in a Garfield file on the header record * of the requested member. *----------------------------------------------------------------------- +SEQ,PRINTPLOT. CHARACTER*80 STRING CHARACTER CHAR CHARACTER*8 MEMBER,TYPE CHARACTER*(*) OPER LOGICAL EXIS,OPEN,MATCH *** Print some debugging information. IF(LIDENT)PRINT *,' /// ROUTINE DSNLOC ///' IF(LDEBUG)PRINT *,' ++++++ DSNLOC DEBUG : Request to locate ', - MEMBER(1:NC),' on unit ',LUN,' in mode ',OPER,'.' *** First set EXIS to .FALSE. ie not yet found. EXIS=.FALSE. *** Check that unit LUN is indeed open. INQUIRE(UNIT=LUN,OPENED=OPEN) IF(.NOT.OPEN)THEN PRINT *,' ###### DSNLOC ERROR : Unit ',LUN,' should be'// - ' open but is not; program bug, member not located.' RETURN ENDIF *** Rewind the file. REWIND(UNIT=LUN,ERR=2050,IOSTAT=IOS) *** Loop until EOF or until the member has been located. 10 CONTINUE READ(LUN,'(A1)',END=20,IOSTAT=IOS,ERR=2010) CHAR IF(CHAR.EQ.'%')THEN BACKSPACE(UNIT=LUN,IOSTAT=IOS,ERR=2040) READ(LUN,'(A80)',END=20,IOSTAT=IOS,ERR=2010) STRING IF(LDEBUG)PRINT *,' ++++++ DSNLOC DEBUG : Found member '// - STRING(32:39)//', type '//STRING(41:48)// - ', delete flag "'//STRING(2:2)//'".' * Skip members of the wrong type and deleted members unless IGNORE. IF((OPER.NE.'IGNORE'.AND.STRING(2:2).EQ.'X').OR. - STRING(41:48).NE.TYPE)GOTO 10 * Wildcard check for the actual member name. CALL WLDCRD(STRING(32:39),MEMBER(1:NC),.FALSE.,MATCH) * Member found, make sure the next read sees the header and return. IF(MATCH)THEN EXIS=.TRUE. BACKSPACE(UNIT=LUN,IOSTAT=IOS,ERR=2040) RETURN ENDIF ENDIF * Next line. GOTO 10 *** EOF seen on the dataset, member apparently not found. 20 CONTINUE REWIND(UNIT=LUN,IOSTAT=IOS,ERR=2050) RETURN *** Handle error conditions. 2010 CONTINUE PRINT *,' ###### DSNLOC ERROR : I/O error reading a dataset'// - ' for dataset manipulation via LUN ',LUN,'; no action.' CALL INPIOS(IOS) RETURN 2040 CONTINUE PRINT *,' ###### DSNLOC ERROR : Error during backspace on'// - ' a dataset connected to LUN ',LUN,' ; no action.' CALL INPIOS(IOS) RETURN 2050 CONTINUE PRINT *,' ###### DSNLOC ERROR : Error during rewind on'// - ' a dataset connected to LUN ',LUN,' ; no action.' CALL INPIOS(IOS) END +DECK,DSNLOG. SUBROUTINE DSNLOG(DSNAME,TYPNAM,ACCESS,OPER) *----------------------------------------------------------------------- * DSNLOG - Routine accumulating data on dataset use (eg sceptre data- * sets) with an entry to print the data (DSNPRT). * VARIABLES : NAME : Line with information on the dataset. * LIST : List of the above descriptions. * ICOUNT : Counts the number of names entered. * ACCESS : Type of access, set by calling routine. * TYPNAM : Type of data, set by calling routine. * OPER : Type of operation carried out. * (Last changed on 26/ 9/08.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. CHARACTER*40 DSN CHARACTER*76 LIST(100) CHARACTER*(*) DSNAME CHARACTER*10 ACCESS,OPER,TYPNAM INTEGER ICOUNT,J +SELF,IF=SAVE. SAVE LIST,ICOUNT +SELF. *** Initialise ICOUNT to 0. DATA ICOUNT/0/ *** Store the information, if there is still room for them. IF(ICOUNT.LT.100)THEN DSN=' ' DSN=DSNAME ICOUNT=ICOUNT+1 LIST(ICOUNT)=DSN//' '//TYPNAM//' '//ACCESS//' '//OPER ENDIF *** Issue a warning if 100 datasets have been accessed IF(ICOUNT.EQ.100)THEN ICOUNT=101 PRINT *,' ------ DSNLOG MESSAGE : 100 Datasets have been'// - ' used ; further dataset information not stored.' ENDIF RETURN *** Print the list. ENTRY DSNPRT WRITE(*,'(''1'')') IF(ICOUNT.EQ.0)THEN PRINT *,' No data sets have been accessed.' RETURN ENDIF PRINT *,' The following datasets have been accessed:' PRINT *,' ==========================================' PRINT *,' ' PRINT *,' Dataset name Type ', - ' Access Operation ' PRINT *,' ' DO 10 J=1,MIN(ICOUNT,100) PRINT *,' ',LIST(J) 10 CONTINUE PRINT *,' ' PRINT *,' ' END +DECK,DSNOPNVM,IF=CMS. SUBROUTINE DSNOPN(FILE,NC,LUNDSN,ACCESS,IFAIL) *----------------------------------------------------------------------- * DSNOPN - Opens a file, version for VM/CMS systems. Uses REXX and * several HEPVM and CERN additional functions. * VARIABLES : FILE : The name of the file to be opened. * NC : Number of characters in FILE. * LUNDSN : The logical file number to open the file. * ACCESS : The type of access to the file. * (Last changed on 23/ 5/95.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. CHARACTER*(*) FILE,ACCESS CHARACTER*6543 EXEC CHARACTER*80 ARG CHARACTER*(MXNAME) DSNDEF CHARACTER*9 ACTION INTEGER NC,LUNDSN,IFAIL +SELF,IF=SAVE. SAVE DSNDEF,NCDEF +SELF. DATA DSNDEF/'= INPUT ='/,NCDEF/9/ *** Create the exec file. EXEC( 1: 550)= - '/* Origin: DSNOPN EXEC */Signal on Syntax;Signal on Nov'// - 'alue;Signal on Halt;Address Command;"ID (LIFO";Pull acc'// - 'ount . node .;userid = "XNAME"("USERID");Arg file"/"fil'// - 'edef"/"lun"/"rw;fileout="";last=".";ndot=0;Do i=1 To "L'// - 'ENGTH"(file);char="SUBSTR"(file,i,1);If char=" " Then D'// - 'o;If last^="." Then last="B";End;Else If char="." Then '// - 'Do;fileout=fileout||".";ndot=ndot+1;last=".";End;Else D'// - 'o;If last="B" Then Do;fileout=fileout||"."||char;ndot=n'// - 'dot+1;End;Else;fileout=fileout||char;last="C";End;End;f'// - 'ile=fileout;fileout="";last=".";ndotdef=0;Do i=1 To "LE' EXEC( 551:1100)= - 'NGTH"(filedef);char="SUBSTR"(filedef,i,1);If char=" " T'// - 'hen Do;If last^="." Then last="B";End;Else If char="." '// - 'Then Do;fileout=fileout||".";ndotdef=ndotdef+1;last="."'// - ';End;Else Do;If last="B" Then Do;fileout=fileout||"."||'// - 'char;ndotdef=ndotdef+1;End;Else;fileout=fileout||char;l'// - 'ast="C";End;End;filedef=fileout;Parse var file fn"."ft"'// - '."fm"."junk;Parse var filedef fndef"."ftdef"."fmdef"."j'// - 'unkdef;If ndot>2 Then;Say " !!!!!! DSNOPN EXECWRN : Too'// - ' many components in the file name; ignoring """junk""".'// - '";If ndotdef>2 Then;Say " !!!!!! DSNOPN EXECWRN : Too m' EXEC(1101:1650)= - 'any components in the default file; ignoring """junkdef'// - '""".";lun = "STRIP"(lun,"B"); rw = "STRIP"(rw,"B");If r'// - 'w^="READ-FILE" & rw^="WRITE-FILE" & rw^="RW-FILE" & rw^'// - '="READ-LIBRARY" & rw^="WRITE-LIBRARY" & rw^="RW-LIBRARY'// - '" Then Do;Say " !!!!!! DSNOPN EXECWRN : Unknown access '// - 'description" rw "received.";Exit 1;End;If "DATATYPE"(lu'// - 'n)^= "NUM" | lun<0 | lun>99 Then Do;Say " !!!!!! DSNOPN'// - ' EXECWRN : Incorrect logical unit" lun "received.";Exit'// - ' 1;End;lun = "RIGHT"(lun,2,"0");If fn="" | fn="=" Then '// - 'fn=fndef;If ft="" | ft="=" Then ft=ftdef;If fm="" | fm=' EXEC(1651:2200)= - '"=" Then fm=fmdef;If fn="" | fn="=" Then fn="*";If ft="'// - '" | ft="=" Then ft="*";If fm="" | fm="=" Then Do;If "LE'// - 'FT"(rw,5)="WRITE" | "LEFT"(rw,2)="RW" Then;fm = "QDISK"'// - '("RW","MODE");Else;fm = "*";End;If "INDEX"(fn ft fm,"*"'// - ')+"INDEX"(fn ft fm,"%")>0 Then;wildcard = 1;Else;wildca'// - 'rd = 0;n_old = "QUEUED"();"SET CMSTYPE HT";"MAKEBUF";"L'// - 'ISTFILE" fn ft fm "(STACK FIFO ALL";rclist = rc;"SET CM'// - 'STYPE RT";n_new = "QUEUED"();If rclist = 24 Then Do;Say'// - ' " !!!!!! DSNOPN EXECWRN : Your file specification" fn '// - 'ft fm "contains an invalid character.";"DROPBUF";Exit 1' EXEC(2201:2750)= - ';End;Else If rclist = 36 Then Do;Say " !!!!!! DSNOPN EX'// - 'ECWRN : No disk has been accessed under mode letter" "L'// - 'EFT"(fm,1)".";"DROPBUF";Exit 1;End;Else If rclist = 28 '// - '& wildcard Then Do;Say " !!!!!! DSNOPN EXECWRN : No fil'// - 'e found that matches" fn ft fm"; no file opened.";"DROP'// - 'BUF";Exit 1;End;Else If rclist = 28 Then;n_files = 0;El'// - 'se;n_files = n_new-n_old;If n_files>1 Then;Say " ------'// - ' DSNOPN EXECMSG :" n_files "files match your wildcard" '// - 'fn ft fm".";found = 0;n_OK = 0;Do i=1 To n_files;Pull f'// - 'nr ftr fmr recfm lrecl .;If (lrecl>500 & rw="READ-FILE"' EXEC(2751:3300)= - ') | ((recfm^="F" | lrecl<133) & "RIGHT"(rw,7)="LIBRARY"'// - ') Then Do;Say " ------ DSNOPN EXECMSG : File" fnr ftr f'// - 'mr "does not have the right format.";Iterate;End;If ("L'// - 'EFT"(rw,5)="WRITE" | "LEFT"(rw,2)="RW") & "QDISK"(fmr,"'// - 'ACCESS")^="RW" Then Do;Say " ------ DSNOPN EXECMSG : Yo'// - 'u do not have write access to" fnr ftr fmr".";Iterate;E'// - 'nd;If ^found Then Do;fn = fnr;ft = ftr;fm = fmr;found ='// - ' 1;End;n_OK = n_OK + 1;End;"DROPBUF";If n_OK=0 & n_file'// - 's>0 Then Do;Say " !!!!!! DSNOPN EXECWRN : At least one '// - 'file matches but no useable file found; no file opened.' EXEC(3301:3850)= - '";Exit 1;End;Else If n_OK=0 & "LEFT"(rw,4)="READ" Then '// - 'Do;Say " !!!!!! DSNOPN EXECWRN : The file" fn ft fm "ha'// - 's not been found; not opened for read access.";Exit 1;E'// - 'nd;Else If n_OK=0 & ("LEFT"(rw,5)="WRITE" | "LEFT"(rw,2'// - ')="RW") & "QDISK"(fm,"ACCESS")^="RW" Then Do;Say " !!!!'// - '!! DSNOPN EXECWRN : You do not have write access to you'// - 'r" "LEFT"(fm,1) "disk; no file opened.";Exit 1;End;If w'// - 'ildcard Then Do;If n_files=1 & n_OK=1 Then;Say " ------'// - ' DSNOPN EXECMSG : Only" fn ft fm "matches your wildcard'// - '.";Else If n_files>1 & n_OK=1 Then;Say " ------ DSNOPN ' EXEC(3851:4400)= - 'EXECMSG : The only suitable file matching your wildcard'// - ' is" fn ft fm".";Else If n_files=n_OK Then;Say " ------'// - ' DSNOPN EXECMSG : All" n_files "are suitable, selecting'// - '" fn ft fm".";Else;Say " ------ DSNOPN EXECMSG : Only" '// - 'n_OK "are suitable, selecting" fn ft fm".";End;If "FEXI'// - 'ST"(fn ft fm) Then Do;filestat = "QFILE"(fn ft fm,"STAT'// - 'US");If filestat^="N" Then Do;If filestat="R" Then;Say '// - '" ------ DSNOPN EXECMSG : File" fn ft fm "is currently '// - 'being read; not opened.";Else If filestat="W" Then;Say '// - '" ------ DSNOPN EXECMSG : File" fn ft fm "is currently ' EXEC(4401:4950)= - 'being written; not opened.";Else;Say " ------ DSNOPN EX'// - 'ECMSG : File" fn ft fm "is currently being accessed ("f'// - 'ilestat"); not opened.";Exit 1;End;End;If "QDISK"(fm,"M'// - 'ODIFIED") Then Do;"SET CMSTYPE HT";address="QDISK"(fm,"'// - 'ADDRESS");"EXEC RELEASE" "LEFT"(fm,1);"ACCESS" address '// - '"LEFT"(fm,1);"SET CMSTYPE RT";Say " ------ DSNOPN EXECM'// - 'SG : Your" "LEFT"(fm,1) "disk has been reaccessed becau'// - 'se the disk has been modified.";End;If n_OK=0 & (rw="WR'// - 'ITE-LIBRARY" | rw="RW-LIBRARY") Then Do;aux = "* This G'// - 'arfield library has been created by user" userid"@"node' EXEC(4951:5500)= - ' "on" "DATE"("E") "at" "TIME"()".";Push "LEFT"(aux,132,'// - '" ")||"*";"EXECIO 1 DISKW" fn ft fm "1 F 133 (FINIS";If'// - ' rc=0 Then;Say " ------ DSNOPN EXECMSG : Library" fn ft'// - ' fm "has been created.";Else Do;Say " !!!!!! DSNOPN EXE'// - 'CWRN : Error writing a header record for library" fn ft'// - ' fm".";Exit 1;End;End;If n_OK=0 & rw="RW-FILE" Then Do;'// - 'aux = "* This file has been created by user" userid"@"n'// - 'ode "on" "DATE"("E") "at" "TIME"()".";Push "LEFT"(aux,1'// - '32," ")||"*";"EXECIO 1 DISKW" fn ft fm "1 V (FINIS";If '// - 'rc^=0 Then Do;Say " !!!!!! DSNOPN EXECWRN : Error writi' EXEC(5501:6050)= - 'ng a header record for file" fn ft fm".";Exit 1;End;End'// - ';If rw="WRITE-FILE" Then Do;If n_OK>0 Then Do;If "FEXIS'// - 'T"(fn "LEFT"("OLD"||ft,8) fm) Then "ERASE" fn "LEFT"("O'// - 'LD"||ft,8) fm;"RENAME" fn ft fm fn "LEFT"("OLD"||ft,8) '// - 'fm;End;aux = "* This file has been created by user" use'// - 'rid"@"node "on" "DATE"("E") "at" "TIME"()".";Push "LEFT'// - '"(aux,132," ")||"*";"EXECIO 1 DISKW" fn ft fm "1 V (FIN'// - 'IS";If rc^=0 Then Do;Say " !!!!!! DSNOPN EXECWRN : Erro'// - 'r writing a header record for file" fn ft fm".";Exit 1;'// - 'End;End;If rw="WRITE-FILE" | rw="RW-FILE" Then Do;"FILE' EXEC(6051:6543)= - 'DEF FT"lun"F001 CLEAR";"FILEDEF FT"lun"F001 DISK" fn ft'// - ' fm "(RECFM V";End;Else Do;"FILEDEF FT"lun"F001 CLEAR";'// - '"FILEDEF FT"lun"F001 DISK" fn ft fm;End;Exit;SYNTAX:;Sa'// - 'y " ###### DSNOPN EXECERR : Syntax error at line" sigl '// - '"; program bug, please report.";Exit 1;NOVALUE:;Say " #'// - '##### DSNOPN EXECERR : Unitialised variable at line" si'// - 'gl "; program bug, please report.";Exit 1;HALT:;Say " -'// - '----- DSNOPN EXECMSG : You have interrupted the executi'// - 'on of the file opening exec, no file opened.";Exit 1;' *** Write the argument string for the exec. WRITE(ARG,'(A,''/'',A,''/'',I3,''/'',A)') FILE(1:NC), - DSNDEF(1:NCDEF),LUNDSN,ACCESS *** Execute an EXEC file to do most of the job. CALL DSNVMX(EXEC,ARG,IRC,IFAIL) *** Handle error conditions. IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! DSNOPN WARNING : Failure to have the'// - ' REXX exec executed that opens VM files.' RETURN ENDIF *** Make an ACTION string. IF(ACCESS(1:2).EQ.'RW'.OR.ACCESS(1:5).EQ.'WRITE')THEN ACTION='READWRITE' ELSEIF(ACCESS(1:4).EQ.'READ')THEN ACTION='READ' ELSE PRINT *,' !!!!!! DSNOPN WARNING : Invalid access type'// - ' received '//ACCESS//'; program bug.' RETURN ENDIF *** FILEDEF has already been issued, now also open the file. IF(IRC.EQ.0.AND.ACCESS.EQ.'READ-FILE')THEN OPEN(UNIT=LUNDSN,ERR=2020,FORM='UNFORMATTED',ACTION=ACTION) IF(LDEBUG)PRINT *,' ++++++ DSNOPN DEBUG : Unit ',LUNDSN, - ' opened for unformatted ',ACTION ELSEIF(IRC.EQ.0)THEN OPEN(UNIT=LUNDSN,ERR=2020,ACTION=ACTION) IF(LDEBUG)PRINT *,' ++++++ DSNOPN DEBUG : Unit ',LUNDSN, - ' opened for formatted ',ACTION ENDIF *** Move to the end of the file is library output is to be performed. IF(IRC.EQ.0.AND.(ACCESS.EQ.'WRITE-LIBRARY'.OR. - ACCESS.EQ.'WRITE-FILE'.OR.ACCESS.EQ.'RW-FILE'))THEN 100 CONTINUE READ(LUNDSN,'()',END=110,ERR=2010,IOSTAT=IOS) GOTO 100 110 CONTINUE BACKSPACE(LUNDSN,ERR=2040,IOSTAT=IOS) ENDIF *** Pass a non-zero exec rc on to the calling routine as an error. IF(IRC.NE.0)THEN IFAIL=1 ELSE IFAIL=0 ENDIF *** Normal end of the routine. RETURN *** Entry point for default handling. ENTRY DSNFMD * Figure out where the key is located. CALL INPNUM(NWORD) IF(INPCMP(1,'%').NE.0)THEN IKEY=2 ELSE IKEY=1 ENDIF * See whether this is an inquiry or an update. IF(NWORD.GT.IKEY+3)PRINT *,' !!!!!! DSNFMD WARNING : Too'// - ' many arguments; excess ignored.' IF(IKEY.EQ.NWORD)THEN WRITE(LUNOUT,'(/1X,A/)') ' The current default file'// - ' specification is '//DSNDEF(1:NCDEF)//'.' ELSE CALL INPSTR(IKEY+1,NWORD,DSNDEF,NCDEF) IF(LDEBUG)WRITE(LUNOUT,*) ' ++++++ DSNFMD DEBUG : New'// - ' default: '//DSNDEF(1:NCDEF)//'.' ENDIF RETURN *** Error handling. 2010 CONTINUE PRINT *,' !!!!!! DSNOPN WARNING : Reading error while'// - ' attempting to skip to the end of file.' CALL INPIOS(IOS) IFAIL=1 RETURN 2020 CONTINUE PRINT *,' !!!!!! DSNOPN WARNING : Error while opening'// - ' your file.' CALL INPIOS(IOS) IFAIL=1 RETURN 2040 CONTINUE PRINT *,' !!!!!! DSNOPN WARNING : Backspace error while'// - ' attempting to skip to the end of file.' CALL INPIOS(IOS) IFAIL=1 END +DECK,DSNOPNUX,IF=UNIX,CYGWIN. SUBROUTINE DSNOPN(DSNAME,NCDSN,LUNDSN,ACCESS,IFAIL) *----------------------------------------------------------------------- * DSNOPN - Opens a file. * VARIABLES : FILE/DSNAME : The name of the file to be opened. * NC/NCDSN : Number of characters in FILE. * LUNDSN : The logical file number to open the file. * ACCESS : The type of access to the file. * (Last changed on 6/ 3/08.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. CHARACTER*(*) DSNAME,ACCESS +SELF,IF=-LINUX,IF=-MACOSX,IF=-BOINC. CHARACTER*1 STRING +SELF. LOGICAL EXBACK LOGICAL OPEN,EXIS CHARACTER*(MXNAME) FILE INTEGER NC,NCDSN,LUNDSN,IFAIL,IOS +SELF,IF=BOINC. INTEGER I +SELF. *** Identify the routine if requested. IF(LIDENT)PRINT *,' /// ROUTINE DSNOPN (Unix+Cygwin) ///' IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DSNOPN DEBUG : Request'', - '' to open '',A/26X,''on unit '',I2,'' with access '',A)') - DSNAME(1:NCDSN),LUNDSN,ACCESS *** Initialise IFAIL to 1. IFAIL=1 *** Check that the unit is closed. INQUIRE(UNIT=LUNDSN,OPENED=OPEN) IF(OPEN)THEN PRINT *,' !!!!!! DSNOPN WARNING : Unit ',LUNDSN,' is'// - ' found to be open ; attempt to close it.' CLOSE(UNIT=LUNDSN,STATUS='KEEP',IOSTAT=IOS,ERR=2030) ENDIF *** Perform subsitutions of environment variables. CALL DSNFMT(DSNAME,NCDSN,FILE,NC,'ANY',IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! DSNOPN WARNING : The file is not opened'// - ' because of the above error.' RETURN ENDIF +SELF,IF=BOINC. *** Resolve the file name for BOINC. call boincrf(file(1:nc),file) do i=len(file),1,-1 if(file(i:i).ne.' ')then nc=i goto 1234 endif enddo 1234 continue +SELF. *** Store the file existence flag. INQUIRE(FILE=FILE(1:NC),EXIST=EXIS) IF((.NOT.EXIS).AND. - (ACCESS(1:4).EQ.'READ'.OR.ACCESS(1:2).EQ.'RW'))THEN PRINT *,' !!!!!! DSNOPN WARNING : The file '//FILE(1:NC)// - ' has not been found; not opened.' IFAIL=1 RETURN ENDIF *** Check that the file is not open. INQUIRE(FILE=FILE(1:NC),OPENED=OPEN) IF(OPEN)THEN PRINT *,' !!!!!! DSNOPN WARNING : The file '//FILE(1:NC)// - ' is already open; no access given.' IFAIL=1 RETURN ENDIF *** Open the dataset. IF(INDEX(ACCESS,'WRITE').NE.0)THEN * If an output file, shift previous copies. IF(INDEX(ACCESS,'FILE').NE.0.AND.EXIS)THEN INQUIRE(FILE=FILE(1:NC)//'.bak',EXIST=EXBACK) IF(EXBACK)CALL unlink(FILE(1:NC)//'.bak') CALL rename(FILE(1:NC),FILE(1:NC)//'.bak') OPEN(UNIT=LUNDSN,FILE=FILE(1:NC),STATUS='NEW', - ACCESS='SEQUENTIAL',FORM='FORMATTED', - IOSTAT=IOS,ERR=2020) EXIS=.FALSE. * If a binary output file, shift previous copies. ELSEIF(INDEX(ACCESS,'BINARY').NE.0.AND.EXIS)THEN INQUIRE(FILE=FILE(1:NC)//'.bak',EXIST=EXBACK) IF(EXBACK)CALL unlink(FILE(1:NC)//'.bak') CALL rename(FILE(1:NC),FILE(1:NC)//'.bak') OPEN(UNIT=LUNDSN,FILE=FILE(1:NC),STATUS='NEW', - ACCESS='SEQUENTIAL',FORM='UNFORMATTED', - IOSTAT=IOS,ERR=2020) EXIS=.FALSE. * Otherwise skip to the end of the file if it exist. ELSEIF(EXIS)THEN +SELF,IF=LINUX,MACOSX,BOINC. OPEN(UNIT=LUNDSN,FILE=FILE(1:NC),STATUS='OLD', - ACCESS='APPEND',IOSTAT=IOS,ERR=2020) +SELF,IF=-LINUX,IF=-MACOSX,IF=-BOINC. OPEN(UNIT=LUNDSN,FILE=FILE(1:NC),STATUS='OLD', - ACCESS='SEQUENTIAL',IOSTAT=IOS,ERR=2020) 100 CONTINUE READ(LUNDSN,'(A1)',END=110,IOSTAT=IOS,ERR=2010) STRING GOTO 100 110 CONTINUE BACKSPACE(UNIT=LUNDSN,IOSTAT=IOS,ERR=2040) +SELF. * Or open a new file if it didn't yet exist. ELSEIF(INDEX(ACCESS,'BINARY').NE.0)THEN OPEN(UNIT=LUNDSN,FILE=FILE(1:NC),STATUS='NEW', - ACCESS='SEQUENTIAL',FORM='UNFORMATTED', - IOSTAT=IOS,ERR=2020) ELSE OPEN(UNIT=LUNDSN,FILE=FILE(1:NC),STATUS='NEW', - ACCESS='SEQUENTIAL',FORM='FORMATTED', - IOSTAT=IOS,ERR=2020) ENDIF * Open for non-binary read or read/write access. ELSEIF(INDEX(ACCESS,'BINARY').EQ.0)THEN OPEN(UNIT=LUNDSN,FILE=FILE(1:NC),STATUS='UNKNOWN', - ACCESS='SEQUENTIAL',FORM='FORMATTED', - IOSTAT=IOS,ERR=2020) * Open for binary read or read/write access. ELSE OPEN(UNIT=LUNDSN,FILE=FILE(1:NC),STATUS='UNKNOWN', - ACCESS='SEQUENTIAL',FORM='UNFORMATTED', - IOSTAT=IOS,ERR=2020) ENDIF *** Write a first record on the dataset if it is new. IF((.NOT.EXIS).AND. - INDEX(ACCESS,'BINARY').EQ.0.AND. - INDEX(ACCESS,'FILE').EQ.0.AND. - INDEX(ACCESS,'WRITE')+INDEX(ACCESS,'RW').NE.0) - WRITE(LUNDSN,'(''*----.----1----.----2----.----3'', - ''----.----4----.----5----.----6----.----7----.----8----.'', - ''----9----.---10----.---11----.---12----.---13--'')', - IOSTAT=IOS,ERR=2015) IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DSNOPN DEBUG : Dataset '', - A,'' opened on unit '',I2,''.'')') FILE(1:NC),LUNDSN *** Everything looks all right, set IFAIL to 0 (OK) and return. IFAIL=0 RETURN *** Handle I/O problems. 2010 CONTINUE PRINT *,' ###### DSNOPN ERROR : Error while skipping to'// - ' the end of the file '//FILE(1:NC)//'.' CALL INPIOS(IOS) IFAIL=1 RETURN 2015 CONTINUE PRINT *,' ###### DSNOPN ERROR : Failure to write a heading'// - ' record to the new file '//FILE(1:NC)//'.' CALL INPIOS(IOS) IFAIL=1 RETURN 2020 CONTINUE PRINT *,' ###### DSNOPN ERROR : Failure to open '//FILE(1:NC)// - ' on unit ',LUNDSN CALL INPIOS(IOS) IFAIL=1 RETURN 2030 CONTINUE PRINT *,' !!!!!! DSNOPN WARNING : I/O problem when closing'// - ' an unknown file on unit ',LUNDSN CALL INPIOS(IOS) IFAIL=1 RETURN 2040 CONTINUE PRINT *,' ###### DSNOPN ERROR : Backspace at the end of the'// - ' file '//FILE(1:NC)//' failed.' CALL INPIOS(IOS) IFAIL=1 END +DECK,DSNOPNOT,IF=APOLLO,MVS,VAX. SUBROUTINE DSNOPN(DSNAME,NCDSN,LUNDSN,ACCESS,IFAIL) *----------------------------------------------------------------------- * DSNOPN - Opens a file. * VARIABLES : FILE/DSNAME : The name of the file to be opened. * NC/NCDSN : Number of characters in FILE. * LUNDSN : The logical file number to open the file. * ACCESS : The type of access to the file. * (Last changed on 2/ 3/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. CHARACTER*(*) DSNAME,ACCESS +SELF,IF=APOLLO. CHARACTER*1 STRING +SELF. LOGICAL OPEN,EXIS CHARACTER*(MXNAME) FILE INTEGER NC,NCDSN,LUNDSN,IFAIL,IOS *** Identify the routine if requested. IF(LIDENT)PRINT *,' /// ROUTINE DSNOPN ///' *** Initialise IFAIL to 1. IFAIL=1 *** Check that the unit is closed. INQUIRE(UNIT=LUNDSN,OPENED=OPEN) IF(OPEN)THEN PRINT *,' !!!!!! DSNOPN WARNING : Unit ',LUNDSN,' is'// - ' found to be open ; attempt to close it.' CLOSE(UNIT=LUNDSN,STATUS='KEEP',IOSTAT=IOS,ERR=2030) ENDIF +SELF,IF=VAX. *** Get the complete Vax file name. CALL DSNFMT(DSNAME,NCDSN,FILE,NC,'ANY',IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! DSNOPN WARNING : The file is not opened'// - ' because of the above error.' RETURN ENDIF +SELF,IF=-VAX. *** Simply copy. FILE=DSNAME NC=NCDSN +SELF. *** Store the file existence flag. INQUIRE(FILE=FILE(1:NC),EXIST=EXIS) IF((.NOT.EXIS).AND. - (ACCESS(1:4).EQ.'READ'.OR.ACCESS(1:2).EQ.'RW'))THEN PRINT *,' !!!!!! DSNOPN WARNING : The file '//FILE(1:NC)// - ' has not been found; not opened.' IFAIL=1 RETURN ENDIF *** Check that the file is not open. INQUIRE(FILE=FILE(1:NC),OPENED=OPEN) IF(OPEN)THEN PRINT *,' !!!!!! DSNOPN WARNING : The file '//FILE(1:NC)// - ' is already open; no access given.' IFAIL=1 RETURN ENDIF *** Open the dataset. IF(ACCESS(1:5).EQ.'WRITE')THEN +SELF,IF=VAX. IF(ACCESS(7:10).EQ.'FILE')THEN IF(INDEX(FILE(1:NC),';').GE.2) - NC=INDEX(FILE(1:NC),';')-1 OPEN(UNIT=LUNDSN,FILE=FILE(1:NC),STATUS='NEW', - ACCESS='SEQUENTIAL',IOSTAT=IOS,ERR=2020) ELSE OPEN(UNIT=LUNDSN,FILE=FILE(1:NC),STATUS='UNKNOWN', - ACCESS='APPEND',IOSTAT=IOS,ERR=2020) ENDIF +SELF,IF=APOLLO. OPEN(UNIT=LUNDSN,FILE=FILE(1:NC),STATUS='UNKNOWN', - ACCESS='SEQUENTIAL',IOSTAT=IOS,ERR=2020) IF(EXIS)THEN 100 CONTINUE READ(LUNDSN,'(A1)',END=110,IOSTAT=IOS,ERR=2010) STRING GOTO 100 110 CONTINUE ENDIF +SELF,IF=VAX. ELSEIF(ACCESS(1:4).EQ.'READ')THEN OPEN(UNIT=LUNDSN,FILE=FILE(1:NC),STATUS='UNKNOWN', - ACCESS='SEQUENTIAL',READONLY,IOSTAT=IOS,ERR=2020) +SELF. ELSE OPEN(UNIT=LUNDSN,FILE=FILE(1:NC),STATUS='UNKNOWN', - ACCESS='SEQUENTIAL',IOSTAT=IOS,ERR=2020) ENDIF *** Write a first record on the dataset if it is new. IF((.NOT.EXIS).AND. - (ACCESS(1:5).EQ.'WRITE'.OR.ACCESS(1:2).EQ.'RW')) - WRITE(LUNDSN,'(''*----.----1----.----2----.----3'', - ''----.----4----.----5----.----6----.----7----.----8----.'', - ''----9----.---10----.---11----.---12----.---13--'')', - IOSTAT=IOS,ERR=2015) IF(LDEBUG)PRINT *,' ++++++ DSNOPN DEBUG : Dataset '// - FILE(1:NC)//' opened on unit ',LUNDSN,'.' *** Everything looks all right, set IFAIL to 0 (OK) and return. IFAIL=0 RETURN *** Handle I/O problems. +SELF,IF=-VAX. 2010 CONTINUE PRINT *,' ###### DSNOPN ERROR : Error while skipping to'// - ' the end of the file '//FILE(1:NC)//'.' CALL INPIOS(IOS) IFAIL=1 RETURN +SELF. 2015 CONTINUE PRINT *,' ###### DSNOPN ERROR : Failure to write a heading'// - ' record to the new file '//FILE(1:NC)//'.' CALL INPIOS(IOS) IFAIL=1 RETURN 2020 CONTINUE PRINT *,' ###### DSNOPN ERROR : Failure to open '//FILE(1:NC)// - ' on unit ',LUNDSN CALL INPIOS(IOS) IFAIL=1 RETURN 2030 CONTINUE PRINT *,' !!!!!! DSNOPN WARNING : I/O problem when closing'// - ' an unknown file on unit ',LUNDSN CALL INPIOS(IOS) IFAIL=1 RETURN +SELF,IF=-APOLLO,IF=-VAX. 2040 CONTINUE PRINT *,' ###### DSNOPN ERROR : Backspace at the end of the'// - ' file '//FILE(1:NC)//' failed.' CALL INPIOS(IOS) IFAIL=1 +SELF. END +DECK,DSNREM. SUBROUTINE DSNREM(FILE,MEMBER,TYPE,EXMEMB) *----------------------------------------------------------------------- * DSNREM - Checks whether a member already exists when writing a new * one and marks the old member for deletion if required. * VARIABLES : FILE : File name * MEMBER : Member name * TYPE : Member type * (Last changed on 30/ 8/97.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. CHARACTER*(*) FILE,MEMBER,TYPE CHARACTER*133 LINE INTEGER NCFILE,NCMEMB,NCTYPE,IFAIL,IOS LOGICAL EXIST,MATMEM,MATTYP,EXMEMB *** Assume that the member does not exist. EXMEMB=.FALSE. *** Establish the lengths of the various strings. NCFILE=LEN(FILE) NCMEMB=LEN(MEMBER) NCTYPE=LEN(TYPE) *** See whether the file exists. CALL DSNINQ(FILE,NCFILE,EXIST) * If the file doesn't exist, don't do anything else. IF(.NOT.EXIST)RETURN *** Open the file. CALL DSNOPN(FILE,NCFILE,12,'READ-LIBRARY',IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! DSNREM WARNING : Unable to open ', - FILE(1:NCFILE),'; not checked for existing members.' RETURN ENDIF *** Open a temporary file if "delete old copy" has been selected. IF(JEXMEM.EQ.1)THEN +SELF,IF=CMS. CALL VMCMS('FILEDEF FT09F001 DISK GARFTEMP COPYFILE'// - ' (RECFM F LRECL 133',IRC) +SELF. OPEN(UNIT=9,STATUS='SCRATCH',IOSTAT=IOS,ERR=2020) ENDIF *** Read through the dataset and mark, then copy to scratch. READ(12,'(A133)',IOSTAT=IOS,ERR=2010,END=110) LINE 100 CONTINUE READ(12,'(A133)',IOSTAT=IOS,ERR=2010,END=110) LINE IF(LINE(1:1).EQ.'%')THEN CALL WLDCRD(LINE(32:39),MEMBER(1:NCMEMB),.FALSE., - MATMEM) CALL WLDCRD(LINE(41:48),TYPE(1:NCTYPE),.FALSE., - MATTYP) ELSE MATMEM=.FALSE. MATTYP=.FALSE. ENDIF IF(LINE(1:1).EQ.'%'.AND.LINE(2:2).NE.'X'.AND. - MATMEM.AND.MATTYP.AND.JEXMEM.EQ.1)THEN LINE(2:2)='X' EXMEMB=.TRUE. PRINT *,' Member ',MEMBER(1:NCMEMB),' written on '// - LINE(11:18)//' at '//LINE(23:30)//' has been'// - ' marked for deletion.' ELSEIF(LINE(1:1).EQ.'%'.AND.LINE(2:2).NE.'X'.AND. - MATMEM.AND.MATTYP.AND.(JEXMEM.EQ.2.OR.JEXMEM.EQ.3))THEN EXMEMB=.TRUE. PRINT *,' !!!!!! DSNREM WARNING : A member called ', - MEMBER(1:NCMEMB),' was already written on '// - LINE(11:18)//' at '//LINE(23:30)//'.' ENDIF IF(JEXMEM.EQ.1)WRITE(9,'(A133)',IOSTAT=IOS,ERR=2015) LINE GOTO 100 110 CONTINUE *** Copy the file from unit 9 to unit 12, after deleting old copy. IF(JEXMEM.EQ.1)THEN CLOSE(UNIT=12,STATUS='DELETE',IOSTAT=IOS,ERR=2030) * Create a new file with the same name. CALL DSNOPN(FILE,NCFILE,12,'WRITE-LIBRARY',IFAIL) IF(IFAIL.EQ.1)THEN PRINT *,' ###### DSNREM ERROR : Unable to'// - ' create the file again ; dataset lost.' +SELF,IF=CMS. PRINT *,' The data may'// - ' still be stored in GARFTEMP COPYFILE A.' +SELF. CLOSE(UNIT=9,IOSTAT=IOS,ERR=2035) CALL DSNLOG(FILE,'Cleanup ','Sequential', - 'File lost') CALL DSNLOG('< intermediate file for copying >', - 'Cleanup ','Sequential','Read/Write') RETURN ENDIF * And copy the whole file back to the original file. REWIND(UNIT=9,IOSTAT=IOS,ERR=2055) 120 CONTINUE READ(9,'(A133)',IOSTAT=IOS,ERR=2015,END=130) LINE WRITE(12,'(A133)',IOSTAT=IOS,ERR=2010) LINE GOTO 120 130 CONTINUE * Close the main file. CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) CALL DSNLOG(FILE,'Cleanup ','Sequential', - 'Read/Write') * Close the scratch file and log its use. CLOSE(UNIT=9,IOSTAT=IOS,ERR=2035) CALL DSNLOG('< intermediate file for copying >', - 'Cleanup ','Sequential','Read/Write') *** Or simply close the file. ELSE CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) CALL DSNLOG(FILE,'Check ','Sequential', - 'Read/Write') ENDIF RETURN *** Handle I/O errors. 2010 CONTINUE PRINT *,' !!!!!! DSNREM WARNING : Read/write error on ', - FILE(1:NCFILE),'; no check for existing members.' CALL INPIOS(IOS) CLOSE(12,IOSTAT=IOS,ERR=2030) RETURN 2015 CONTINUE PRINT *,' !!!!!! DSNREM WARNING : Read/write error on a'// - ' temporary file ; no check for existing members.' CALL INPIOS(IOS) CLOSE(9,IOSTAT=IOS,ERR=2035) RETURN 2020 CONTINUE PRINT *,' !!!!!! DSNREM WARNING : Error opening a temporary'// - ' file for copying; no check for existing members.' CALL INPIOS(IOS) RETURN 2030 CONTINUE PRINT *,' !!!!!! DSNREM WARNING : File closing error on ', - FILE(1:NCFILE),'; no check for existing members.' CALL INPIOS(IOS) RETURN 2035 CONTINUE PRINT *,' !!!!!! DSNREM WARNING : File closing error on a', - ' temporary file; no check for existing members.' CALL INPIOS(IOS) RETURN 2055 CONTINUE PRINT *,' !!!!!! DSNREM WARNING : Rewind error on a', - ' temporary file; no check for existing members.' CLOSE(9,IOSTAT=IOS,ERR=2035) CALL INPIOS(IOS) RETURN END +DECK,DSNVMX,IF=CMS. SUBROUTINE DSNVMX(EXEC,ARG,IRC,IFAIL) *----------------------------------------------------------------------- * DSNVMX - Executes a REXX exec file. *----------------------------------------------------------------------- LOGICAL OPEN CHARACTER*(*) EXEC,ARG CHARACTER*80 FILDEF *** Assume for now that the routine will fail. IFAIL=1 *** Check unit 12 is closed. INQUIRE(UNIT=12,OPENED=OPEN) IF(OPEN)THEN PRINT *,' !!!!!! DSNVMX WARNING : Unit 12 found to be'// - ' open, trying to close.' CLOSE(UNIT=12,IOSTAT=IOS,ERR=2030) ENDIF *** Check existence of previous versions of GARFTEMP EXEC. CALL VMCMS('STATE GARFTEMP EXEC A',IRC) IF(IRC.NE.28)CALL VMCMS('ERASE GARFTEMP EXEC A',IRC) *** Write the EXEC to disk. CALL VMCMS('FILEDEF 12 CLEAR',IRC) WRITE(FILDEF,'(''FILEDEF 12 DISK GARFTEMP EXEC (RECFM F'', - '' LRECL '',I4)') LEN(EXEC) CALL VMCMS(FILDEF,IRC) IF(IRC.NE.0)THEN PRINT *,' !!!!!! DSNVMX WARNING : Non-zero return code'// - ' for the EXEC writing FILEDEF; no file opened.' RETURN ENDIF OPEN(UNIT=12,ERR=2020,IOSTAT=IOS) WRITE(12,'(A)',ERR=2010,IOSTAT=IOS) EXEC CLOSE(UNIT=12,ERR=2030,IOSTAT=IOS) *** Execute the EXEC. CALL VMCMS('EXEC GARFTEMP '//ARG(1:LEN(ARG)),IRC) *** Erase the EXEC. CALL VMCMS('ERASE GARFTEMP EXEC A',JRC) *** Successfull completion. IFAIL=0 RETURN *** Error handling. 2010 CONTINUE PRINT *,' !!!!!! DSNVMX WARNING : I/O error writing a'// - ' temporary exec to disk.' CALL INPIOS(IOS) RETURN 2020 CONTINUE PRINT *,' !!!!!! DSNVMX WARNING : I/O error opening a'// - ' temporary exec.' CALL INPIOS(IOS) RETURN 2030 CONTINUE PRINT *,' !!!!!! DSNVMX WARNING : I/O error closing a'// - ' temporary exec.' CALL INPIOS(IOS) END +PATCH,ALGEBRA. +DECK,ALGCAL. SUBROUTINE ALGCAL(INSTR,IFAIL) *----------------------------------------------------------------------- * ALGCAL - Handles external CALL statements in instruction lists. * (Last changed on 1/11/11.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. +SEQ,ALGDATA. +SEQ,CONSTANTS. +SEQ,MATDATA. +SEQ,GLOBALS. CHARACTER*(MXINCH) STRING CHARACTER*80 TITLE,FILE CHARACTER*29 REMARK CHARACTER*8 MEMBER,TYPE,DATE,TIME REAL PAR(MXFPAR),EPAR(MXFPAR),K3,DT LOGICAL EXIST INTEGER INSTR,IFAIL,IFAIL1,IFAIL2,IFAIL3,I,IAUX,NARG,IPROC,NC, - NC1,NCFILE,NCTYPE,NCREM,NCMEMB,MATSLT,ISY,IREY,ISEY, - ISIZ(1),IOS,NPAR,IA(MXVAR),IE(MXVAR) EXTERNAL MATSLT *** Assume the CALL will fail. IFAIL=1 *** Ensure the statement is a legitimate CALL. IF(INS(INSTR,2).NE.9.OR. - INS(INSTR,3).LT.0.OR.INS(INSTR,3).GT.MXARG)THEN IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ ALGCAL DEBUG : '', - '' Syntax of CALL statement '',I3,'' not valid'')') - INSTR RETURN ENDIF *** Some easy reference variables. NARG=INS(INSTR,3) IPROC=INS(INSTR,1) *** Execute the statements, first PRINT. IF(IPROC.EQ.-1)THEN WRITE(LUNOUT,'(/'' PRINT: ''/)') DO 10 I=1,NARG CALL OUTFMT(ARG(I),MODARG(I),STRING,NC,'LEFT') WRITE(LUNOUT,'('' Arg '',I3,'': '',A)') I,STRING(1:NC) 10 CONTINUE IF(NARG.EQ.0)WRITE(LUNOUT,'('' No arguments.'')') *** Time delay ELSEIF(IPROC.EQ.-2)THEN * Check arguments. IF(NARG.LE.0)THEN CALL TIMED(DT) PRINT *,' Time delay since previous call: ',DT,' sec.' ELSEIF(NARG.EQ.1.AND.ARGREF(1,1).LT.2)THEN CALL TIMED(ARG(1)) MODARG(1)=2 ELSE PRINT *,' !!!!!! ALGCAL WARNING : Can not'// - ' return the time delay.' RETURN ENDIF *** Cell procedures. ELSEIF(IPROC.LE.-11.AND.IPROC.GT.-20)THEN CALL CELCAL(INSTR,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! ALGCAL WARNING : Failure executing'// - ' a cell procedure call.' CALL LOGSAV(.FALSE.,'OK',IFAIL1) RETURN ELSE CALL LOGSAV(.TRUE.,'OK',IFAIL1) ENDIF *** Gas procedures. ELSEIF(IPROC.LE.-201.AND.IPROC.GT.-300)THEN CALL GASCAL(INSTR,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! ALGCAL WARNING : Failure executing'// - ' a gas procedure call.' CALL LOGSAV(.FALSE.,'OK',IFAIL1) RETURN ELSE CALL LOGSAV(.TRUE.,'OK',IFAIL1) ENDIF *** Electric field procedures. ELSEIF(IPROC.LE.-301.AND.IPROC.GE.-400)THEN CALL EFCCAL(INSTR,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! ALGCAL WARNING : Failure executing'// - ' a field procedure call.' CALL LOGSAV(.FALSE.,'OK',IFAIL1) RETURN ELSE CALL LOGSAV(.TRUE.,'OK',IFAIL1) ENDIF *** Time and progress logging. ELSEIF(IPROC.EQ.-401)THEN IF(NARG.NE.1.OR.MODARG(1).NE.1)THEN PRINT *,' !!!!!! ALGCAL WARNING : Incorrect'// - ' argument for TIME_LOGGING.' ELSE CALL STRBUF('READ',NINT(ARG(1)),STRING,NC1,IFAIL1) CALL TIMLOG(STRING(1:NC1)) ENDIF +SELF,IF=LINUX,MACOSX. *** Sleep ELSEIF(IPROC.EQ.-404)THEN IF(NARG.NE.1.OR.MODARG(1).NE.2)THEN PRINT *,' !!!!!! ALGCAL WARNING : Incorrect'// - ' argument for SLEEP.' ELSE CALL SLEEP(NINT(ARG(1))) ENDIF +SELF. *** Drift line procedures. ELSEIF(IPROC.LE.-501.AND.IPROC.GE.-600)THEN CALL DLCCAL(INSTR,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! ALGCAL WARNING : Failure executing'// - ' a transport procedure call.' CALL LOGSAV(.FALSE.,'OK',IFAIL1) RETURN ELSE CALL LOGSAV(.TRUE.,'OK',IFAIL1) ENDIF *** Histogram procedures. ELSEIF(IPROC.LE.-601.AND.IPROC.GT.-700)THEN CALL HISCAL(INSTR,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! ALGCAL WARNING : Failure executing'// - ' a histogram procedure call.' CALL LOGSAV(.FALSE.,'OK',IFAIL1) RETURN ELSE CALL LOGSAV(.TRUE.,'OK',IFAIL1) ENDIF *** Utility procedures. ELSEIF(IPROC.LE.-701.AND.IPROC.GT.-800)THEN CALL ROUCAL(INSTR,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! ALGCAL WARNING : Failure executing'// - ' a procedure call.' RETURN ENDIF *** Plotting calls. ELSEIF(IPROC.LE.-801.AND.IPROC.GE.-900)THEN CALL GRACAL(INSTR,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! ALGCAL WARNING : Failure executing'// - ' a graphics procedure call.' RETURN ENDIF *** String calls. ELSEIF(IPROC.LE.-901.AND.IPROC.GE.-1000)THEN CALL STRCAL(INSTR,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! ALGCAL WARNING : Failure executing'// - ' a string procedure call.' RETURN ENDIF *** Determine type of a variable. ELSEIF(IPROC.EQ.-50)THEN * Check arguments. IF(NARG.NE.2.OR.ARGREF(2,1).GE.2)THEN PRINT *,' !!!!!! ALGCAL WARNING : Incorrect set'// - ' of arguments for INQUIRE_TYPE.' RETURN ENDIF * Set string depending on the argument type. IF(MODARG(1).EQ.1)THEN STRING='String' NC=6 ELSEIF(MODARG(1).EQ.2)THEN STRING='Number' NC=6 ELSEIF(MODARG(1).EQ.3)THEN STRING='Logical' NC=7 ELSEIF(MODARG(1).EQ.4)THEN STRING='Histogram' NC=9 ELSEIF(MODARG(1).EQ.5)THEN STRING='Matrix' NC=6 ELSEIF(MODARG(1).EQ.0)THEN STRING='Undefined' NC=9 ELSE STRING='# Invalid' NC=9 ENDIF * Store the string. CALL ALGREU(NINT(ARG(2)),MODARG(2),ARGREF(2,1)) CALL STRBUF('STORE',IAUX,STRING(1:NC),NC,IFAIL1) ARG(2)=REAL(IAUX) MODARG(2)=1 * Error processing. IF(IFAIL1.NE.0)PRINT *,' !!!!!! ALGCAL WARNING : Unable'// - ' to store the variable type.' *** Determine whether a file exists. ELSEIF(IPROC.EQ.-51)THEN * Check arguments. IF(NARG.NE.2.OR.ARGREF(2,1).GE.2.OR.MODARG(1).NE.1)THEN PRINT *,' !!!!!! ALGCAL WARNING : Incorrect set'// - ' of arguments for INQUIRE_FILE.' RETURN ENDIF * Fetch the file name. CALL STRBUF('READ',NINT(ARG(1)),FILE,NCFILE,IFAIL1) * Determine whether the file exists. IF(IFAIL1.EQ.0)THEN CALL DSNINQ(FILE,NCFILE,EXIST) ELSE PRINT *,' !!!!!! ALGCAL WARNING : Unable'// - ' to fetch the file name.' EXIST=.FALSE. ENDIF * Clear the storage space previously occupied by Arg 2. CALL ALGREU(NINT(ARG(2)),MODARG(2),ARGREF(2,1)) * Set the result. IF(EXIST)THEN ARG(2)=1 ELSE ARG(2)=0 ENDIF MODARG(2)=3 *** Determine whether a member exists. ELSEIF(IPROC.EQ.-52)THEN * Check arguments. IF(NARG.LT.4.OR.NARG.GT.7.OR. - MODARG(1).NE.1.OR.MODARG(2).NE.1.OR.MODARG(3).NE.1.OR. - ARGREF(4,1).GE.2.OR. - (NARG.GE.5.AND.ARGREF(5,1).GE.2).OR. - (NARG.GE.6.AND.ARGREF(6,1).GE.2).OR. - (NARG.GE.7.AND.ARGREF(7,1).GE.2))THEN PRINT *,' !!!!!! ALGCAL WARNING : Incorrect set'// - ' of arguments for INQUIRE_MEMBER.' RETURN ENDIF * Fetch the file, member and type. CALL STRBUF('READ',NINT(ARG(1)),FILE,NCFILE,IFAIL1) CALL STRBUF('READ',NINT(ARG(2)),MEMBER,NCMEMB,IFAIL2) CALL STRBUF('READ',NINT(ARG(3)),TYPE,NCTYPE,IFAIL3) CALL CLTOU(TYPE) * Preset the remark, date and time. REMARK='< none >' NCREM=8 DATE='Unknown' TIME='Unknown' * Determine whether the file exists. IF(IFAIL1.EQ.0.AND.IFAIL2.EQ.0.AND.IFAIL3.EQ.0)THEN CALL DSNINQ(FILE,NCFILE,EXIST) ELSE PRINT *,' !!!!!! ALGCAL WARNING : Unable to fetch'// - ' file, member or type; declared not to exist.' EXIST=.FALSE. ENDIF * Open the file and see whether the member exists. IF(EXIST)THEN CALL DSNOPN(FILE,NCFILE,12,'READ-LIBRARY',IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! ALGCAL WARNING : Unable to'// - ' open the file; declared not to exist.' EXIST=.FALSE. ELSE CALL DSNLOC(MEMBER,NCMEMB,TYPE,12,EXIST,'RESPECT') IF(EXIST)THEN READ(12,'(10X,A8,4X,A8,1X,A8,11X,A29,1X)', - END=2000,ERR=2010,IOSTAT=IOS) - DATE,TIME,MEMBER,REMARK DO 20 I=LEN(REMARK),1,-1 IF(REMARK(I:I).NE.' ')THEN NCREM=I GOTO 30 ENDIF 20 CONTINUE NCREM=1 30 CONTINUE DO 40 I=LEN(MEMBER),1,-1 IF(MEMBER(I:I).NE.' ')THEN NCMEMB=I GOTO 50 ENDIF 40 CONTINUE NCMEMB=1 50 CONTINUE ENDIF ENDIF CLOSE(UNIT=12,STATUS='KEEP',ERR=2030,IOSTAT=IOS) ENDIF * Clear the storage space. CALL ALGREU(NINT(ARG(4)),MODARG(4),ARGREF(4,1)) IF(EXIST)THEN IF(ARGREF(2,1).LE.1) - CALL ALGREU(NINT(ARG(2)),MODARG(2),ARGREF(2,1)) IF(NARG.GE.5) - CALL ALGREU(NINT(ARG(5)),MODARG(5),ARGREF(5,1)) IF(NARG.GE.6) - CALL ALGREU(NINT(ARG(6)),MODARG(6),ARGREF(6,1)) IF(NARG.GE.7) - CALL ALGREU(NINT(ARG(7)),MODARG(7),ARGREF(7,1)) ENDIF * Set the result, first the updated member name. IF(EXIST.AND.ARGREF(2,1).LE.1)THEN CALL STRBUF('STORE',IAUX,MEMBER(1:NCMEMB),NCMEMB, - IFAIL1) ARG(2)=REAL(IAUX) MODARG(2)=1 ENDIF * The existence flag. IF(EXIST)THEN ARG(4)=1 ELSE ARG(4)=0 ENDIF MODARG(4)=3 * The remark. IF(EXIST.AND.NARG.GE.5)THEN CALL STRBUF('STORE',IAUX,REMARK(1:NCREM),NCREM,IFAIL1) ARG(5)=REAL(IAUX) MODARG(5)=1 ENDIF * Date and time. IF(EXIST.AND.NARG.GE.6)THEN CALL STRBUF('STORE',IAUX,DATE,8,IFAIL1) ARG(6)=REAL(IAUX) MODARG(6)=1 ENDIF IF(EXIST.AND.NARG.GE.7)THEN CALL STRBUF('STORE',IAUX,TIME,8,IFAIL1) ARG(7)=REAL(IAUX) MODARG(7)=1 ENDIF *** List objects. ELSEIF(IPROC.EQ.-53)THEN IF(NARG.NE.0)PRINT *,' !!!!!! ALGCAL WARNING : The'// - ' LIST_OBJECTS procedure has no arguments; ignored.' CALL BOOK('LIST',' ',' ',IFAIL) *** Fit a Gaussian to a histogram. ELSEIF(IPROC.EQ.-60.AND.MODARG(1).EQ.4)THEN * Check number and type of arguments. IF(ARGREF(2,1).GE.2.OR. - ARGREF(3,1).GE.2.OR.ARGREF(4,1).GE.2.OR. - (NARG.GE.5.AND.ARGREF(5,1).GE.2).OR. - (NARG.GE.6.AND.ARGREF(6,1).GE.2).OR. - (NARG.GE.7.AND.ARGREF(7,1).GE.2).OR. - (NARG.GE.8.AND.MODARG(8).NE.1).OR. - NARG.LT.4.OR.NARG.GT.8)THEN PRINT *,' !!!!!! ALGCAL WARNING : Incorrect argument'// - ' list provided for FIT_GAUSSIAN.' RETURN ENDIF * Fetch the option string. IF(NARG.GE.8)THEN CALL STRBUF('READ',NINT(ARG(8)),TITLE,NC,IFAIL1) CALL CLTOU(TITLE(1:NC)) ELSE TITLE=' ' NC=1 ENDIF * Clear previous use of storage for the results. CALL ALGREU(NINT(ARG(2)),MODARG(2),ARGREF(2,1)) CALL ALGREU(NINT(ARG(3)),MODARG(3),ARGREF(3,1)) CALL ALGREU(NINT(ARG(4)),MODARG(4),ARGREF(4,1)) IF(NARG.GE.5)CALL ALGREU(NINT(ARG(5)),MODARG(5),ARGREF(5,1)) IF(NARG.GE.6)CALL ALGREU(NINT(ARG(6)),MODARG(6),ARGREF(6,1)) IF(NARG.GE.7)CALL ALGREU(NINT(ARG(7)),MODARG(7),ARGREF(7,1)) * Perform the fit. CALL HISFNR(NINT(ARG(1)),TITLE(1:NC), - ARG(2),ARG(3),ARG(4),ARG(5),ARG(6),ARG(7),IFAIL1) IF(IFAIL1.EQ.0)THEN MODARG(2)=2 MODARG(3)=2 MODARG(4)=2 MODARG(5)=2 MODARG(6)=2 MODARG(7)=2 ELSE MODARG(2)=0 MODARG(3)=0 MODARG(4)=0 MODARG(5)=0 MODARG(6)=0 MODARG(7)=0 ENDIF * Check the error flag. IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! ALGCAL WARNING : The fit'// - ' was not successful.' CALL LOGSAV(.FALSE.,'OK',IFAIL1) RETURN ELSE CALL LOGSAV(.TRUE.,'OK',IFAIL1) ENDIF *** Fit a Gaussian to a set of matrices. ELSEIF(IPROC.EQ.-60.AND.MODARG(1).EQ.5)THEN * Check number and type of arguments. IF(NARG.LT.6.OR.NARG.GT.10.OR. - MODARG(2).NE.5.OR. - (MODARG(3).NE.2.AND.MODARG(3).NE.5).OR. - ARGREF(4,1).GE.2.OR. - ARGREF(5,1).GE.2.OR.ARGREF(6,1).GE.2.OR. - (NARG.GE.7.AND.ARGREF(7,1).GE.2).OR. - (NARG.GE.8.AND.ARGREF(8,1).GE.2).OR. - (NARG.GE.9.AND.ARGREF(9,1).GE.2).OR. - (NARG.GE.10.AND.MODARG(10).NE.1))THEN PRINT *,' !!!!!! ALGCAL WARNING : Incorrect argument'// - ' list provided for FIT_GAUSSIAN.' RETURN ENDIF * Fetch the option string, if present. IF(NARG.GE.10)THEN CALL STRBUF('READ',NINT(ARG(10)),TITLE,NC,IFAIL1) CALL CLTOU(TITLE(1:NC)) ELSE TITLE=' ' NC=1 ENDIF * Clear previous use of storage for the results. CALL ALGREU(NINT(ARG(4)),MODARG(4),ARGREF(4,1)) CALL ALGREU(NINT(ARG(5)),MODARG(5),ARGREF(5,1)) CALL ALGREU(NINT(ARG(6)),MODARG(6),ARGREF(6,1)) IF(NARG.GE.7)CALL ALGREU(NINT(ARG(7)),MODARG(7),ARGREF(7,1)) IF(NARG.GE.8)CALL ALGREU(NINT(ARG(8)),MODARG(8),ARGREF(8,1)) IF(NARG.GE.9)CALL ALGREU(NINT(ARG(9)),MODARG(9),ARGREF(9,1)) * Expand the error, if required, taking dimensions from the Y vector. IF(MODARG(3).EQ.2)THEN ISY=MATSLT(NINT(ARG(2))) IF(ISY.GE.0)THEN ISIZ(1)=MLEN(ISY) ELSE ISIZ(1)=1 ENDIF CALL MATADM('ALLOCATE',IREY,1,ISIZ,MODARG(3),IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! ALGCAL WARNING : Unable to'// - ' allocate an error array; no fit.' RETURN ENDIF ISEY=MATSLT(IREY) IF(ISEY.LE.0)THEN PRINT *,' !!!!!! ALGCAL WARNING : Unable to'// - ' locate an error array; no fit.' RETURN ENDIF DO 67 I=1,ISIZ(1) MVEC(MORG(ISEY)+I)=ARG(3) 67 CONTINUE ELSE IREY=NINT(ARG(3)) ENDIF * Perform the fit. CALL MATFNR(NINT(ARG(1)),NINT(ARG(2)),IREY, - TITLE(1:NC),ARG(4),ARG(5),ARG(6),ARG(7),ARG(8),ARG(9), - IFAIL1) IF(IFAIL1.EQ.0)THEN MODARG(4)=2 MODARG(5)=2 MODARG(6)=2 MODARG(7)=2 MODARG(8)=2 MODARG(9)=2 ELSE MODARG(4)=0 MODARG(5)=0 MODARG(6)=0 MODARG(7)=0 MODARG(8)=0 MODARG(9)=0 ENDIF * Delete the error array after use. IF(MODARG(3).EQ.2) - CALL MATADM('DELETE',IREY,1,ISIZ,MODARG(3),IFAIL2) * Check the error flag. IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! ALGCAL WARNING : The fit'// - ' was not successful.' CALL LOGSAV(.FALSE.,'OK',IFAIL1) RETURN ELSE CALL LOGSAV(.TRUE.,'OK',IFAIL1) ENDIF *** Attempt to fit a Gaussian to something else. ELSEIF(IPROC.EQ.-60)THEN PRINT *,' !!!!!! ALGCAL WARNING : Incorrect data type for'// - ' a Gaussian fit ; no fit.' RETURN *** Fit a polynomial to a histogram. ELSEIF(IPROC.EQ.-61.AND.MODARG(1).EQ.4)THEN * Check number and type of arguments. IF(NARG.LT.3.OR. - (MODARG(NARG).EQ.1.AND.NARG.NE.2*(NARG/2)).OR. - (MODARG(NARG).NE.1.AND.NARG.EQ.2*(NARG/2)))THEN PRINT *,' !!!!!! ALGCAL WARNING : Incorrect argument'// - ' list provided for FIT_POLYNOMIAL.' RETURN ENDIF * Establish number of parameters. IF(MODARG(NARG).EQ.1)THEN NPAR=NARG/2-1 ELSE NPAR=(NARG-1)/2 ENDIF IF(NPAR.GT.MXFPAR.OR.NPAR.LT.1)THEN PRINT *,' !!!!!! ALGCAL WARNING : Number of fit'// - ' parameters out of range; no fit.' RETURN ENDIF * Fetch the option string, if present. IF(MODARG(NARG).EQ.1)THEN CALL STRBUF('READ',NINT(ARG(NARG)),TITLE,NC,IFAIL1) CALL CLTOU(TITLE(1:NC)) ELSE TITLE=' ' NC=1 ENDIF * Clear previous use of storage for the results. DO 60 I=2,1+2*NPAR IF(ARGREF(I,1).GE.2)THEN PRINT *,' !!!!!! ALGCAL WARNING : An output argument'// - ' of FIT_POLYNOMIAL can not be modified; no fit.' RETURN ENDIF CALL ALGREU(NINT(ARG(I)),MODARG(I),ARGREF(I,1)) 60 CONTINUE * Perform the fit. CALL HISFPL(NINT(ARG(1)),TITLE(1:NC),PAR,EPAR,NPAR,IFAIL1) * Return the results. DO 70 I=1,NPAR IF(IFAIL1.EQ.0)THEN ARG(1+I)=PAR(I) MODARG(1+I)=2 ARG(NPAR+1+I)=EPAR(I) MODARG(NPAR+1+I)=2 ELSE ARG(1+I)=0 MODARG(1+I)=0 ARG(NPAR+1+I)=0 MODARG(NPAR+1+I)=0 ENDIF 70 CONTINUE * Check the error flag. IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! ALGCAL WARNING : The fit'// - ' was not successful.' CALL LOGSAV(.FALSE.,'OK',IFAIL1) RETURN ELSE CALL LOGSAV(.TRUE.,'OK',IFAIL1) ENDIF *** Fit a polynomial to a set of matrices. ELSEIF(IPROC.EQ.-61.AND.MODARG(1).EQ.5)THEN * Check number and type of arguments. IF(NARG.LT.5.OR. - MODARG(2).NE.5.OR. - (MODARG(3).NE.2.AND.MODARG(3).NE.5).OR. - (MODARG(NARG).EQ.1.AND.NARG.NE.2*(NARG/2)).OR. - (MODARG(NARG).NE.1.AND.NARG.EQ.2*(NARG/2)))THEN PRINT *,' !!!!!! ALGCAL WARNING : Incorrect argument'// - ' list provided for FIT_POLYNOMIAL.' RETURN ENDIF * Establish number of parameters. IF(MODARG(NARG).EQ.1)THEN NPAR=NARG/2-2 ELSE NPAR=(NARG-1)/2-1 ENDIF IF(NPAR.GT.MXFPAR.OR.NPAR.LT.1)THEN PRINT *,' !!!!!! ALGCAL WARNING : Number of fit'// - ' parameters out of range; no fit.' RETURN ENDIF * Fetch the option string, if present. IF(MODARG(NARG).EQ.1)THEN CALL STRBUF('READ',NINT(ARG(NARG)),TITLE,NC,IFAIL1) CALL CLTOU(TITLE(1:NC)) ELSE TITLE=' ' NC=1 ENDIF * Clear previous use of storage for the results. DO 65 I=4,3+2*NPAR IF(ARGREF(I,1).GE.2)THEN PRINT *,' !!!!!! ALGCAL WARNING : An output argument'// - ' of FIT_POLYNOMIAL can not be modified; no fit.' RETURN ENDIF CALL ALGREU(NINT(ARG(I)),MODARG(I),ARGREF(I,1)) 65 CONTINUE * Expand the error, if required, taking dimensions from the Y vector. IF(MODARG(3).EQ.2)THEN ISY=MATSLT(NINT(ARG(2))) IF(ISY.GE.0)THEN ISIZ(1)=MLEN(ISY) ELSE ISIZ(1)=1 ENDIF CALL MATADM('ALLOCATE',IREY,1,ISIZ,MODARG(3),IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! ALGCAL WARNING : Unable to'// - ' allocate an error array; no fit.' RETURN ENDIF ISEY=MATSLT(IREY) IF(ISEY.LE.0)THEN PRINT *,' !!!!!! ALGCAL WARNING : Unable to'// - ' locate an error array; no fit.' RETURN ENDIF DO 66 I=1,ISIZ(1) MVEC(MORG(ISEY)+I)=ARG(3) 66 CONTINUE ELSE IREY=NINT(ARG(3)) ENDIF * Perform the fit. CALL MATFPL(NINT(ARG(1)),NINT(ARG(2)),IREY, - TITLE(1:NC),PAR,EPAR,NPAR,IFAIL1) * Return the results. DO 75 I=1,NPAR IF(IFAIL1.EQ.0)THEN ARG(3+I)=PAR(I) MODARG(3+I)=2 ARG(NPAR+3+I)=EPAR(I) MODARG(NPAR+3+I)=2 ELSE ARG(3+I)=0 MODARG(3+I)=0 ARG(NPAR+3+I)=0 MODARG(NPAR+3+I)=0 ENDIF 75 CONTINUE * Delete the error array after use. IF(MODARG(3).EQ.2) - CALL MATADM('DELETE',IREY,1,ISIZ,MODARG(3),IFAIL2) * Check the error flag. IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! ALGCAL WARNING : The fit'// - ' was not successful.' CALL LOGSAV(.FALSE.,'OK',IFAIL1) RETURN ELSE CALL LOGSAV(.TRUE.,'OK',IFAIL1) ENDIF *** Attempt to fit a polynomial to something else. ELSEIF(IPROC.EQ.-61)THEN PRINT *,' !!!!!! ALGCAL WARNING : Incorrect data type for'// - ' a polynomial fit ; no fit.' RETURN *** Fit an exponential of a polynomial to a histogram. ELSEIF(IPROC.EQ.-62.AND.MODARG(1).EQ.4)THEN * Check number and type of arguments. IF(NARG.LT.3.OR. - (MODARG(NARG).EQ.1.AND.NARG.NE.2*(NARG/2)).OR. - (MODARG(NARG).NE.1.AND.NARG.EQ.2*(NARG/2)))THEN PRINT *,' !!!!!! ALGCAL WARNING : Incorrect argument'// - ' list provided for FIT_EXPONENTIAL.' RETURN ENDIF * Establish number of parameters. IF(MODARG(NARG).EQ.1)THEN NPAR=NARG/2-1 ELSE NPAR=(NARG-1)/2 ENDIF IF(NPAR.GT.MXFPAR.OR.NPAR.LT.1)THEN PRINT *,' !!!!!! ALGCAL WARNING : Number of fit'// - ' parameters out of range; no fit.' RETURN ENDIF * Fetch the option string, if present. IF(MODARG(NARG).EQ.1)THEN CALL STRBUF('READ',NINT(ARG(NARG)),TITLE,NC,IFAIL1) CALL CLTOU(TITLE(1:NC)) ELSE TITLE=' ' NC=1 ENDIF * Clear previous use of storage for the results. DO 260 I=2,1+2*NPAR IF(ARGREF(I,1).GE.2)THEN PRINT *,' !!!!!! ALGCAL WARNING : An output argument'// - ' of FIT_EXPONENTIAL can not be modified; no fit.' RETURN ENDIF CALL ALGREU(NINT(ARG(I)),MODARG(I),ARGREF(I,1)) 260 CONTINUE * Perform the fit. CALL HISFEX(NINT(ARG(1)),TITLE(1:NC),PAR,EPAR,NPAR,IFAIL1) * Return the results. DO 270 I=1,NPAR IF(IFAIL1.EQ.0)THEN ARG(1+I)=PAR(I) MODARG(1+I)=2 ARG(NPAR+1+I)=EPAR(I) MODARG(NPAR+1+I)=2 ELSE ARG(1+I)=0 MODARG(1+I)=0 ARG(NPAR+1+I)=0 MODARG(NPAR+1+I)=0 ENDIF 270 CONTINUE * Check the error flag. IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! ALGCAL WARNING : The fit'// - ' was not successful.' CALL LOGSAV(.FALSE.,'OK',IFAIL1) RETURN ELSE CALL LOGSAV(.TRUE.,'OK',IFAIL1) ENDIF *** Fit an exponential of a polynomial to a set of matrices. ELSEIF(IPROC.EQ.-62.AND.MODARG(1).EQ.5)THEN * Check number and type of arguments. IF(NARG.LT.5.OR. - MODARG(2).NE.5.OR. - (MODARG(3).NE.2.AND.MODARG(3).NE.5).OR. - (MODARG(NARG).EQ.1.AND.NARG.NE.2*(NARG/2)).OR. - (MODARG(NARG).NE.1.AND.NARG.EQ.2*(NARG/2)))THEN PRINT *,' !!!!!! ALGCAL WARNING : Incorrect argument'// - ' list provided for FIT_EXPONENTIAL.' RETURN ENDIF * Establish number of parameters. IF(MODARG(NARG).EQ.1)THEN NPAR=NARG/2-2 ELSE NPAR=(NARG-1)/2-1 ENDIF IF(NPAR.GT.MXFPAR.OR.NPAR.LT.1)THEN PRINT *,' !!!!!! ALGCAL WARNING : Number of fit'// - ' parameters out of range; no fit.' RETURN ENDIF * Fetch the option string, if present. IF(MODARG(NARG).EQ.1)THEN CALL STRBUF('READ',NINT(ARG(NARG)),TITLE,NC,IFAIL1) CALL CLTOU(TITLE(1:NC)) ELSE TITLE=' ' NC=1 ENDIF * Clear previous use of storage for the results. DO 265 I=4,3+2*NPAR IF(ARGREF(I,1).GE.2)THEN PRINT *,' !!!!!! ALGCAL WARNING : An output argument'// - ' of FIT_EXPONENTIAL can not be modified; no fit.' RETURN ENDIF CALL ALGREU(NINT(ARG(I)),MODARG(I),ARGREF(I,1)) 265 CONTINUE * Expand the error, if required, taking dimensions from the Y vector. IF(MODARG(3).EQ.2)THEN ISY=MATSLT(NINT(ARG(2))) IF(ISY.GE.0)THEN ISIZ(1)=MLEN(ISY) ELSE ISIZ(1)=1 ENDIF CALL MATADM('ALLOCATE',IREY,1,ISIZ,MODARG(3),IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! ALGCAL WARNING : Unable to'// - ' allocate an error array; no fit.' RETURN ENDIF ISEY=MATSLT(IREY) IF(ISEY.LE.0)THEN PRINT *,' !!!!!! ALGCAL WARNING : Unable to'// - ' locate an error array; no fit.' RETURN ENDIF DO 266 I=1,ISIZ(1) MVEC(MORG(ISEY)+I)=ARG(3) 266 CONTINUE ELSE IREY=NINT(ARG(3)) ENDIF * Perform the fit. CALL MATFEX(NINT(ARG(1)),NINT(ARG(2)),IREY, - TITLE(1:NC),PAR,EPAR,NPAR,IFAIL1) * Return the results. DO 275 I=1,NPAR IF(IFAIL1.EQ.0)THEN ARG(3+I)=PAR(I) MODARG(3+I)=2 ARG(NPAR+3+I)=EPAR(I) MODARG(NPAR+3+I)=2 ELSE ARG(3+I)=0 MODARG(3+I)=0 ARG(NPAR+3+I)=0 MODARG(NPAR+3+I)=0 ENDIF 275 CONTINUE * Delete the error array after use. IF(MODARG(3).EQ.2) - CALL MATADM('DELETE',IREY,1,ISIZ,MODARG(3),IFAIL2) * Check the error flag. IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! ALGCAL WARNING : The fit'// - ' was not successful.' CALL LOGSAV(.FALSE.,'OK',IFAIL1) RETURN ELSE CALL LOGSAV(.TRUE.,'OK',IFAIL1) ENDIF *** Attempt to fit an exponential of a polynomial to something else. ELSEIF(IPROC.EQ.-62)THEN PRINT *,' !!!!!! ALGCAL WARNING : Incorrect data type for'// - ' an exponential polynomial fit ; no fit.' RETURN *** Fit a Polya distribution to a histogram. ELSEIF(IPROC.EQ.-63.AND.MODARG(1).EQ.4)THEN * Check number and type of arguments. IF(NARG.LT.9.OR.NARG.GT.10.AND. - (NARG.GE.2.AND.ARGREF(2,1).GE.2).OR. - (NARG.GE.3.AND.ARGREF(3,1).GE.2).OR. - (NARG.GE.4.AND.ARGREF(4,1).GE.2).OR. - (NARG.GE.5.AND.ARGREF(5,1).GE.2).OR. - (NARG.GE.6.AND.ARGREF(6,1).GE.2).OR. - (NARG.GE.7.AND.ARGREF(7,1).GE.2).OR. - (NARG.GE.8.AND.ARGREF(8,1).GE.2).OR. - (NARG.GE.9.AND.ARGREF(9,1).GE.2).OR. - (NARG.EQ.10.AND.MODARG(NARG).NE.1))THEN PRINT *,' !!!!!! ALGCAL WARNING : Incorrect argument'// - ' list provided for FIT_POLYA.' RETURN ENDIF * Fetch the option string, if present. IF(MODARG(NARG).EQ.1)THEN CALL STRBUF('READ',NINT(ARG(NARG)),TITLE,NC,IFAIL1) CALL CLTOU(TITLE(1:NC)) ELSE TITLE=' ' NC=1 ENDIF * Clear previous use of storage for the results. DO 261 I=2,9 CALL ALGREU(NINT(ARG(I)),MODARG(I),ARGREF(I,1)) 261 CONTINUE * Perform the fit. CALL HISFPR(NINT(ARG(1)),TITLE(1:NC),ARG(2),ARG(3),ARG(4), - ARG(5),ARG(6),ARG(7),ARG(8),ARG(9),IFAIL1) IF(IFAIL1.EQ.0)THEN MODARG(2)=2 MODARG(3)=2 MODARG(4)=2 MODARG(5)=2 MODARG(6)=2 MODARG(7)=2 MODARG(8)=2 MODARG(9)=2 ELSE MODARG(2)=0 MODARG(3)=0 MODARG(4)=0 MODARG(5)=0 MODARG(6)=0 MODARG(7)=0 MODARG(8)=0 MODARG(9)=0 ENDIF * Check the error flag. IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! ALGCAL WARNING : The fit'// - ' was not successful.' CALL LOGSAV(.FALSE.,'OK',IFAIL1) RETURN ELSE CALL LOGSAV(.TRUE.,'OK',IFAIL1) ENDIF *** Fit a Polya distribution to a set of matrices. ELSEIF(IPROC.EQ.-63.AND.MODARG(1).EQ.5)THEN * Check number and type of arguments. IF(NARG.LT.11.OR.NARG.GT.12.AND. - MODARG(2).NE.5.OR. - (MODARG(3).NE.2.AND.MODARG(3).NE.5).OR. - (NARG.GE.4.AND.ARGREF(4,1).GE.2).OR. - (NARG.GE.5.AND.ARGREF(5,1).GE.2).OR. - (NARG.GE.6.AND.ARGREF(6,1).GE.2).OR. - (NARG.GE.7.AND.ARGREF(7,1).GE.2).OR. - (NARG.GE.8.AND.ARGREF(8,1).GE.2).OR. - (NARG.GE.9.AND.ARGREF(9,1).GE.2).OR. - (NARG.GE.10.AND.ARGREF(10,1).GE.2).OR. - (NARG.GE.11.AND.ARGREF(11,1).GE.2).OR. - (NARG.EQ.12.AND.MODARG(NARG).NE.1))THEN PRINT *,' !!!!!! ALGCAL WARNING : Incorrect argument'// - ' list provided for FIT_POLYA.' RETURN ENDIF * Fetch the option string, if present. IF(MODARG(NARG).EQ.1)THEN CALL STRBUF('READ',NINT(ARG(NARG)),TITLE,NC,IFAIL1) CALL CLTOU(TITLE(1:NC)) ELSE TITLE=' ' NC=1 ENDIF * Clear previous use of storage for the results. DO 267 I=4,11 CALL ALGREU(NINT(ARG(I)),MODARG(I),ARGREF(I,1)) 267 CONTINUE * Expand the error, if required, taking dimensions from the Y vector. IF(MODARG(3).EQ.2)THEN ISY=MATSLT(NINT(ARG(2))) IF(ISY.GE.0)THEN ISIZ(1)=MLEN(ISY) ELSE ISIZ(1)=1 ENDIF CALL MATADM('ALLOCATE',IREY,1,ISIZ,MODARG(3),IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! ALGCAL WARNING : Unable to'// - ' allocate an error array; no fit.' RETURN ENDIF ISEY=MATSLT(IREY) IF(ISEY.LE.0)THEN PRINT *,' !!!!!! ALGCAL WARNING : Unable to'// - ' locate an error array; no fit.' RETURN ENDIF DO 268 I=1,ISIZ(1) MVEC(MORG(ISEY)+I)=ARG(3) 268 CONTINUE ELSE IREY=NINT(ARG(3)) ENDIF * Perform the fit. CALL MATFPR(NINT(ARG(1)),NINT(ARG(2)),IREY,TITLE(1:NC), - ARG(4),ARG(5),ARG(6),ARG(7), - ARG(8),ARG(9),ARG(10),ARG(11),IFAIL1) IF(IFAIL1.EQ.0)THEN MODARG(4)=2 MODARG(5)=2 MODARG(6)=2 MODARG(7)=2 MODARG(8)=2 MODARG(9)=2 MODARG(10)=2 MODARG(11)=2 ELSE MODARG(4)=0 MODARG(5)=0 MODARG(6)=0 MODARG(7)=0 MODARG(8)=0 MODARG(9)=0 MODARG(10)=0 MODARG(11)=0 ENDIF * Delete the error array after use. IF(MODARG(3).EQ.2) - CALL MATADM('DELETE',IREY,1,ISIZ,MODARG(3),IFAIL2) * Check the error flag. IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! ALGCAL WARNING : The fit'// - ' was not successful.' CALL LOGSAV(.FALSE.,'OK',IFAIL1) RETURN ELSE CALL LOGSAV(.TRUE.,'OK',IFAIL1) ENDIF *** Attempt to fit an exponential of a polynomial to something else. ELSEIF(IPROC.EQ.-63)THEN PRINT *,' !!!!!! ALGCAL WARNING : Incorrect data type for'// - ' a Polya fit ; no fit.' RETURN *** Fit a function to an histogram. ELSEIF(IPROC.EQ.-64.AND.MODARG(1).EQ.4)THEN * Check number and type of arguments. IF(NARG.LT.4.OR.MODARG(2).NE.1.OR. - (MODARG(NARG).EQ.1.AND.NARG.EQ.2*(NARG/2)).OR. - (MODARG(NARG).NE.1.AND.NARG.NE.2*(NARG/2)))THEN PRINT *,' !!!!!! ALGCAL WARNING : Incorrect argument'// - ' list provided for FIT_FUNCTION.' RETURN ENDIF * Establish number of parameters. IF(MODARG(NARG).EQ.1)THEN NPAR=(NARG-3)/2 ELSE NPAR=(NARG-2)/2 ENDIF IF(NPAR.GT.MXFPAR.OR.NPAR.LT.1)THEN PRINT *,' !!!!!! ALGCAL WARNING : Number of fit'// - ' parameters out of range; no fit.' RETURN ENDIF * Fetch the function string. CALL STRBUF('READ',NINT(ARG(2)),FILE,NCFILE,IFAIL1) IF(NCFILE.LE.0)THEN PRINT *,' !!!!!! ALGCAL WARNING : Null string not'// - ' suitable as function; no fit.' RETURN ENDIF CALL CLTOU(FILE(1:NCFILE)) * Fetch the option string, if present. IF(MODARG(NARG).EQ.1)THEN CALL STRBUF('READ',NINT(ARG(NARG)),TITLE,NC,IFAIL1) CALL CLTOU(TITLE(1:NC)) ELSE TITLE=' ' NC=1 ENDIF * Determine the origin of the variables. DO 310 I=1,NPAR IF(ARGREF(2+I,1).GE.2.OR.ARGREF(2+NPAR+I,1).GE.2)THEN PRINT *,' !!!!!! ALGCAL WARNING : An output argument'// - ' of FIT_FUNCTION can not be modified; no fit.' RETURN ENDIF IA(I)=ARGREF(2+I,2) IE(I)=ARGREF(2+NPAR+I,2) CALL ALGREU(NINT(ARG(2+NPAR+I)),MODARG(2+NPAR+I), - ARGREF(2+NPAR+I,1)) 310 CONTINUE * Perform the fit. CALL HISFFU(NINT(ARG(1)),FILE(1:NCFILE),TITLE(1:NC), - IA,IE,NPAR,IFAIL1) * And ensure that the argument vector matches the globals list. DO 320 I=3,2+2*NPAR IF(IFAIL1.EQ.0)THEN ARG(I)=GLBVAL(ARGREF(I,2)) MODARG(I)=2 ELSE ARG(I)=0 MODARG(I)=0 ENDIF 320 CONTINUE * Check the error flag. IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! ALGCAL WARNING : The fit'// - ' was not successful.' CALL LOGSAV(.FALSE.,'OK',IFAIL1) RETURN ELSE CALL LOGSAV(.TRUE.,'OK',IFAIL1) ENDIF *** Fit a function to a set of matrices. ELSEIF(IPROC.EQ.-64.AND.MODARG(1).EQ.5)THEN * Check number and type of arguments. IF(NARG.LT.6.OR.MODARG(4).NE.1.OR. - MODARG(2).NE.5.OR. - (MODARG(3).NE.2.AND.MODARG(3).NE.5).OR. - (MODARG(NARG).NE.1.AND.NARG.NE.2*(NARG/2)).OR. - (MODARG(NARG).EQ.1.AND.NARG.EQ.2*(NARG/2)))THEN PRINT *,' !!!!!! ALGCAL WARNING : Incorrect argument'// - ' list provided for FIT_FUNCTION.' RETURN ENDIF * Establish number of parameters. IF(MODARG(NARG).EQ.1)THEN NPAR=(NARG-5)/2 ELSE NPAR=(NARG-4)/2 ENDIF IF(NPAR.GT.MXFPAR.OR.NPAR.LT.1)THEN PRINT *,' !!!!!! ALGCAL WARNING : Number of fit'// - ' parameters out of range; no fit.' RETURN ENDIF * Fetch the function string. CALL STRBUF('READ',NINT(ARG(4)),FILE,NCFILE,IFAIL1) IF(NCFILE.LE.0)THEN PRINT *,' !!!!!! ALGCAL WARNING : Null string not'// - ' suitable as function; no fit.' RETURN ENDIF CALL CLTOU(FILE(1:NCFILE)) * Fetch the option string, if present. IF(MODARG(NARG).EQ.1)THEN CALL STRBUF('READ',NINT(ARG(NARG)),TITLE,NC,IFAIL1) CALL CLTOU(TITLE(1:NC)) ELSE TITLE=' ' NC=1 ENDIF * Determine the origin of the variables. DO 330 I=1,NPAR IF(ARGREF(4+I,1).GE.2.OR.ARGREF(4+NPAR+I,1).GE.2)THEN PRINT *,' !!!!!! ALGCAL WARNING : An output argument'// - ' of FIT_FUNCTION can not be modified; no fit.' RETURN ENDIF IA(I)=ARGREF(4+I,2) IE(I)=ARGREF(4+NPAR+I,2) CALL ALGREU(NINT(ARG(4+NPAR+I)),MODARG(4+NPAR+I), - ARGREF(4+NPAR+I,1)) 330 CONTINUE * Expand the error, if required, taking dimensions from the Y vector. IF(MODARG(3).EQ.2)THEN ISY=MATSLT(NINT(ARG(2))) IF(ISY.GE.0)THEN ISIZ(1)=MLEN(ISY) ELSE ISIZ(1)=1 ENDIF CALL MATADM('ALLOCATE',IREY,1,ISIZ,MODARG(3),IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! ALGCAL WARNING : Unable to'// - ' allocate an error array; no fit.' RETURN ENDIF ISEY=MATSLT(IREY) IF(ISEY.LE.0)THEN PRINT *,' !!!!!! ALGCAL WARNING : Unable to'// - ' locate an error array; no fit.' RETURN ENDIF DO 350 I=1,ISIZ(1) MVEC(MORG(ISEY)+I)=ARG(3) 350 CONTINUE ELSE IREY=NINT(ARG(3)) ENDIF * Perform the fit. CALL MATFFU(NINT(ARG(1)),NINT(ARG(2)),IREY,FILE(1:NCFILE), - TITLE(1:NC),IA,IE,NPAR,IFAIL1) * And ensure that the argument vector matches the globals list. DO 340 I=5,4+2*NPAR IF(IFAIL1.EQ.0)THEN ARG(I)=GLBVAL(ARGREF(I,2)) MODARG(I)=2 ELSE ARG(I)=0 MODARG(I)=0 ENDIF 340 CONTINUE * Delete the error array after use. IF(MODARG(3).EQ.2) - CALL MATADM('DELETE',IREY,1,ISIZ,MODARG(3),IFAIL2) * Check the error flag. IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! ALGCAL WARNING : The fit'// - ' was not successful.' CALL LOGSAV(.FALSE.,'OK',IFAIL1) RETURN ELSE CALL LOGSAV(.TRUE.,'OK',IFAIL1) ENDIF *** Attempt to fit a function to something else. ELSEIF(IPROC.EQ.-64)THEN PRINT *,' !!!!!! ALGCAL WARNING : Incorrect data type for'// - ' a function fit ; no fit.' RETURN *** Fit a Mathieson distribution to an histogram. ELSEIF(IPROC.EQ.-65.AND.MODARG(1).EQ.4)THEN * Check number and type of arguments. IF((MODARG(NARG).EQ.1.AND.NARG.NE.9).OR. - (MODARG(NARG).NE.1.AND.NARG.NE.8).OR. - NARG.LT.8.OR.NARG.GT.9.OR. - MODARG(2).NE.2.OR. - (NARG.GE.3.AND.ARGREF(3,1).GE.2).OR. - (NARG.GE.4.AND.ARGREF(4,1).GE.2).OR. - (NARG.GE.5.AND.ARGREF(5,1).GE.2).OR. - (NARG.GE.6.AND.ARGREF(6,1).GE.2).OR. - (NARG.GE.7.AND.ARGREF(7,1).GE.2).OR. - (NARG.GE.8.AND.ARGREF(8,1).GE.2))THEN PRINT *,' !!!!!! ALGCAL WARNING : Incorrect argument'// - ' list provided for FIT_MATHIESON.' RETURN ENDIF * Fetch the option string, if present. IF(MODARG(NARG).EQ.1)THEN CALL STRBUF('READ',NINT(ARG(NARG)),TITLE,NC,IFAIL1) CALL CLTOU(TITLE(1:NC)) IF(INDEX(TITLE(1:NC),'NOFITK3').NE.0.AND. - MODARG(5).NE.2)THEN PRINT *,' !!!!!! ALGCAL WARNING : The K3'// - ' parameter is fixed but not numeric ;'// - ' fit not performed.' RETURN ENDIF ELSE TITLE=' ' NC=1 ENDIF * Initial setting of K3. IF(MODARG(5).EQ.2)THEN K3=ARG(5) ELSE K3=0.5 ENDIF * Clear up memory associated with modifiable variables. DO 269 I=3,8 CALL ALGREU(NINT(ARG(I)),MODARG(I),ARGREF(I,1)) 269 CONTINUE * Perform the fit. CALL HISFMS(NINT(ARG(1)),TITLE(1:NC),ARG(2), - ARG(4),ARG(3),K3,ARG(7),ARG(6),ARG(8),IFAIL1) * Check the error flag. IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! ALGCAL WARNING : The fit'// - ' was not successful.' MODARG(3)=0 MODARG(4)=0 MODARG(5)=0 MODARG(6)=0 MODARG(7)=0 MODARG(8)=0 CALL LOGSAV(.FALSE.,'OK',IFAIL1) RETURN ELSE MODARG(3)=2 MODARG(4)=2 ARG(5)=K3 MODARG(5)=2 MODARG(6)=2 MODARG(7)=2 MODARG(8)=2 CALL LOGSAV(.TRUE.,'OK',IFAIL1) ENDIF *** Fit a Mathieson distribution to a set of matrices. ELSEIF(IPROC.EQ.-65.AND.MODARG(1).EQ.5)THEN * Check number and type of arguments. IF((MODARG(NARG).NE.1.AND.NARG.EQ.11).OR. - NARG.LT.10.OR.NARG.GT.11.OR. - MODARG(2).NE.5.OR. - (MODARG(3).NE.2.AND.MODARG(3).NE.5).OR. - MODARG(4).NE.2.OR. - (NARG.GE.5.AND.ARGREF(5,1).GE.2).OR. - (NARG.GE.6.AND.ARGREF(6,1).GE.2).OR. - (NARG.GE.7.AND.ARGREF(7,1).GE.2).OR. - (NARG.GE.8.AND.ARGREF(8,1).GE.2).OR. - (NARG.GE.9.AND.ARGREF(9,1).GE.2).OR. - (NARG.GE.10.AND.ARGREF(10,1).GE.2))THEN PRINT *,' !!!!!! ALGCAL WARNING : Incorrect argument'// - ' list provided for FIT_MATHIESON.' RETURN ENDIF * Fetch the option string, if present. IF(MODARG(NARG).EQ.1)THEN CALL STRBUF('READ',NINT(ARG(NARG)),TITLE,NC,IFAIL1) CALL CLTOU(TITLE(1:NC)) IF(INDEX(TITLE(1:NC),'NOFITK3').NE.0.AND. - MODARG(7).NE.2)THEN PRINT *,' !!!!!! ALGCAL WARNING : The K3'// - ' parameter is fixed but not numeric ;'// - ' fit not performed.' RETURN ENDIF ELSE TITLE=' ' NC=1 ENDIF * Initial setting of K3. IF(MODARG(7).EQ.2)THEN K3=ARG(7) ELSE K3=0.5 ENDIF * Clear up memory associated with modifiable variables. DO 271 I=5,10 IF(I.LE.NARG) - CALL ALGREU(NINT(ARG(I)),MODARG(I),ARGREF(I,1)) 271 CONTINUE * Expand the error, if required, taking dimensions from the Y vector. IF(MODARG(3).EQ.2)THEN ISY=MATSLT(NINT(ARG(2))) IF(ISY.GE.0)THEN ISIZ(1)=MLEN(ISY) ELSE ISIZ(1)=1 ENDIF CALL MATADM('ALLOCATE',IREY,1,ISIZ,MODARG(3),IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! ALGCAL WARNING : Unable to'// - ' allocate an error array; no fit.' RETURN ENDIF ISEY=MATSLT(IREY) IF(ISEY.LE.0)THEN PRINT *,' !!!!!! ALGCAL WARNING : Unable to'// - ' locate an error array; no fit.' RETURN ENDIF DO 272 I=1,ISIZ(1) MVEC(MORG(ISEY)+I)=ARG(3) 272 CONTINUE ELSE IREY=NINT(ARG(3)) ENDIF * Perform the fit. CALL MATFMS(NINT(ARG(1)),NINT(ARG(2)),IREY, - TITLE(1:NC), - ARG(4),ARG(6),ARG(5),K3,ARG(9),ARG(8),ARG(10),IFAIL1) * Check the error flag. IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! ALGCAL WARNING : The fit'// - ' was not successful.' MODARG(5)=0 MODARG(6)=0 MODARG(7)=0 MODARG(8)=0 MODARG(9)=0 MODARG(10)=0 CALL LOGSAV(.FALSE.,'OK',IFAIL1) RETURN ELSE MODARG(5)=2 MODARG(6)=2 ARG(7)=K3 MODARG(7)=2 MODARG(8)=2 MODARG(9)=2 MODARG(10)=2 CALL LOGSAV(.TRUE.,'OK',IFAIL1) ENDIF *** Mathieson fit on other data types. ELSEIF(IPROC.EQ.-65)THEN PRINT *,' !!!!!! ALGCAL WARNING : Mathieson fits are'// - ' available for matrices and histograms; no fit.' RETURN *** Signal procedures. ELSEIF(IPROC.LE.-70.AND.IPROC.GT.-80)THEN CALL SIGCAL(INSTR,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! ALGCAL WARNING : Failure executing'// - ' a signal procedure call.' CALL LOGSAV(.FALSE.,'OK',IFAIL1) RETURN ELSE CALL LOGSAV(.TRUE.,'OK',IFAIL1) ENDIF *** Matrix procedures. ELSEIF(IPROC.LE.-80.AND.IPROC.GT.-110)THEN CALL MATCAL(INSTR,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! ALGCAL WARNING : Failure executing'// - ' a matrix procedure call.' CALL LOGSAV(.FALSE.,'OK',IFAIL1) RETURN ELSE CALL LOGSAV(.TRUE.,'OK',IFAIL1) ENDIF *** Other procedures are not known. ELSE PRINT *,' !!!!!! ALGCAL WARNING : Unknown procedure code'// - ' received.' CALL LOGSAV(.FALSE.,'OK',IFAIL1) RETURN ENDIF *** Things worked fine. IFAIL=0 RETURN *** I/O error handling. 2000 CONTINUE PRINT *,' !!!!!! ALGCAL WARNING : Unexpected EOF seen.' CALL INPIOS(IOS) RETURN 2010 CONTINUE PRINT *,' !!!!!! ALGCAL WARNING : I/O error encountered.' CALL INPIOS(IOS) RETURN 2030 CONTINUE PRINT *,' !!!!!! ALGCAL WARNING : Error closing a file.' CALL INPIOS(IOS) END +DECK,ALGCLR. SUBROUTINE ALGCLR(IENTRY) *----------------------------------------------------------------------- * ALGCLR - Clears an entry point, marking the storage space it * occupied as available - only effective after a gbc. * (Last changed on 1/ 2/01.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,ALGDATA. +SEQ,PRINTPLOT. LOGICAL FOUND INTEGER I,IENTRY *** Scan the entry point table to find the entry. FOUND=.FALSE. DO 10 I=1,NALGE IF(ALGENT(I,1).EQ.IENTRY)THEN FOUND=.TRUE. IF(ALGENT(I,2).EQ.0.AND.LDEBUG)THEN WRITE(LUNOUT,'('' ++++++ ALGCLR DEBUG : Entry'', - '' point '',I4,'' was already cleared.'')') IENTRY ELSEIF(LDEBUG)THEN WRITE(LUNOUT,'('' ++++++ ALGCLR DEBUG : Entry'', - '' point '',I4,'' cleared.'')') IENTRY ENDIF ALGENT(I,2)=0 ENDIF 10 CONTINUE *** Make sure the entry was indeed found. IF(.NOT.FOUND)PRINT *,' !!!!!! ALGCLR WARNING : The entry'// - ' point to be cleared does not exist; program bug.' END +DECK,ALGEDT. SUBROUTINE ALGEDT(VARLIS,NVAR,IENTRY,USE,NREXP) *----------------------------------------------------------------------- * ALGEDT - Reads instructions relating to formula manipulation. It * serves as a section but will rarely be used as such by the * normal user. * (Last changed on 27/11/10.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,ALGDATA. +SEQ,PRINTPLOT. INTEGER IBUF(4),INPCMP,INPTYP,MODVAR(MXVAR),MODRES(10),ILIST1, - ILIST,ILIST2,IFAIL,IFAIL1,IFAIL2,IFAIL3,IFAIL4,IENT,IENUPD, - IDEL,ICOPY,IENCLR,IEXEC,I,J,I1,I2,NCPRT,NC,NWORD,IENTRR, - IENDSP,NVAR,NREXP,IENTRY,INS0,INSC,IPRINT,NNRES,IENTNO, - NC1,NC2 CHARACTER*10 VARLIS(MXVAR) CHARACTER*30 AUX1,AUX2 CHARACTER*(MXINCH) STRING LOGICAL USE(MXVAR) REAL RES(10),VAR(MXVAR) EXTERNAL INPCMP,INPTYP +SELF,IF=AST. EXTERNAL ASTCCH +SELF. *** Define some output formats. 1010 FORMAT(' ',25X,'Reg(',I3,')=',E15.8:'; Reg(',I3,')=',E15.8) *** Print a header for this section. WRITE(*,'(''1'')') PRINT *,' ------------------------------------------------' PRINT *,' ---------- Algebra subsection ----------' PRINT *,' ------------------------------------------------' PRINT *,' ' *** Assign an entry point to the instruction list. IENTRY=IENTRL+1 IENTRL=IENTRL+1 IINS0=NINS+1 ICONS0=NCONS-1 * Check storage, perform a garbage collect if necessary. IF(NALGE+1.GT.MXALGE)THEN CALL ALGGBC IF(NALGE+1.GT.MXALGE)THEN PRINT *,' !!!!!! ALGEDT WARNING : Unable to allocate'// - ' an entry point to the instruction list.' PRINT *,' Increase MXALGE'// - ' and recompile the program.' IFAIL=1 IENTRY=-1 RETURN ENDIF ENDIF NALGE=NALGE+1 * Initialise the entry point record. ALGENT(NALGE,1)=IENTRY ALGENT(NALGE,2)=1 ALGENT(NALGE,3)=0 ALGENT(NALGE,4)=0 ALGENT(NALGE,5)=IINS0 ALGENT(NALGE,6)=0 ALGENT(NALGE,7)=NVAR ALGENT(NALGE,8)=ICONS0 ALGENT(NALGE,9)=0 ALGENT(NALGE,10)=0 *** Read instructions and make some simple checks. CALL INPPRM('Algebra','ADD-PRINT') 10 CONTINUE CALL INPGET CALL INPNUM(NWORD) +SELF,IF=AST. *** Set up ASTCCH as the condition handler. CALL LIB$ESTABLISH(ASTCCH) +SELF. CALL INPSTR(1,1,STRING,NC) IF(NWORD.EQ.0)GOTO 10 *** Avoid that this routine is left using '&'. IF(STRING(1:1).EQ.'&')THEN PRINT *,' !!!!!! ALGEDT WARNING : The section cannot be'// - ' left at this point; first type EXIT.' GOTO 10 ELSEIF(INDEX('$%?> Register('',I3,'')'')') - VARLIS(I),I 300 CONTINUE WRITE(LUNOUT,'('' '')') *** Unknown instruction. ELSE CALL INPSTR(1,1,STRING,NC) PRINT *,' !!!!!! ALGEDT WARNING : '//STRING(1:NC)//' is'// - ' not a valid instruction; ignored.' ENDIF *** Display error messages. CALL INPERR GOTO 10 END +DECK,ALGERR. SUBROUTINE ALGERR *----------------------------------------------------------------------- * ALGERR - Routine printing the number of arithmetic errors since the * last call from ALGPRE. * (Last changed on 22/11/06.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,ALGDATA. CHARACTER*20 AUX INTEGER I,NC,NATOT *** Count the errors. NATOT=0 DO 20 I=1,100 NATOT=NATOT+NAERR(I) 20 CONTINUE IF(NERR.LT.NATOT)NERR=NATOT *** One error. IF(NERR.EQ.1)THEN PRINT *,' !!!!!! ALGERR WARNING : One arithmetic error'// - ' has been detected.' *** Two errors. ELSEIF(NERR.EQ.2)THEN PRINT *,' !!!!!! ALGERR WARNING : Two arithmetic errors'// - ' have been detected.' *** More errors, format the number and print. ELSEIF(NERR.GT.2)THEN CALL OUTFMT(REAL(NERR),2,AUX,NC,'LEFT') PRINT *,' !!!!!! ALGERR WARNING : '//AUX(1:NC)// - ' arithmetic errors have been detected.' ENDIF *** Print detailed error messages. IF(NAERR(1).GT.0)WRITE(*,'(26X, - ''Division by zero: '',I5)') NAERR(1) IF(NAERR(2).GT.0)WRITE(*,'(26X, - ''Exponential overflow: '',I5)') NAERR(2) IF(NAERR(3).GT.0)WRITE(*,'(26X, - ''Exponential underflow: '',I5)') NAERR(3) IF(NAERR(4).GT.0)WRITE(*,'(26X, - ''Log of a non-positive number: '',I5)') NAERR(4) IF(NAERR(5).GT.0)WRITE(*,'(26X, - ''Arcsin or Arccos of a number > 1: '',I5)') NAERR(5) IF(NAERR(6).GT.0)WRITE(*,'(26X, - ''Square root of a negative number: '',I5)') NAERR(6) IF(NAERR(7).GT.0)WRITE(*,'(26X, - ''Arccosh of a number < 1: '',I5)') NAERR(7) IF(NAERR(8).GT.0)WRITE(*,'(26X, - ''Arctanh of a number outside <-1,1>: '',I5)') NAERR(8) IF(NAERR(9).GT.0)WRITE(*,'(26X, - ''Failure to store a string: '',I5)') NAERR(9) IF(NAERR(10).GT.0)WRITE(*,'(26X, - ''Unidentified operator code: '',I5)') NAERR(10) IF(NAERR(11).GT.0)WRITE(*,'(26X, - ''Undefined power raising: '',I5)') NAERR(11) IF(NAERR(12).GT.0)WRITE(*,'(26X, - ''Gamma of a number not > 0: '',I5)') NAERR(12) IF(NAERR(13).GT.0)WRITE(*,'(26X, - ''Gamma of a number > 25: '',I5)') NAERR(13) IF(NAERR(14).GT.0)WRITE(*,'(26X, - ''Random gamma requested for p <= 0: '',I5)') NAERR(14) IF(NAERR(15).GT.0)WRITE(*,'(26X, - ''Vavilov parameters out of range: '',I5)') NAERR(15) * Histogram related errors IF(NAERR(51).GT.0)WRITE(*,'(26X, - ''Invalid histogram reference: '',I5)') NAERR(51) IF(NAERR(52).GT.0)WRITE(*,'(26X, - ''Histogram not in use: '',I5)') NAERR(52) IF(NAERR(53).GT.0)WRITE(*,'(26X, - ''Histogram not yet auto-scaled: '',I5)') NAERR(53) IF(NAERR(54).GT.0)WRITE(*,'(26X, - ''Histograms have incompatible range: '',I5)') NAERR(54) * Matrix related errors IF(NAERR(61).GT.0)WRITE(*,'(26X, - ''Invalid matrix reference: '',I5)') NAERR(61) IF(NAERR(62).GT.0)WRITE(*,'(26X, - ''Matrices differ in dimension: '',I5)') NAERR(62) *** Whatever happens, reset the error counter. NERR=0 DO 10 I=1,100 NAERR(I)=0 10 CONTINUE END +DECK,ALGEXE. SUBROUTINE ALGEXE(IENTRY,VAR,MODVAR,NVAR,RES,MODRES,NNRES,IFAIL) *----------------------------------------------------------------------- * ALGEXE - Routine executing the instructions produced by ALGPRE. * (Last changed on 1/ 9/09.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,ALGDATA. +SEQ,GLOBALS. +SEQ,PRINTPLOT. REAL VAR(*),RES(*),EPS INTEGER MODVAR(*),MODRES(*),IENTRY,NVAR,NNRES,IFAIL,I,J,IENTNO, - INEXT,IDUM,NCDUM,IFAIL1 CHARACTER*1 DUMSTR PARAMETER(EPS=1.0E-5) *** Early returns mean evalution failed. IFAIL=1 *** Assign zero to all expected results. DO 40 I=1,NNRES RES(I)=0.0 MODRES(I)=0 40 CONTINUE *** Zero argument buffer. DO 160 I=1,MXARG ARG(I)=0.0 MODARG(I)=0 ARGREF(I,1)=0 ARGREF(I,2)=0 160 CONTINUE *** Locate the entry point. IENTNO=0 DO 30 I=1,NALGE IF(ALGENT(I,1).EQ.IENTRY)IENTNO=I 30 CONTINUE IF(IENTNO.EQ.0)THEN IF(LDEBUG)WRITE(LUNOUT,*) ' ++++++ ALGEXE DEBUG :'// - ' Requested entry point does not exist.' RETURN ENDIF IF(ALGENT(IENTNO,2).EQ.0.OR.ALGENT(IENTNO,3).EQ.0.OR. - ALGENT(IENTNO,7).GT.NVAR.OR. - (ALGENT(IENTNO,10).NE.0.AND.ALGENT(IENTNO,10).GT.NNRES))THEN IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ ALGEXE DEBUG :'', - '' List for entry point is not executable.''/ - 26X,''Serial number='',I4,'', Reference number='',I4/ - 26X,''In use='',I1,'', List correct='',I1, - '', Sequential='',I1/ - 26X,''First instruction='',I4,'', # instructions='',I4/ - 26X,''# variables expected='',I4,'' (given='',I4,'')''/ - 26X,''First constant='',I4,'', # constants='',I4/ - 26X,''# results from list='',I4,'' (expected='',I4, - '').'')') - IENTNO,(ALGENT(IENTNO,I),I=1,7),NVAR, - (ALGENT(IENTNO,I),I=8,10),NNRES RETURN ENDIF *** First assign the values of the variables to REG. DO 10 I=1,MXREG IF(I.LE.NVAR.AND.I.LE.ALGENT(IENTNO,7))THEN REG(I)=VAR(I) MODREG(I)=MODVAR(I) ELSE REG(I)=0 MODREG(I)=0 ENDIF 10 CONTINUE IFAIL=0 *** Execute all the instructions. INEXT=ALGENT(IENTNO,5)-1 20 CONTINUE INEXT=INEXT+1 *** Return at the end of the list and if INEXT has been set to 0. IF(INEXT.GT.ALGENT(IENTNO,5)+ALGENT(IENTNO,6)-1.OR. - INEXT.EQ.0)GOTO 3000 *** Do nothing statement IF(INS(INEXT,2).EQ.-1)THEN GOTO 20 *** Lines of the result-assignment type. ELSEIF(INS(INEXT,2).EQ.0)THEN IF(INS(INEXT,4).LT.1.OR.INS(INEXT,4).GT.NNRES)THEN IFAIL=1 IF(LDEBUG)WRITE(LUNOUT,'(1X,A,I3,A)') - ' ++++++ ALGEXE DEBUG : No room for result'// - ' produced at line ',INEXT,' in receiving array.' GOTO 3000 ELSE RES(INS(INEXT,4))=REG(INS(INEXT,3)) MODRES(INS(INEXT,4))=MODREG(INS(INEXT,3)) ENDIF *** GOTO statement. ELSEIF(INS(INEXT,2).EQ.7)THEN IF(ABS(REG(INS(INEXT,1))-1).LT.EPS)THEN INEXT=NINT(REG(INS(INEXT,3)))-1 ELSEIF(ABS(REG(INS(INEXT,1))).GT.EPS)THEN IF(LDEBUG)THEN WRITE(LUNOUT,'(2X,A)') '++++++ ALGEXE DEBUG :'// - ' Logical value error at the line:' CALL ALGPRT(INEXT,INEXT) WRITE(LUNOUT,'(26X,''Reg('',I3,'')='',E15.7, - ''; Reg('',I3,'')='',E15.7,/)') - INS(INEXT,1),REG(INS(INEXT,1)), - INS(INEXT,3),REG(INS(INEXT,3)) ENDIF IFAIL=1 GOTO 3000 ENDIF *** Arguments. ELSEIF(INS(INEXT,2).EQ.8)THEN IF(INS(INEXT,4).LE.0.OR.INS(INEXT,4).GT.MXARG)THEN IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ ALGEXE DEBUG :'', - '' Invalid argument # '',I3,'' found in line '', - I3,'':'')') INS(INEXT,4),INEXT IF(LDEBUG)CALL ALGPRT(INEXT,INEXT) IFAIL=1 GOTO 3000 ENDIF ARG(INS(INEXT,4))=REG(INS(INEXT,3)) MODARG(INS(INEXT,4))=MODREG(INS(INEXT,3)) ARGREF(INS(INEXT,4),1)=INS(INEXT,1) ARGREF(INS(INEXT,4),2)=INS(INEXT,3) *** Procedure calls. ELSEIF(INS(INEXT,2).EQ.9)THEN * Execute the procedure. CALL ALGCAL(INEXT,IFAIL1) IF(IFAIL1.NE.0)THEN NERR=NERR+1 IF(LDEBUG)THEN WRITE(LUNOUT,'(1X,A)') ' ++++++ ALGEXE'// - ' DEBUG : Procedure call error in:' CALL ALGPRT(INEXT,INEXT) WRITE(LUNOUT,'(26X,''Arguments:''/26X, - '' No Value Mode Ref1 Ref2'')') DO 170 I=1,INS(INEXT,3) WRITE(LUNOUT,'(26X,I5,2X,E12.5,3I5)') - I,ARG(I),MODARG(I),ARGREF(I,1),ARGREF(I,2) 170 CONTINUE ENDIF IFAIL=1 GOTO 3000 ENDIF * Back transfer of arguments to origin registers and variables. IF(LDEBUG)WRITE(LUNOUT,'(26X,''Arguments:''/26X, - '' No Value Mode Ref1 Ref2'')') DO 100 I=1,INS(INEXT,3) IF(LDEBUG)WRITE(LUNOUT,'(26X,I5,2X,E12.5,3I5)') - I,ARG(I),MODARG(I),ARGREF(I,1),ARGREF(I,2) IF(ARGREF(I,1).GE.2)GOTO 100 REG(ARGREF(I,2))=ARG(I) MODREG(ARGREF(I,2))=MODARG(I) IF(ARGREF(I,2).GE.1.AND. - ARGREF(I,2).LE.NVAR.AND. - ARGREF(I,2).LE.ALGENT(IENTNO,7))THEN C CALL ALGREU(NINT(ARG(I)),MODARG(I),ARGREF(I,1)) VAR(ARGREF(I,2))=ARG(I) MODVAR(ARGREF(I,2))=MODARG(I) ENDIF 100 CONTINUE *** RETURN, EXIT and QUIT instruction codes. ELSEIF(INS(INEXT,2).EQ.-9)THEN * Condition satisfied. IF(ABS(REG(INS(INEXT,1))-1).LT.EPS)THEN IF(INS(INEXT,3).EQ.0.OR.INS(INEXT,3).EQ.1)THEN INEXT=-1 ELSEIF(INS(INEXT,3).EQ.2)THEN CALL QUIT ELSE IF(LDEBUG)THEN WRITE(LUNOUT,'(2X,A)') - '++++++ ALGEXE DEBUG : Unrecognised'// - ' RETURN option seen in the line:' CALL ALGPRT(INEXT,INEXT) WRITE(LUNOUT,'(26X,''Reg('',I3,'')='',E15.7, - ''; Reg('',I3,'')='',E15.7,/)') - INS(INEXT,1),REG(INS(INEXT,1)), - INS(INEXT,3),REG(INS(INEXT,3)) ENDIF IFAIL=1 GOTO 3000 ENDIF * Invalid logical. ELSEIF(ABS(REG(INS(INEXT,1))).GT.EPS)THEN IF(LDEBUG)THEN WRITE(LUNOUT,'(2X,A)') '++++++ ALGEXE DEBUG :'// - ' Logical value error detected in the line:' CALL ALGPRT(INEXT,INEXT) WRITE(LUNOUT,'(26X,''Reg('',I3,'')='',E15.7, - ''; Reg('',I3,'')='',E15.7,/)') - INS(INEXT,1),REG(INS(INEXT,1)), - INS(INEXT,3),REG(INS(INEXT,3)) ENDIF IFAIL=1 GOTO 3000 ENDIF *** Algebraic instruction. ELSE IF((INS(INEXT,2).EQ.6.AND.MODREG(INS(INEXT,3)).EQ.0).OR. - (INS(INEXT,2).NE.6.AND.(MODREG(INS(INEXT,1)).EQ.0.OR. - MODREG(INS(INEXT,3)).EQ.0)))THEN CALL ALGEX0(INEXT,IFAIL) ELSEIF((INS(INEXT,2).EQ.6.AND.MODREG(INS(INEXT,3)).EQ.2).OR. - (INS(INEXT,2).NE.6.AND.MODREG(INS(INEXT,1)).EQ.2.AND. - MODREG(INS(INEXT,3)).EQ.2))THEN CALL ALGEX2(INEXT,IFAIL) ELSEIF((INS(INEXT,2).EQ.6.AND.MODREG(INS(INEXT,3)).EQ.3).OR. - (INS(INEXT,2).NE.6.AND.MODREG(INS(INEXT,1)).EQ.3.AND. - MODREG(INS(INEXT,3)).EQ.3))THEN CALL ALGEX3(INEXT,IFAIL) ELSEIF((INS(INEXT,2).EQ.6.AND.MODREG(INS(INEXT,3)).EQ.1).OR. - (INS(INEXT,2).NE.6.AND.MODREG(INS(INEXT,1)).EQ.1.AND. - MODREG(INS(INEXT,3)).EQ.1))THEN CALL ALGEX4(INEXT,IFAIL) ELSEIF((INS(INEXT,2).EQ.6.AND.MODREG(INS(INEXT,3)).EQ.4).OR. - (INS(INEXT,2).NE.6.AND.MODREG(INS(INEXT,1)).EQ.4.OR. - MODREG(INS(INEXT,3)).EQ.4))THEN CALL ALGEX5(INEXT,IFAIL) ELSEIF((INS(INEXT,2).EQ.6.AND.MODREG(INS(INEXT,3)).EQ.5).OR. - (INS(INEXT,2).NE.6.AND.MODREG(INS(INEXT,1)).EQ.5.OR. - MODREG(INS(INEXT,3)).EQ.5))THEN CALL ALGEX6(INEXT,IFAIL) ELSE PRINT *,' !!!!!! ALGEXE WARNING : Unable to evaluate'// - ' a variable because of mode incompatibility.' IF(LDEBUG)THEN WRITE(LUNOUT,'(26X,''Error occured in:'')') CALL ALGPRT(INEXT,INEXT) IF(INS(INEXT,2).NE.6)WRITE(LUNOUT,'(26X,''Reg '', - I3,'' = '',E15.7,'', Mode = '',I2,''.'')') - INS(INEXT,1),REG(INS(INEXT,1)), - MODREG(INS(INEXT,1)) WRITE(LUNOUT,'(26X,''Reg '', - I3,'' = '',E15.7,'', Mode = '',I2,''.'')') - INS(INEXT,3),REG(INS(INEXT,3)), - MODREG(INS(INEXT,3)) ENDIF GOTO 3000 ENDIF IF(IFAIL.NE.0)NERR=NERR+1 IF(IFAIL.NE.0.AND.LDEBUG)THEN WRITE(LUNOUT,'(1X,A)') ' ++++++ ALGEXE DEBUG :'// - ' Arithmetic error while evaluating:' CALL ALGPRT(INEXT,INEXT) IF(INS(INEXT,2).EQ.6)WRITE(LUNOUT,'(26X,''Reg('',I3, - '')='',E15.7,/)') INS(INEXT,3),REG(INS(INEXT,3)) IF(INS(INEXT,2).NE.6)WRITE(LUNOUT,'(26X,''Reg('',I3, - '')='',E15.7,''; Reg('',I3,'')='',E15.7,/)') - INS(INEXT,1),REG(INS(INEXT,1)), - INS(INEXT,3),REG(INS(INEXT,3)) IFAIL=1 GOTO 3000 ENDIF ENDIF *** Next instruction. GOTO 20 *** Clean up temporary strings. 3000 CONTINUE * Loop over the instructions. DO 50 I=ALGENT(IENTNO,5),ALGENT(IENTNO,5)+ALGENT(IENTNO,6)-1 * Skip results and control statements. IF(INS(I,2).EQ.0.OR.INS(I,2).EQ.8)GOTO 50 * Select lines that result in string type variables. IF(MODREG(INS(I,4)).NE.1)GOTO 70 DO 60 J=I+1,ALGENT(IENTNO,5)+ALGENT(IENTNO,6)-1 IF(INS(J,2).EQ.0.AND.INS(J,3).EQ.INS(I,4))GOTO 70 60 CONTINUE DO 150 J=1,NGLB IF(GLBMOD(J).NE.1)GOTO 150 IF(NINT(GLBVAL(J)).EQ.NINT(REG(INS(I,4))))GOTO 70 150 CONTINUE CALL STRBUF('DELETE',NINT(REG(INS(I,4))),DUMSTR,NCDUM,IFAIL1) 70 CONTINUE * Select lines that result in histogram type variables. IF(MODREG(INS(I,4)).NE.4)GOTO 80 DO 90 J=I+1,ALGENT(IENTNO,5)+ALGENT(IENTNO,6)-1 IF(INS(J,2).EQ.0.AND.INS(J,3).EQ.INS(I,4))GOTO 80 90 CONTINUE DO 110 J=1,NGLB IF(GLBMOD(J).NE.4)GOTO 110 IF(NINT(GLBVAL(J)).EQ.NINT(REG(INS(I,4))))GOTO 80 110 CONTINUE CALL HISADM('DELETE',NINT(REG(INS(I,4))),0,0.0,0.0,.FALSE.,IDUM) 80 CONTINUE * Select lines that result in matrix type variables. IF(MODREG(INS(I,4)).NE.5)GOTO 120 DO 130 J=I+1,ALGENT(IENTNO,5)+ALGENT(IENTNO,6)-1 IF(INS(J,2).EQ.0.AND.INS(J,3).EQ.INS(I,4))GOTO 120 130 CONTINUE DO 140 J=1,NGLB IF(GLBMOD(J).NE.5)GOTO 140 IF(NINT(GLBVAL(J)).EQ.NINT(REG(INS(I,4))))GOTO 120 140 CONTINUE CALL MATADM('DELETE',NINT(REG(INS(I,4))),0,IDUM,IDUM,IFAIL1) 120 CONTINUE * Next instruction. 50 CONTINUE END +DECK,AL2EXE. SUBROUTINE AL2EXE(IENTRY,VAR,MODVAR,NVAR,RES,MODRES,NNRES,IFAIL) *----------------------------------------------------------------------- * AL2EXE - Copy of ALGEXE, to avoid recursive calls. * (Last changed on 1/ 9/09.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,ALGDATA. +SEQ,GLOBALS. +SEQ,PRINTPLOT. REAL VAR(*),RES(*),EPS INTEGER MODVAR(*),MODRES(*),IENTRY,NVAR,NNRES,IFAIL,I,J,IENTNO, - INEXT,IDUM,NCDUM,IFAIL1 CHARACTER*1 DUMSTR PARAMETER(EPS=1.0E-5) *** Early returns mean evalution failed. IFAIL=1 *** Save the current environment. CALL ALGSTC *** Assign zero to all expected results. DO 40 I=1,NNRES RES(I)=0.0 MODRES(I)=0 40 CONTINUE *** Zero argument buffer. DO 160 I=1,MXARG ARG(I)=0.0 MODARG(I)=0 ARGREF(I,1)=0 ARGREF(I,2)=0 160 CONTINUE *** Locate the entry point. IENTNO=0 DO 30 I=1,NALGE IF(ALGENT(I,1).EQ.IENTRY)IENTNO=I 30 CONTINUE IF(IENTNO.EQ.0)THEN IF(LDEBUG)WRITE(LUNOUT,*) ' ++++++ AL2EXE DEBUG :'// - ' Requested entry point does not exist.' CALL ALGUST RETURN ENDIF IF(ALGENT(IENTNO,2).EQ.0.OR.ALGENT(IENTNO,3).EQ.0.OR. - ALGENT(IENTNO,7).GT.NVAR.OR. - (ALGENT(IENTNO,10).NE.0.AND.ALGENT(IENTNO,10).GT.NNRES))THEN IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ AL2EXE DEBUG :'', - '' List for entry point is not executable.''/ - 26X,''Serial number='',I4,'', Reference number='',I4/ - 26X,''In use='',I1,'', List correct='',I1, - '', Sequential='',I1/ - 26X,''First instruction='',I4,'', # instructions='',I4/ - 26X,''# variables expected='',I4,'' (given='',I4,'')''/ - 26X,''First constant='',I4,'', # constants='',I4/ - 26X,''# results from list='',I4,'' (expected='',I4, - '').'')') - IENTNO,(ALGENT(IENTNO,I),I=1,7),NVAR, - (ALGENT(IENTNO,I),I=8,10),NNRES CALL ALGUST RETURN ENDIF *** First assign the values of the variables to REG. DO 10 I=1,MXREG IF(I.LE.NVAR.AND.I.LE.ALGENT(IENTNO,7))THEN REG(I)=VAR(I) MODREG(I)=MODVAR(I) ELSE REG(I)=0 MODREG(I)=0 ENDIF 10 CONTINUE IFAIL=0 *** Execute all the instructions. INEXT=ALGENT(IENTNO,5)-1 20 CONTINUE INEXT=INEXT+1 *** Return at the end of the list and if INEXT has been set to 0. IF(INEXT.GT.ALGENT(IENTNO,5)+ALGENT(IENTNO,6)-1.OR. - INEXT.EQ.0)GOTO 3000 *** Do nothing statement IF(INS(INEXT,2).EQ.-1)THEN GOTO 20 *** Lines of the result-assignment type. ELSEIF(INS(INEXT,2).EQ.0)THEN IF(INS(INEXT,4).LT.1.OR.INS(INEXT,4).GT.NNRES)THEN IFAIL=1 IF(LDEBUG)WRITE(LUNOUT,'(1X,A,I3,A)') - ' ++++++ AL2EXE DEBUG : No room for result'// - ' produced at line ',INEXT,' in receiving array.' GOTO 3000 ELSE RES(INS(INEXT,4))=REG(INS(INEXT,3)) MODRES(INS(INEXT,4))=MODREG(INS(INEXT,3)) ENDIF *** GOTO statement. ELSEIF(INS(INEXT,2).EQ.7)THEN IF(ABS(REG(INS(INEXT,1))-1).LT.EPS)THEN INEXT=NINT(REG(INS(INEXT,3)))-1 ELSEIF(ABS(REG(INS(INEXT,1))).GT.EPS)THEN IF(LDEBUG)THEN WRITE(LUNOUT,'(2X,A)') '++++++ AL2EXE DEBUG :'// - ' Logical value error at the line:' CALL ALGPRT(INEXT,INEXT) WRITE(LUNOUT,'(26X,''Reg('',I3,'')='',E15.7, - ''; Reg('',I3,'')='',E15.7,/)') - INS(INEXT,1),REG(INS(INEXT,1)), - INS(INEXT,3),REG(INS(INEXT,3)) ENDIF IFAIL=1 GOTO 3000 ENDIF *** Arguments. ELSEIF(INS(INEXT,2).EQ.8)THEN IF(INS(INEXT,4).LE.0.OR.INS(INEXT,4).GT.MXARG)THEN IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ AL2EXE DEBUG :'', - '' Invalid argument # '',I3,'' found in line '', - I3,'':'')') INS(INEXT,4),INEXT IF(LDEBUG)CALL ALGPRT(INEXT,INEXT) IFAIL=1 GOTO 3000 ENDIF ARG(INS(INEXT,4))=REG(INS(INEXT,3)) MODARG(INS(INEXT,4))=MODREG(INS(INEXT,3)) ARGREF(INS(INEXT,4),1)=INS(INEXT,1) ARGREF(INS(INEXT,4),2)=INS(INEXT,3) *** Procedure calls. ELSEIF(INS(INEXT,2).EQ.9)THEN * Execute the procedure. CALL ALGCAL(INEXT,IFAIL1) IF(IFAIL1.NE.0)THEN NERR=NERR+1 IF(LDEBUG)THEN WRITE(LUNOUT,'(1X,A)') ' ++++++ AL2EXE'// - ' DEBUG : Procedure call error in:' CALL ALGPRT(INEXT,INEXT) WRITE(LUNOUT,'(26X,''Arguments:''/26X, - '' No Value Mode Ref1 Ref2'')') DO 170 I=1,INS(INEXT,3) WRITE(LUNOUT,'(26X,I5,2X,E12.5,3I5)') - I,ARG(I),MODARG(I),ARGREF(I,1),ARGREF(I,2) 170 CONTINUE ENDIF IFAIL=1 GOTO 3000 ENDIF * Back transfer of arguments to origin registers and variables. IF(LDEBUG)WRITE(LUNOUT,'(26X,''Arguments:''/26X, - '' No Value Mode Ref1 Ref2'')') DO 100 I=1,INS(INEXT,3) IF(LDEBUG)WRITE(LUNOUT,'(26X,I5,2X,E12.5,3I5)') - I,ARG(I),MODARG(I),ARGREF(I,1),ARGREF(I,2) IF(ARGREF(I,1).GE.2)GOTO 100 REG(ARGREF(I,2))=ARG(I) MODREG(ARGREF(I,2))=MODARG(I) IF(ARGREF(I,2).GE.1.AND. - ARGREF(I,2).LE.NVAR.AND. - ARGREF(I,2).LE.ALGENT(IENTNO,7))THEN C CALL ALGREU(NINT(ARG(I)),MODARG(I),ARGREF(I,1)) VAR(ARGREF(I,2))=ARG(I) MODVAR(ARGREF(I,2))=MODARG(I) ENDIF 100 CONTINUE *** RETURN, EXIT and QUIT instruction codes. ELSEIF(INS(INEXT,2).EQ.-9)THEN * Condition satisfied. IF(ABS(REG(INS(INEXT,1))-1).LT.EPS)THEN IF(INS(INEXT,3).EQ.0.OR.INS(INEXT,3).EQ.1)THEN INEXT=-1 ELSEIF(INS(INEXT,3).EQ.2)THEN CALL QUIT ELSE IF(LDEBUG)THEN WRITE(LUNOUT,'(2X,A)') - '++++++ AL2EXE DEBUG : Unrecognised'// - ' RETURN option seen in the line:' CALL ALGPRT(INEXT,INEXT) WRITE(LUNOUT,'(26X,''Reg('',I3,'')='',E15.7, - ''; Reg('',I3,'')='',E15.7,/)') - INS(INEXT,1),REG(INS(INEXT,1)), - INS(INEXT,3),REG(INS(INEXT,3)) ENDIF IFAIL=1 GOTO 3000 ENDIF * Invalid logical. ELSEIF(ABS(REG(INS(INEXT,1))).GT.EPS)THEN IF(LDEBUG)THEN WRITE(LUNOUT,'(2X,A)') '++++++ AL2EXE DEBUG :'// - ' Logical value error detected in the line:' CALL ALGPRT(INEXT,INEXT) WRITE(LUNOUT,'(26X,''Reg('',I3,'')='',E15.7, - ''; Reg('',I3,'')='',E15.7,/)') - INS(INEXT,1),REG(INS(INEXT,1)), - INS(INEXT,3),REG(INS(INEXT,3)) ENDIF IFAIL=1 GOTO 3000 ENDIF *** Algebraic instruction. ELSE IF((INS(INEXT,2).EQ.6.AND.MODREG(INS(INEXT,3)).EQ.0).OR. - (INS(INEXT,2).NE.6.AND.(MODREG(INS(INEXT,1)).EQ.0.OR. - MODREG(INS(INEXT,3)).EQ.0)))THEN CALL ALGEX0(INEXT,IFAIL) ELSEIF((INS(INEXT,2).EQ.6.AND.MODREG(INS(INEXT,3)).EQ.2).OR. - (INS(INEXT,2).NE.6.AND.MODREG(INS(INEXT,1)).EQ.2.AND. - MODREG(INS(INEXT,3)).EQ.2))THEN CALL ALGEX2(INEXT,IFAIL) ELSEIF((INS(INEXT,2).EQ.6.AND.MODREG(INS(INEXT,3)).EQ.3).OR. - (INS(INEXT,2).NE.6.AND.MODREG(INS(INEXT,1)).EQ.3.AND. - MODREG(INS(INEXT,3)).EQ.3))THEN CALL ALGEX3(INEXT,IFAIL) ELSEIF((INS(INEXT,2).EQ.6.AND.MODREG(INS(INEXT,3)).EQ.1).OR. - (INS(INEXT,2).NE.6.AND.MODREG(INS(INEXT,1)).EQ.1.AND. - MODREG(INS(INEXT,3)).EQ.1))THEN CALL ALGEX4(INEXT,IFAIL) ELSEIF((INS(INEXT,2).EQ.6.AND.MODREG(INS(INEXT,3)).EQ.4).OR. - (INS(INEXT,2).NE.6.AND.MODREG(INS(INEXT,1)).EQ.4.OR. - MODREG(INS(INEXT,3)).EQ.4))THEN CALL ALGEX5(INEXT,IFAIL) ELSEIF((INS(INEXT,2).EQ.6.AND.MODREG(INS(INEXT,3)).EQ.5).OR. - (INS(INEXT,2).NE.6.AND.MODREG(INS(INEXT,1)).EQ.5.OR. - MODREG(INS(INEXT,3)).EQ.5))THEN CALL ALGEX6(INEXT,IFAIL) ELSE PRINT *,' !!!!!! AL2EXE WARNING : Unable to evaluate'// - ' a variable because of mode incompatibility.' IF(LDEBUG)THEN WRITE(LUNOUT,'(26X,''Error occured in:'')') CALL ALGPRT(INEXT,INEXT) IF(INS(INEXT,2).NE.6)WRITE(LUNOUT,'(26X,''Reg '', - I3,'' = '',E15.7,'', Mode = '',I2,''.'')') - INS(INEXT,1),REG(INS(INEXT,1)), - MODREG(INS(INEXT,1)) WRITE(LUNOUT,'(26X,''Reg '', - I3,'' = '',E15.7,'', Mode = '',I2,''.'')') - INS(INEXT,3),REG(INS(INEXT,3)), - MODREG(INS(INEXT,3)) ENDIF GOTO 3000 ENDIF IF(IFAIL.NE.0)NERR=NERR+1 IF(IFAIL.NE.0.AND.LDEBUG)THEN WRITE(LUNOUT,'(1X,A)') ' ++++++ AL2EXE DEBUG :'// - ' Arithmetic error while evaluating:' CALL ALGPRT(INEXT,INEXT) IF(INS(INEXT,2).EQ.6)WRITE(LUNOUT,'(26X,''Reg('',I3, - '')='',E15.7,/)') INS(INEXT,3),REG(INS(INEXT,3)) IF(INS(INEXT,2).NE.6)WRITE(LUNOUT,'(26X,''Reg('',I3, - '')='',E15.7,''; Reg('',I3,'')='',E15.7,/)') - INS(INEXT,1),REG(INS(INEXT,1)), - INS(INEXT,3),REG(INS(INEXT,3)) IFAIL=1 GOTO 3000 ENDIF ENDIF *** Next instruction. GOTO 20 *** Clean up temporary strings. 3000 CONTINUE * Loop over the instructions. DO 50 I=ALGENT(IENTNO,5),ALGENT(IENTNO,5)+ALGENT(IENTNO,6)-1 * Skip results and control statements. IF(INS(I,2).EQ.0.OR.INS(I,2).EQ.8)GOTO 50 * Select lines that result in string type variables. IF(MODREG(INS(I,4)).NE.1)GOTO 70 DO 60 J=I+1,ALGENT(IENTNO,5)+ALGENT(IENTNO,6)-1 IF(INS(J,2).EQ.0.AND.INS(J,3).EQ.INS(I,4))GOTO 70 60 CONTINUE DO 150 J=1,NGLB IF(GLBMOD(J).NE.1)GOTO 150 IF(NINT(GLBVAL(J)).EQ.NINT(REG(INS(I,4))))GOTO 70 150 CONTINUE CALL STRBUF('DELETE',NINT(REG(INS(I,4))),DUMSTR,NCDUM,IFAIL1) 70 CONTINUE * Select lines that result in histogram type variables. IF(MODREG(INS(I,4)).NE.4)GOTO 80 DO 90 J=I+1,ALGENT(IENTNO,5)+ALGENT(IENTNO,6)-1 IF(INS(J,2).EQ.0.AND.INS(J,3).EQ.INS(I,4))GOTO 80 90 CONTINUE DO 110 J=1,NGLB IF(GLBMOD(J).NE.4)GOTO 110 IF(NINT(GLBVAL(J)).EQ.NINT(REG(INS(I,4))))GOTO 80 110 CONTINUE CALL HISADM('DELETE',NINT(REG(INS(I,4))),0,0.0,0.0,.FALSE.,IDUM) 80 CONTINUE * Select lines that result in matrix type variables. IF(MODREG(INS(I,4)).NE.5)GOTO 120 DO 130 J=I+1,ALGENT(IENTNO,5)+ALGENT(IENTNO,6)-1 IF(INS(J,2).EQ.0.AND.INS(J,3).EQ.INS(I,4))GOTO 120 130 CONTINUE DO 140 J=1,NGLB IF(GLBMOD(J).NE.5)GOTO 140 IF(NINT(GLBVAL(J)).EQ.NINT(REG(INS(I,4))))GOTO 120 140 CONTINUE CALL MATADM('DELETE',NINT(REG(INS(I,4))),0,IDUM,IDUM,IFAIL1) 120 CONTINUE * Next instruction. 50 CONTINUE *** Restore environment. CALL ALGUST END +DECK,ALGEX0. SUBROUTINE ALGEX0(I,IFAIL) *----------------------------------------------------------------------- * ALGEX0 - Routine executing instructions on arguments of * undefined type. * (Last changed on 12/ 9/99.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,ALGDATA. INTEGER I,IFAIL,IREF *** Assume the routine will fail. IFAIL=1 *** Function call: type of argument. IF(INS(I,2).EQ.6.AND.(INS(I,1).EQ.12.OR.INS(I,1).EQ.17))THEN CALL STRBUF('STORE',IREF,'Undefined',9,IFAIL) IF(IFAIL.NE.0)RETURN REG(INS(I,4))=IREF MODREG(INS(I,4))=1 *** No other functions known. ELSE REG(INS(I,4))=0 MODREG(INS(I,4))=0 ENDIF *** Reset IFAIL to 0 because the exercise was probably successful. IFAIL=0 END +DECK,ALGEX2. SUBROUTINE ALGEX2(I,IFAIL) *----------------------------------------------------------------------- * ALGEX2 - Routine executing instruction I (produced by ALGPRE). * This routine takes care of arithmetic operations between * reals (and for the time being also of logicals). * (Last changed on 9/11/07.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,ALGDATA. +SEQ,MATDATA. EXTERNAL RNDUNI,RANLAN,RNDEXP,RNDNOR,RNDPOL,RNDFUN,DENLAN,RNDLAP REAL RNDUNI,RANLAN,RNDEXP,RNDNOR,RNDPOL,RNDFUN,DENLAN,EPS,GAMMA, - ALGAMA,RNGAMA,RNDLAP INTEGER I,J,IFAIL,IFAIL1,NPOIS,IERR,NCAUX,IREF,ISIZ(1),ISLOT, - MATSLT CHARACTER*20 AUXSTR EXTERNAL MATSLT,GAMMA,ALGAMA,RNGAMA *** Set IFAIL to 1 and EPS. IFAIL=1 +SELF,IF=CRAY. EPS=1.0E-10 +SELF,IF=-CRAY. EPS=1.0E-5 +SELF. *** Initial value is zero for any result. REG(INS(I,4))=0.0 *** Perform the actual calculation: binary numerical operators. IF(INS(I,2).EQ.1)THEN REG(INS(I,4))=REG(INS(I,1))+REG(INS(I,3)) MODREG(INS(I,4))=2 ELSEIF(INS(I,2).EQ.2)THEN REG(INS(I,4))=REG(INS(I,1))-REG(INS(I,3)) MODREG(INS(I,4))=2 ELSEIF(INS(I,2).EQ.3)THEN REG(INS(I,4))=REG(INS(I,1))*REG(INS(I,3)) MODREG(INS(I,4))=2 ELSEIF(INS(I,2).EQ.4)THEN MODREG(INS(I,4))=2 IF(REG(INS(I,3)).EQ.0.0)THEN NAERR(1)=NAERR(1)+1 RETURN ENDIF REG(INS(I,4))=REG(INS(I,1))/REG(INS(I,3)) ELSEIF(INS(I,2).EQ.5)THEN MODREG(INS(I,4))=2 IF(ABS(REG(INS(I,3))-NINT(REG(INS(I,3)))).LT.EPS)THEN IF(NINT(REG(INS(I,3))).LE.0.AND.REG(INS(I,1)).EQ.0)THEN RETURN ELSEIF(2*(NINT(REG(INS(I,3)))/2).EQ. - NINT(REG(INS(I,3))))THEN REG(INS(I,4))=ABS(REG(INS(I,1)))** - NINT(REG(INS(I,3))) ELSE REG(INS(I,4))=SIGN(ABS(REG(INS(I,1)))** - NINT(REG(INS(I,3))),REG(INS(I,1))) ENDIF ELSEIF(REG(INS(I,1)).EQ.0.AND.REG(INS(I,3)).GT.0)THEN REG(INS(I,4))=0 ELSEIF(REG(INS(I,1)).GT.0)THEN REG(INS(I,4))=REG(INS(I,1))**REG(INS(I,3)) ELSE NAERR(11)=NAERR(11)+1 RETURN ENDIF *** Numerical function calls. ELSEIF(INS(I,2).EQ.6)THEN * Exponential and log. MODREG(INS(I,4))=2 IF(INS(I,1).EQ. 1)THEN IF(REG(INS(I,3)).GT.EXPMAX)THEN NAERR(2)=NAERR(2)+1 REG(INS(I,4))=EXP(EXPMAX) RETURN ELSEIF(REG(INS(I,3)).LT.-EXPMAX)THEN IF(LIGUND)THEN REG(INS(I,4))=0 ELSE NAERR(3)=NAERR(3)+1 RETURN ENDIF ELSE REG(INS(I,4))=EXP(REG(INS(I,3))) ENDIF ELSEIF(INS(I,1).EQ.-1)THEN IF(REG(INS(I,3)).LE.0.0)THEN NAERR(4)=NAERR(4)+1 RETURN ENDIF REG(INS(I,4))=LOG(REG(INS(I,3))) * Trigonometric. ELSEIF(INS(I,1).EQ. 2)THEN REG(INS(I,4))= SIN(REG(INS(I,3))) ELSEIF(INS(I,1).EQ.-2)THEN IF(ABS(REG(INS(I,3))).GT.1.0)THEN NAERR(5)=NAERR(5)+1 RETURN ENDIF REG(INS(I,4))= ASIN(REG(INS(I,3))) ELSEIF(INS(I,1).EQ. 3)THEN REG(INS(I,4))= COS(REG(INS(I,3))) ELSEIF(INS(I,1).EQ.-3)THEN IF(ABS(REG(INS(I,3))).GT.1.0)THEN NAERR(5)=NAERR(5)+1 RETURN ENDIF REG(INS(I,4))= ACOS(REG(INS(I,3))) ELSEIF(INS(I,1).EQ. 4)THEN REG(INS(I,4))= TAN(REG(INS(I,3))) ELSEIF(INS(I,1).EQ.-4)THEN REG(INS(I,4))= ATAN(REG(INS(I,3))) * Absolute value. ELSEIF(INS(I,1).EQ. 5)THEN REG(INS(I,4))= ABS(REG(INS(I,3))) * Square root. ELSEIF(INS(I,1).EQ.-5)THEN IF(REG(INS(I,3)).LT.0.0)THEN NAERR(6)=NAERR(6)+1 RETURN ENDIF REG(INS(I,4))=SQRT(REG(INS(I,3))) * Assignments and negatives. ELSEIF(INS(I,1).EQ. 6)THEN REG(INS(I,4))= REG(INS(I,3)) ELSEIF(INS(I,1).EQ.-6)THEN REG(INS(I,4))= -REG(INS(I,3)) * Hyperbolic trigonometry. ELSEIF(INS(I,1).EQ. 7)THEN REG(INS(I,4))= SINH(REG(INS(I,3))) ELSEIF(INS(I,1).EQ.-7)THEN REG(INS(I,4))=LOG(REG(INS(I,3))+ - SQRT(1+REG(INS(I,3))**2)) ELSEIF(INS(I,1).EQ. 8)THEN REG(INS(I,4))= COSH(REG(INS(I,3))) ELSEIF(INS(I,1).EQ.-8)THEN IF(REG(INS(I,3)).LT.1)THEN NAERR(7)=NAERR(7)+1 RETURN ENDIF REG(INS(I,4))=LOG(REG(INS(I,3))+ - SQRT(REG(INS(I,3))**2-1)) ELSEIF(INS(I,1).EQ. 9)THEN REG(INS(I,4))= TANH(REG(INS(I,3))) ELSEIF(INS(I,1).EQ.-9)THEN IF(REG(INS(I,3)).LE.-1.0.OR.REG(INS(I,3)).GE.1.0)THEN NAERR(8)=NAERR(8)+1 RETURN ENDIF REG(INS(I,4))=0.5*LOG((1+REG(INS(I,3)))/ - (1-REG(INS(I,3)))) * Landau distribution. ELSEIF(INS(I,1).EQ.18)THEN REG(INS(I,4))=DENLAN(REG(INS(I,3))) * Make a string from a number. ELSEIF(INS(I,1).EQ.12)THEN CALL OUTFMT(REG(INS(I,3)),MODREG(INS(I,3)), - AUXSTR,NCAUX,'LEFT') CALL STRBUF('STORE',IREF,AUXSTR(1:NCAUX),NCAUX,IFAIL) IF(IFAIL.NE.0)THEN NAERR(9)=NAERR(9)+1 RETURN ENDIF MODREG(INS(I,4))=1 REG(INS(I,4))=IREF * Return the type of the argument. ELSEIF(INS(I,1).EQ.17)THEN CALL STRBUF('STORE',IREF,'Number',6,IFAIL) IF(IFAIL.NE.0)THEN NAERR(9)=NAERR(9)+1 RETURN ENDIF REG(INS(I,4))=IREF MODREG(INS(I,4))=1 * Make a number from a number. ELSEIF(INS(I,1).EQ.-12)THEN REG(INS(I,4))=REG(INS(I,3)) MODREG(INS(I,4))=2 * Truncation of a real number. ELSEIF(INS(I,1).EQ.11)THEN REG(INS(I,4))=INT(REG(INS(I,3))) IF(REG(INS(I,3)).LT.0)REG(INS(I,4))=REG(INS(I,4))-1.0 ELSEIF(INS(I,1).EQ.-11)THEN REG(INS(I,4))=REG(INS(I,3))-INT(REG(INS(I,3))) IF(REG(INS(I,3)).LT.0)REG(INS(I,4))=REG(INS(I,4))+1.0 * Return strings by reference. ELSEIF(INS(I,1).EQ.51)THEN REG(INS(I,4))=REG(INS(I,3)) MODREG(INS(I,4))=1 * Return histograms by reference. ELSEIF(INS(I,1).EQ.54)THEN REG(INS(I,4))=REG(INS(I,3)) MODREG(INS(I,4))=4 * Return matrices by reference. ELSEIF(INS(I,1).EQ.55)THEN REG(INS(I,4))=REG(INS(I,3)) MODREG(INS(I,4))=5 * Random number generators. ELSEIF(INS(I,1).EQ.21)THEN REG(INS(I,4))=RNDUNI(REG(INS(I,3))) ELSEIF(INS(I,1).EQ.22)THEN REG(INS(I,4))=RNDNOR(0.0,1.0) ELSEIF(INS(I,1).EQ.23)THEN REG(INS(I,4))=RNDEXP(REG(INS(I,3))) ELSEIF(INS(I,1).EQ.24)THEN CALL RNPSSN(REG(INS(I,3)),NPOIS,IERR) REG(INS(I,4))=REAL(NPOIS) ELSEIF(INS(I,1).EQ.25)THEN REG(INS(I,4))=RANLAN(RNDUNI(1.0)) ELSEIF(INS(I,1).EQ.26)THEN REG(INS(I,4))=RNDPOL(REG(INS(I,3))) ELSEIF(INS(I,1).EQ.27)THEN REG(INS(I,4))=RNDFUN(REG(INS(I,3))) ELSEIF(INS(I,1).EQ.29)THEN IF(REG(INS(I,3)).GT.0)THEN REG(INS(I,4))=RNGAMA(REG(INS(I,3))) ELSE REG(INS(I,4))=-1 NAERR(14)=NAERR(14)+1 ENDIF ELSEIF(INS(I,1).EQ.30)THEN REG(INS(I,4))=RNDLAP(REG(INS(I,3))) * A row of integers. ELSEIF(INS(I,1).EQ.40)THEN ISIZ(1)=NINT(REG(INS(I,3))) CALL MATADM('ALLOCATE',IREF,1,ISIZ,2,IFAIL1) IF(IFAIL1.NE.0)RETURN REG(INS(I,4))=REAL(IREF) MODREG(INS(I,4))=5 * A row of zeroes. ELSEIF(INS(I,1).EQ.44)THEN ISIZ(1)=NINT(REG(INS(I,3))) CALL MATADM('ALLOCATE',IREF,1,ISIZ,2,IFAIL1) IF(IFAIL1.NE.0)RETURN ISLOT=MATSLT(IREF) IF(ISLOT.LE.0)THEN RETURN ELSE DO 10 J=1,MLEN(ISLOT) MVEC(MORG(ISLOT)+J)=0.0 10 CONTINUE REG(INS(I,4))=REAL(IREF) MODREG(INS(I,4))=5 ENDIF * A row of ones. ELSEIF(INS(I,1).EQ.45)THEN ISIZ(1)=NINT(REG(INS(I,3))) CALL MATADM('ALLOCATE',IREF,1,ISIZ,2,IFAIL1) IF(IFAIL1.NE.0)RETURN ISLOT=MATSLT(IREF) IF(ISLOT.LE.0)THEN RETURN ELSE DO 20 J=1,MLEN(ISLOT) MVEC(MORG(ISLOT)+J)=1.0 20 CONTINUE REG(INS(I,4))=REAL(IREF) MODREG(INS(I,4))=5 ENDIF * Gamma function. ELSEIF(INS(I,1).EQ.47)THEN IF(REG(INS(I,3)).LT.1E-20)THEN NAERR(12)=NAERR(12)+1 RETURN ELSEIF(REG(INS(I,3)).GT.25.0)THEN NAERR(13)=NAERR(13)+1 RETURN ELSE REG(INS(I,4))=GAMMA(REG(INS(I,3))) MODREG(INS(I,4))=2 ENDIF * log-Gamma function. ELSEIF(INS(I,1).EQ.48)THEN IF(REG(INS(I,3)).LE.0)THEN NAERR(14)=NAERR(14)+1 RETURN ELSE REG(INS(I,4))=ALGAMA(REG(INS(I,3))) MODREG(INS(I,4))=2 ENDIF * Unidentified. ELSE MODREG(INS(I,4))=0 NAERR(10)=NAERR(10)+1 RETURN ENDIF *** Binary logical operators between real type arguments. ELSEIF(INS(I,2).EQ.10)THEN MODREG(INS(I,4))=3 REG(INS(I,4))=0.0 IF(ABS(REG(INS(I,1))-REG(INS(I,3))).LT.EPS)REG(INS(I,4))=1.0 ELSEIF(INS(I,2).EQ.11)THEN MODREG(INS(I,4))=3 REG(INS(I,4))=0.0 IF(ABS(REG(INS(I,1))-REG(INS(I,3))).GT.EPS)REG(INS(I,4))=1.0 ELSEIF(INS(I,2).EQ.12)THEN MODREG(INS(I,4))=3 REG(INS(I,4))=0.0 IF(REG(INS(I,1)).LT.REG(INS(I,3)))REG(INS(I,4))=1.0 ELSEIF(INS(I,2).EQ.13)THEN MODREG(INS(I,4))=3 REG(INS(I,4))=0.0 IF(REG(INS(I,1)).LE.REG(INS(I,3)))REG(INS(I,4))=1.0 ELSEIF(INS(I,2).EQ.14)THEN MODREG(INS(I,4))=3 REG(INS(I,4))=0.0 IF(REG(INS(I,1)).GT.REG(INS(I,3)))REG(INS(I,4))=1.0 ELSEIF(INS(I,2).EQ.15)THEN MODREG(INS(I,4))=3 REG(INS(I,4))=0.0 IF(REG(INS(I,1)).GE.REG(INS(I,3)))REG(INS(I,4))=1.0 *** Concatenate the 2 arguments to form a Matrix. ELSEIF(INS(I,2).EQ.16)THEN ISIZ(1)=2 CALL MATADM('ALLOCATE',IREF,1,ISIZ,2,IFAIL1) IF(IFAIL1.NE.0)RETURN REG(INS(I,4))=REAL(IREF) MODREG(INS(I,4))=5 ISLOT=MATSLT(IREF) IF(ISLOT.LE.0)RETURN MVEC(MORG(ISLOT)+1)=REG(INS(I,1)) MVEC(MORG(ISLOT)+2)=REG(INS(I,3)) *** Unidentified operation code. ELSE MODREG(INS(I,4))=0 NAERR(10)=NAERR(10)+1 RETURN ENDIF *** Reset IFAIL to 0 because the calculations were probably successful. IFAIL=0 END +DECK,ALGEX3. SUBROUTINE ALGEX3(I,IFAIL) *----------------------------------------------------------------------- * ALGEX3 - Routine executing instruction I (produced by ALGPRE). * This routine takes care of operations on logicals. * (Last changed on 4/ 3/94.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,ALGDATA. INTEGER I,IFAIL,IREF,NCAUX REAL EPS CHARACTER*20 AUXSTR *** Set IFAIL to 1 and EPS to 1.0E-5. IFAIL=1 EPS=1.0E-5 *** Logical function call. IF(INS(I,2).EQ.6)THEN IF(INS(I,1).EQ.10)THEN IF(ABS(REG(INS(I,3))).GT.EPS.AND. - ABS(REG(INS(I,3))-1.0).GT.EPS)RETURN REG(INS(I,4))=1.0-REG(INS(I,3)) MODREG(INS(I,4))=3 * Make a string from a logical. ELSEIF(INS(I,1).EQ.12)THEN CALL OUTFMT(REG(INS(I,3)),MODREG(INS(I,3)), - AUXSTR,NCAUX,'LEFT') CALL STRBUF('STORE',IREF,AUXSTR(1:NCAUX),NCAUX,IFAIL) IF(IFAIL.NE.0)RETURN MODREG(INS(I,4))=1 REG(INS(I,4))=IREF * Return the type of the argument. ELSEIF(INS(I,1).EQ.17)THEN CALL STRBUF('STORE',IREF,'Logical',7,IFAIL) IF(IFAIL.NE.0)RETURN REG(INS(I,4))=IREF MODREG(INS(I,4))=1 * No other functions are known. ELSE RETURN ENDIF *** Binary logical operators between logical type arguments. ELSEIF((INS(I,2).GE.1.AND.INS(I,2).LE.3).OR. - (INS(I,2).GE.10.AND.INS(I,2).LE.11).OR. - (INS(I,2).GE.16.AND.INS(I,2).LE.17))THEN * Check that the numbers are really logicals. IF((ABS(REG(INS(I,1))-1.0).GT.EPS.AND. - ABS(REG(INS(I,1))).GT.EPS).OR. - (ABS(REG(INS(I,3))-1.0).GT.EPS.AND. - ABS(REG(INS(I,3))).GT.EPS))RETURN * Or. IF(INS(I,2).EQ.17.OR.INS(I,2).EQ.1) - REG(INS(I,4))=MIN(1.0,REG(INS(I,1))+REG(INS(I,3))) * Exclusive or. IF(INS(I,2).EQ.2) - REG(INS(I,4))=MOD(REG(INS(I,1))+REG(INS(I,3)),2.0) * And. IF(INS(I,2).EQ.16.OR.INS(I,2).EQ.3) - REG(INS(I,4))=REG(INS(I,1))*REG(INS(I,3)) * Equivalence. IF(INS(I,2).EQ.10)REG(INS(I,4))= - REG(INS(I,1))*REG(INS(I,3))+ - (1-REG(INS(I,1)))*(1-REG(INS(I,3))) * Non-equivalence. IF(INS(I,2).EQ.11)REG(INS(I,4))= - (1-REG(INS(I,1)))*REG(INS(I,3))+ - REG(INS(I,1))*(1-REG(INS(I,3))) * Round the result to the nearest whole number. REG(INS(I,4))=ANINT(REG(INS(I,4))) * Propagate mode. MODREG(INS(I,4))=3 *** Unidentified operation code. ELSE RETURN ENDIF *** Reset IFAIL to 0 because the calculations were probably successful. IFAIL=0 END +DECK,ALGEX4. SUBROUTINE ALGEX4(I,IFAIL) *----------------------------------------------------------------------- * ALGEX4 - Routine executing instruction I (produced by ALGPRE). * This routine takes care of operations on characters. * (Last changed on 10/ 1/02.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,ALGDATA. +SEQ,PRINTPLOT. +SEQ,GLOBALS. INTEGER I,J,IFAIL,IFAIL1,IFAIL2,IFAIL3,NC1,NC2,IREF CHARACTER*(MXINCH) STR1,STR2 LOGICAL EXIST *** Set IFAIL to 1. IFAIL=1 *** Binary operations, concatenation. IF(INS(I,2).EQ.1.OR.INS(I,2).EQ.4.OR.INS(I,2).EQ.16)THEN * Fetch the strings. CALL STRBUF('READ',NINT(REG(INS(I,1))),STR1,NC1,IFAIL1) CALL STRBUF('READ',NINT(REG(INS(I,3))),STR2,NC2,IFAIL2) * Depending on whether one or both have 0 length, concatenate. IF(NC1.GT.0.AND.NC2.GT.0)THEN CALL STRBUF('STORE',IREF,STR1(1:NC1)//STR2(1:NC2), - NC1+NC2,IFAIL3) ELSEIF(NC1.GT.0)THEN CALL STRBUF('STORE',IREF,STR1(1:NC1),NC1,IFAIL3) ELSEIF(NC2.GT.0)THEN CALL STRBUF('STORE',IREF,STR2(1:NC2),NC2,IFAIL3) ELSE CALL STRBUF('STORE',IREF,' ',0,IFAIL3) ENDIF * Store the result. REG(INS(I,4))=IREF MODREG(INS(I,4))=1 * Check error flag. IF(IFAIL1+IFAIL2+IFAIL3.NE.0)THEN IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ ALGEX4 DEBUG :'', - '' String buffer operation error:'',26X, - '' Fetch: '',2I2,'' Store: '',I2)') - IFAIL1,IFAIL2,IFAIL3 RETURN ENDIF * Minus * ELSEIF(INS(I,2).EQ.2)THEN * Product * ELSEIF(INS(I,2).EQ.3)THEN * Exponentiation * ELSEIF(INS(I,2).EQ.5)THEN *** Function calls. ELSEIF(INS(I,2).EQ.6)THEN * Make a string from a string. IF(INS(I,1).EQ.12)THEN REG(INS(I,4))=REG(INS(I,3)) * Make a number from a string. ELSEIF(INS(I,1).EQ.-12)THEN CALL STRBUF('READ',NINT(REG(INS(I,3))),STR1,NC1,IFAIL1) MODREG(INS(I,4))=2 CALL INPRRC(STR1(1:NC1),REG(INS(I,4)),0.0,IFAIL2) IF(IFAIL1.NE.0.OR.IFAIL2.NE.0)RETURN * Locate a global variable from its name. ELSEIF(INS(I,1).EQ.16)THEN CALL STRBUF('READ',NINT(REG(INS(I,3))),STR1,NC1,IFAIL1) IF(NC1.GT.0)THEN CALL CLTOU(STR1(1:NC1)) DO 10 J=1,NGLB IF(STR1(1:NC1).EQ.GLBVAR(J))THEN MODREG(INS(I,4))=GLBMOD(J) REG(INS(I,4))=GLBVAL(J) GOTO 20 ENDIF 10 CONTINUE ENDIF MODREG(INS(I,4))=0 REG(INS(I,4))=0 20 CONTINUE * Return the type of the argument. ELSEIF(INS(I,1).EQ.17)THEN CALL STRBUF('STORE',IREF,'String',6,IFAIL1) IF(IFAIL1.NE.0)RETURN REG(INS(I,4))=IREF MODREG(INS(I,4))=1 * Determine whether a file exists. ELSEIF(INS(I,1).EQ.46)THEN CALL STRBUF('READ',NINT(REG(INS(I,3))),STR1,NC1,IFAIL1) IF(IFAIL1.NE.0)RETURN CALL DSNINQ(STR1,NC1,EXIST) IF(EXIST)THEN REG(INS(I,4))=1 ELSE REG(INS(I,4))=0 ENDIF MODREG(INS(I,4))=3 * Other functions are not known. ELSE RETURN ENDIF *** Binary logical operators between character strings. First = ELSEIF(INS(I,2).EQ.10)THEN CALL STRBUF('READ',NINT(REG(INS(I,1))),STR1,NC1,IFAIL1) CALL STRBUF('READ',NINT(REG(INS(I,3))),STR2,NC2,IFAIL2) IF(IFAIL1.NE.0.OR.IFAIL2.NE.0)RETURN IF(NC1.LE.0.AND.NC2.LE.0)THEN REG(INS(I,4))=1 ELSEIF(NC1.LE.0.OR.NC2.LE.0)THEN REG(INS(I,4))=0 ELSEIF(STR1(1:NC1).EQ.STR2(1:NC2))THEN REG(INS(I,4))=1 ELSE REG(INS(I,4))=0 ENDIF MODREG(INS(I,4))=3 * Not equal: ELSEIF(INS(I,2).EQ.11)THEN CALL STRBUF('READ',NINT(REG(INS(I,1))),STR1,NC1,IFAIL1) CALL STRBUF('READ',NINT(REG(INS(I,3))),STR2,NC2,IFAIL2) IF(IFAIL1.NE.0.OR.IFAIL2.NE.0)RETURN IF(NC1.LE.0.AND.NC2.LE.0)THEN REG(INS(I,4))=0 ELSEIF(NC1.LE.0.OR.NC2.LE.0)THEN REG(INS(I,4))=1 ELSEIF(STR1(1:NC1).NE.STR2(1:NC2))THEN REG(INS(I,4))=1 ELSE REG(INS(I,4))=0 ENDIF MODREG(INS(I,4))=3 * Less: ELSEIF(INS(I,2).EQ.12)THEN CALL STRBUF('READ',NINT(REG(INS(I,1))),STR1,NC1,IFAIL1) CALL STRBUF('READ',NINT(REG(INS(I,3))),STR2,NC2,IFAIL2) IF(IFAIL1.NE.0.OR.IFAIL2.NE.0)RETURN IF(NC1.LE.0.AND.NC2.LE.0)THEN REG(INS(I,4))=0 ELSEIF(NC1.LE.0)THEN REG(INS(I,4))=1 ELSEIF(NC2.LE.0)THEN REG(INS(I,4))=0 ELSEIF(STR1(1:NC1).LT.STR2(1:NC2))THEN REG(INS(I,4))=1 ELSE REG(INS(I,4))=0 ENDIF MODREG(INS(I,4))=3 * Less or equal: ELSEIF(INS(I,2).EQ.13)THEN CALL STRBUF('READ',NINT(REG(INS(I,1))),STR1,NC1,IFAIL1) CALL STRBUF('READ',NINT(REG(INS(I,3))),STR2,NC2,IFAIL2) IF(IFAIL1.NE.0.OR.IFAIL2.NE.0)RETURN IF(NC1.LE.0.AND.NC2.LE.0)THEN REG(INS(I,4))=1 ELSEIF(NC1.LE.0)THEN REG(INS(I,4))=1 ELSEIF(NC2.LE.0)THEN REG(INS(I,4))=0 ELSEIF(STR1(1:NC1).LE.STR2(1:NC2))THEN REG(INS(I,4))=1 ELSE REG(INS(I,4))=0 ENDIF MODREG(INS(I,4))=3 * Greater: ELSEIF(INS(I,2).EQ.14)THEN CALL STRBUF('READ',NINT(REG(INS(I,1))),STR1,NC1,IFAIL1) CALL STRBUF('READ',NINT(REG(INS(I,3))),STR2,NC2,IFAIL2) IF(IFAIL1.NE.0.OR.IFAIL2.NE.0)RETURN IF(NC1.LE.0.AND.NC2.LE.0)THEN REG(INS(I,4))=0 ELSEIF(NC1.LE.0)THEN REG(INS(I,4))=0 ELSEIF(NC2.LE.0)THEN REG(INS(I,4))=1 ELSEIF(STR1(1:NC1).GT.STR2(1:NC2))THEN REG(INS(I,4))=1 ELSE REG(INS(I,4))=0 ENDIF MODREG(INS(I,4))=3 * Greater or equal: ELSEIF(INS(I,2).EQ.15)THEN CALL STRBUF('READ',NINT(REG(INS(I,1))),STR1,NC1,IFAIL1) CALL STRBUF('READ',NINT(REG(INS(I,3))),STR2,NC2,IFAIL2) IF(IFAIL1.NE.0.OR.IFAIL2.NE.0)RETURN IF(NC1.LE.0.AND.NC2.LE.0)THEN REG(INS(I,4))=1 ELSEIF(NC1.LE.0)THEN REG(INS(I,4))=0 ELSEIF(NC2.LE.0)THEN REG(INS(I,4))=1 ELSEIF(STR1(1:NC1).GE.STR2(1:NC2))THEN REG(INS(I,4))=1 ELSE REG(INS(I,4))=0 ENDIF MODREG(INS(I,4))=3 *** Unrecognised code. ELSE RETURN ENDIF *** Reset IFAIL to 0 because the calculations were probably successful. IFAIL=0 END +DECK,ALGEX5. SUBROUTINE ALGEX5(I,IFAIL) *----------------------------------------------------------------------- * ALGEX5 - Routine executing instruction I (produced by ALGPRE). * This routine takes care of arithmetic operations between * histograms. * (Last changed on 19/11/10.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,ALGDATA. +SEQ,HISTDATA. +SEQ,GLOBALS. +SEQ,PRINTPLOT. CHARACTER*(MXINCH) STR1 REAL RNDUNI,RANLAN,RNDEXP,RNDNOR,RNDPOL,RNDFUN,DENLAN,EPS, - XXMIN,XXMAX,XX,XAUX,AVER,RMS,DGAMMA,DLGAMA,RNGAMA,RNDLAP INTEGER IFAIL,IFAIL1,IHIST1,IHIST3,IHIST4,NNCHA,I,J,NPOIS,IREF, - IERR,NC1,NNENTR LOGICAL HEXIST,HSET EXTERNAL RNDUNI,RANLAN,RNDEXP,RNDNOR,RNDPOL,RNDFUN,DENLAN,DGAMMA, - DLGAMA,RNGAMA,RNDLAP *** Set IFAIL to 1 and EPS. IFAIL=1 +SELF,IF=CRAY. EPS=1.0E-10 +SELF,IF=-CRAY. EPS=1.0E-5 +SELF. *** For easier reference, define histogram references. IHIST1=NINT(REG(INS(I,1))) IHIST3=NINT(REG(INS(I,3))) IHIST4=NINT(REG(INS(I,4))) *** Verify that the objects are indeed valid, set histograms. IF(INS(I,2).NE.6.AND.MODREG(INS(I,1)).EQ.4.AND. - MODREG(INS(I,3)).EQ.4)THEN * Validity of reference number. IF(IHIST1.LE.0.OR.IHIST3.LE.0.OR. - IHIST1.GT.MXHIST.OR.IHIST3.GT.MXHIST)THEN MODREG(INS(I,4))=0 REG(INS(I,4))=0 IF(LDEBUG)PRINT *,' ++++++ ALGEX5 DEBUG : Invalid'// - ' histogram reference ',IHIST1,IHIST3 NAERR(51)=NAERR(51)+1 RETURN * Histograms must have been declared. ELSEIF(.NOT.(HISUSE(IHIST1).AND.HISUSE(IHIST3)))THEN MODREG(INS(I,4))=0 REG(INS(I,4))=0 IF(LDEBUG)THEN PRINT *,' ++++++ ALGEX5 DEBUG : Histogram'// - ' not yet in use' PRINT *,' Arg 1: ref=', - IHIST1,' use=',HISUSE(IHIST1), - ', Arg 3: ref=', - IHIST3,' use=',HISUSE(IHIST3) ENDIF NAERR(52)=NAERR(52)+1 RETURN * If autoranged, then the range must have been set. ELSEIF(.NOT.(SET(IHIST1).AND.SET(IHIST3)))THEN MODREG(INS(I,4))=0 REG(INS(I,4))=0 IF(LDEBUG)THEN PRINT *,' ++++++ ALGEX5 DEBUG : Histogram'// - ' not yet autoscaled' PRINT *,' Arg 1: ref=', - IHIST1,' set=',SET(IHIST1),', Arg 3: ref=', - IHIST3,' set=',SET(IHIST3) ENDIF NAERR(53)=NAERR(53)+1 RETURN * The range and the number of bins must agree. ELSEIF(ABS(XMIN(IHIST1)-XMIN(IHIST3)).GT. - EPS*(1+ABS(XMIN(IHIST1))+ABS(XMIN(IHIST3))).OR. - ABS(XMAX(IHIST1)-XMAX(IHIST3)).GT. - EPS*(1+ABS(XMAX(IHIST1))+ABS(XMAX(IHIST3))).OR. - NCHA(IHIST1).NE.NCHA(IHIST3))THEN MODREG(INS(I,4))=0 REG(INS(I,4))=0 IF(LDEBUG)THEN PRINT *,' ++++++ ALGEX5 DEBUG : Histograms'// - ' not compatible.' PRINT *,' Arg 1: ref=', - IHIST1,' range=',XMIN(IHIST1),XMAX(IHIST1), - ' bins=',NCHA(IHIST1) PRINT *,' Arg 3: ref=', - IHIST3,' range=',XMIN(IHIST3),XMAX(IHIST3), - ' bins=',NCHA(IHIST3) ENDIF NAERR(54)=NAERR(54)+1 RETURN ENDIF ELSEIF(MODREG(INS(I,3)).EQ.4)THEN * Validity of reference number. IF(IHIST3.LE.0.OR.IHIST3.GT.MXHIST)THEN MODREG(INS(I,4))=0 REG(INS(I,4))=0 IF(LDEBUG)PRINT *,' ++++++ ALGEX5 DEBUG : Invalid'// - ' histogram reference ',IHIST3 NAERR(51)=NAERR(51)+1 RETURN * Histogram must have been declared. ELSEIF(.NOT.HISUSE(IHIST3))THEN MODREG(INS(I,4))=0 REG(INS(I,4))=0 IF(LDEBUG)THEN PRINT *,' ++++++ ALGEX5 DEBUG : Histogram'// - ' not yet in use' PRINT *,' Arg 3: ref=', - IHIST3,' use=',HISUSE(IHIST3) ENDIF NAERR(52)=NAERR(52)+1 RETURN * If autoranged, then the range must have been set. ELSEIF(.NOT.SET(IHIST3))THEN MODREG(INS(I,4))=0 REG(INS(I,4))=0 IF(LDEBUG)THEN PRINT *,' ++++++ ALGEX5 DEBUG : Histogram'// - ' not yet autoscaled' PRINT *,' Arg 3: ref=', - IHIST3,' set=',SET(IHIST3) ENDIF NAERR(53)=NAERR(53)+1 RETURN ENDIF * Check nothing else than numbers and histograms appear. ELSEIF((INS(I,2).EQ.6.AND.MODREG(INS(I,3)).NE.4).OR. - (INS(I,2).NE.6.AND.((MODREG(INS(I,1)).NE.2.AND. - MODREG(INS(I,1)).NE.4).OR.(MODREG(INS(I,3)).NE.2.AND. - MODREG(INS(I,3)).NE.4))))THEN MODREG(INS(I,4))=0 REG(INS(I,4))=0 IF(LDEBUG)THEN PRINT *,' ++++++ ALGEX5 DEBUG : Unable to'// - ' handle received modes' PRINT *,' Arg 1: ref=', - IHIST1,' mode=',MODREG(INS(I,1)) PRINT *,' Arg 3: ref=', - IHIST3,' mode=',MODREG(INS(I,3)) ENDIF RETURN ENDIF *** Establish parameters of the resulting histogram. IF(INS(I,2).EQ.6)THEN IF(MODREG(INS(I,3)).EQ.4)THEN XXMIN=XMIN(IHIST3) XXMAX=XMAX(IHIST3) NNCHA=NCHA(IHIST3) ELSE RETURN ENDIF ELSE IF(MODREG(INS(I,1)).EQ.4)THEN XXMIN=XMIN(IHIST1) XXMAX=XMAX(IHIST1) NNCHA=NCHA(IHIST1) ELSEIF(MODREG(INS(I,3)).EQ.4)THEN XXMIN=XMIN(IHIST3) XXMAX=XMAX(IHIST3) NNCHA=NCHA(IHIST3) ELSE RETURN ENDIF ENDIF *** If one of the arguments is scalar, turn into a histogram. IF(INS(I,2).NE.6.AND.MODREG(INS(I,1)).EQ.2)THEN CALL HISADM('ALLOCATE',IHIST1,NNCHA,XXMIN,XXMAX, - .FALSE.,IFAIL1) IF(IFAIL1.NE.0)RETURN DO 500 J=1,NNCHA CONTEN(IHIST1,J)=REG(INS(I,1)) 500 CONTINUE ENDIF IF(MODREG(INS(I,3)).EQ.2)THEN CALL HISADM('ALLOCATE',IHIST3,NNCHA,XXMIN,XXMAX, - .FALSE.,IFAIL1) IF(IFAIL1.NE.0)RETURN DO 510 J=1,NNCHA CONTEN(IHIST3,J)=REG(INS(I,3)) 510 CONTINUE ENDIF *** Allocate a histogram for the result. CALL HISADM('ALLOCATE',IHIST4,NNCHA,XXMIN,XXMAX,.FALSE.,IFAIL1) IF(IFAIL1.NE.0)RETURN *** Perform the actual calculation: binary numerical operators. IF(INS(I,2).EQ.1)THEN DO 10 J=1,NNCHA CONTEN(IHIST4,J)=CONTEN(IHIST1,J)+CONTEN(IHIST3,J) 10 CONTINUE MODREG(INS(I,4))=4 ELSEIF(INS(I,2).EQ.2)THEN DO 20 J=1,NNCHA CONTEN(IHIST4,J)=CONTEN(IHIST1,J)-CONTEN(IHIST3,J) 20 CONTINUE MODREG(INS(I,4))=4 ELSEIF(INS(I,2).EQ.3)THEN DO 30 J=1,NNCHA CONTEN(IHIST4,J)=CONTEN(IHIST1,J)*CONTEN(IHIST3,J) 30 CONTINUE MODREG(INS(I,4))=4 ELSEIF(INS(I,2).EQ.4)THEN DO 40 J=1,NNCHA IF(CONTEN(IHIST3,J).NE.0)THEN CONTEN(IHIST4,J)=CONTEN(IHIST1,J)/CONTEN(IHIST3,J) ELSE CONTEN(IHIST4,J)=0.0 ENDIF 40 CONTINUE MODREG(INS(I,4))=4 ELSEIF(INS(I,2).EQ.5)THEN DO 50 J=1,NNCHA IF(ABS(CONTEN(IHIST3,J)-NINT(CONTEN(IHIST3,J))).LT.EPS)THEN IF(NINT(CONTEN(IHIST3,J)).LE.0.AND. - CONTEN(IHIST1,J).EQ.0)THEN CONTEN(IHIST4,J)=0.0 ELSEIF(2*(NINT(CONTEN(IHIST3,J))/2).EQ. - NINT(CONTEN(IHIST3,J)))THEN CONTEN(IHIST4,J)=ABS(CONTEN(IHIST1,J))** - NINT(CONTEN(IHIST3,J)) ELSE CONTEN(IHIST4,J)=SIGN(ABS(CONTEN(IHIST1,J))** - NINT(CONTEN(IHIST3,J)),CONTEN(IHIST1,J)) ENDIF ELSEIF(CONTEN(IHIST1,J).EQ.0.AND.CONTEN(IHIST3,J).GT.0)THEN CONTEN(IHIST4,J)=0 ELSEIF(CONTEN(IHIST1,J).GT.0)THEN CONTEN(IHIST4,J)=CONTEN(IHIST1,J)**CONTEN(IHIST3,J) ELSE NAERR(11)=NAERR(11)+1 CONTEN(IHIST4,J)=0.0 ENDIF 50 CONTINUE MODREG(INS(I,4))=4 * Numerical function calls. ELSEIF(INS(I,2).EQ.6)THEN MODREG(INS(I,4))=4 DO 60 J=1,NNCHA IF(INS(I,1).EQ. 1)THEN IF(CONTEN(IHIST3,J).GT.EXPMAX)THEN NAERR(2)=NAERR(2)+1 CONTEN(IHIST4,J)=EXP(EXPMAX) RETURN ELSEIF(CONTEN(IHIST3,J).LT.-EXPMAX)THEN IF(LIGUND)THEN CONTEN(IHIST4,J)=0 ELSE NAERR(3)=NAERR(3)+1 RETURN ENDIF ELSE CONTEN(IHIST4,J)=EXP(CONTEN(IHIST3,J)) ENDIF ELSEIF(INS(I,1).EQ.-1)THEN IF(CONTEN(IHIST3,J).LE.0.0)RETURN CONTEN(IHIST4,J)=LOG(CONTEN(IHIST3,J)) ENDIF IF((INS(I,1).EQ.-2.OR.INS(I,1).EQ.-3).AND. - ABS(CONTEN(IHIST3,J)).GT.1.0)THEN CONTEN(IHIST4,J)=0.0 ELSE IF(INS(I,1).EQ.-2)CONTEN(IHIST4,J)= - ASIN(CONTEN(IHIST3,J)) IF(INS(I,1).EQ.-3)CONTEN(IHIST4,J)= - ACOS(CONTEN(IHIST3,J)) ENDIF IF(INS(I,1).EQ. 2)CONTEN(IHIST4,J)= SIN(CONTEN(IHIST3,J)) IF(INS(I,1).EQ. 3)CONTEN(IHIST4,J)= COS(CONTEN(IHIST3,J)) IF(INS(I,1).EQ. 4)CONTEN(IHIST4,J)= TAN(CONTEN(IHIST3,J)) IF(INS(I,1).EQ.-4)CONTEN(IHIST4,J)= ATAN(CONTEN(IHIST3,J)) IF(INS(I,1).EQ. 5)CONTEN(IHIST4,J)= ABS(CONTEN(IHIST3,J)) IF(INS(I,1).EQ.-5)THEN IF(CONTEN(IHIST3,J).LT.0.0)THEN CONTEN(IHIST4,J)=-1.0 ELSE CONTEN(IHIST4,J)=SQRT(CONTEN(IHIST3,J)) ENDIF ENDIF IF(INS(I,1).EQ. 6)CONTEN(IHIST4,J)= CONTEN(IHIST3,J) IF(INS(I,1).EQ.-6)CONTEN(IHIST4,J)= -CONTEN(IHIST3,J) IF(INS(I,1).EQ. 7)CONTEN(IHIST4,J)= SINH(CONTEN(IHIST3,J)) IF(INS(I,1).EQ.-7)CONTEN(IHIST4,J)=LOG(CONTEN(IHIST3,J)+ - SQRT(1+CONTEN(IHIST3,J)**2)) IF(INS(I,1).EQ. 8)CONTEN(IHIST4,J)= COSH(CONTEN(IHIST3,J)) IF(INS(I,1).EQ.-8)THEN IF(CONTEN(IHIST3,J).LT.1)THEN CONTEN(IHIST4,J)=0.0 ELSE CONTEN(IHIST4,J)=LOG(CONTEN(IHIST3,J)+ - SQRT(CONTEN(IHIST3,J)**2-1)) ENDIF ENDIF IF(INS(I,1).EQ. 9)CONTEN(IHIST4,J)= TANH(CONTEN(IHIST3,J)) IF(INS(I,1).EQ.-9)THEN IF(CONTEN(IHIST3,J).LE.-1.0.OR. - CONTEN(IHIST3,J).GE.1.0)THEN CONTEN(IHIST4,J)=0.0 ELSE CONTEN(IHIST4,J)=0.5*LOG((1+CONTEN(IHIST3,J))/ - (1-CONTEN(IHIST3,J))) ENDIF ENDIF * Truncation of a real number. IF(INS(I,1).EQ.11)THEN CONTEN(IHIST4,J)=INT(CONTEN(IHIST3,J)) IF(CONTEN(IHIST3,J).LT.0)CONTEN(IHIST4,J)= - CONTEN(IHIST4,J)-1.0 ELSEIF(INS(I,1).EQ.-11)THEN CONTEN(IHIST4,J)=CONTEN(IHIST3,J)-INT(CONTEN(IHIST3,J)) IF(CONTEN(IHIST3,J).LT.0)CONTEN(IHIST4,J)= - CONTEN(IHIST4,J)+1.0 ENDIF * Landau density. IF(INS(I,1).EQ.18)CONTEN(IHIST4,J)= - DENLAN(REAL(CONTEN(IHIST3,J))) * Gamma function. IF(INS(I,1).EQ.47)THEN IF(CONTEN(IHIST3,J).LT.1E-20)THEN NAERR(12)=NAERR(12)+1 CONTEN(IHIST4,J)=0.0 ELSEIF(CONTEN(IHIST3,J).GT.25.0)THEN NAERR(13)=NAERR(13)+1 CONTEN(IHIST4,J)=0.0 ELSE CONTEN(IHIST4,J)=DGAMMA(CONTEN(IHIST3,J)) ENDIF * log-Gamma function. ELSEIF(INS(I,1).EQ.48)THEN IF(CONTEN(IHIST3,J).LE.0)THEN NAERR(14)=NAERR(14)+1 CONTEN(IHIST4,J)=0.0 ELSE CONTEN(IHIST4,J)=DLGAMA(CONTEN(IHIST3,J)) ENDIF ENDIF 60 CONTINUE * Make a string from a number. IF(INS(I,1).EQ.12)THEN CALL STRBUF('STORE',IREF,'Histogram',9,IFAIL) IF(IFAIL.NE.0)RETURN MODREG(INS(I,4))=1 REG(INS(I,4))=IREF * Sum and product. ELSEIF(INS(I,1).EQ.13)THEN REG(INS(I,4))=0 MODREG(INS(I,4))=2 DO 90 J=1,NNCHA REG(INS(I,4))=REG(INS(I,4))+CONTEN(IHIST3,J) 90 CONTINUE ELSEIF(INS(I,1).EQ.14)THEN REG(INS(I,4))=1 MODREG(INS(I,4))=2 DO 100 J=1,NNCHA REG(INS(I,4))=REG(INS(I,4))*CONTEN(IHIST3,J) 100 CONTINUE * Reference of an histogram. ELSEIF(INS(I,1).EQ.15)THEN REG(INS(I,4))=IHIST3 MODREG(INS(I,4))=2 * Maximum and minimum. ELSEIF(INS(I,1).EQ.19)THEN REG(INS(I,4))=CONTEN(IHIST3,1) MODREG(INS(I,4))=2 DO 95 J=2,NNCHA REG(INS(I,4))=MIN(REG(INS(I,4)),CONTEN(IHIST3,J)) 95 CONTINUE ELSEIF(INS(I,1).EQ.20)THEN REG(INS(I,4))=CONTEN(IHIST3,1) MODREG(INS(I,4))=2 DO 96 J=2,NNCHA REG(INS(I,4))=MAX(REG(INS(I,4)),CONTEN(IHIST3,J)) 96 CONTINUE * Mean and RMS. ELSEIF(INS(I,1).EQ.41)THEN CALL HISINQ(IHIST3,HEXIST,HSET,NNCHA,XXMIN,XXMAX, - NNENTR,AVER,RMS) REG(INS(I,4))=AVER MODREG(INS(I,4))=2 ELSEIF(INS(I,1).EQ.42)THEN CALL HISINQ(IHIST3,HEXIST,HSET,NNCHA,XXMIN,XXMAX, - NNENTR,AVER,RMS) REG(INS(I,4))=RMS MODREG(INS(I,4))=2 * Locate a global variable from its name. ELSEIF(INS(I,1).EQ.16)THEN CALL STRBUF('READ',NINT(REG(INS(I,3))),STR1,NC1,IFAIL1) DO 101 J=1,NGLB IF(STR1(1:NC1).EQ.GLBVAR(J))THEN MODREG(INS(I,4))=GLBMOD(J) REG(INS(I,4))=GLBVAL(J) GOTO 102 ENDIF 101 CONTINUE MODREG(INS(I,4))=0 REG(INS(I,4))=0 102 CONTINUE * Return the type of the argument. ELSEIF(INS(I,1).EQ.17)THEN CALL STRBUF('STORE',IREF,'Histogram',9,IFAIL1) IF(IFAIL1.NE.0)RETURN REG(INS(I,4))=IREF MODREG(INS(I,4))=1 * Random number according to a histogram. ELSEIF(INS(I,1).EQ.28)THEN CALL RNDHIS(IHIST3,XAUX) REG(INS(I,4))=XAUX MODREG(INS(I,4))=2 ENDIF * Random number generators. DO 110 J=1,NNCHA IF(INS(I,1).EQ.21)THEN CONTEN(IHIST4,J)=DBLE(RNDUNI(REG(INS(I,3)))) ELSEIF(INS(I,1).EQ.22)THEN CONTEN(IHIST4,J)=DBLE(RNDNOR(0.0,1.0)) ELSEIF(INS(I,1).EQ.23)THEN CONTEN(IHIST4,J)=DBLE(RNDEXP(REAL(CONTEN(IHIST3,J)))) ELSEIF(INS(I,1).EQ.24)THEN CALL RNPSSN(REAL(CONTEN(IHIST3,J)),NPOIS,IERR) CONTEN(IHIST4,J)=DBLE(NPOIS) ELSEIF(INS(I,1).EQ.25)THEN CONTEN(IHIST4,J)=DBLE(RANLAN(REAL(RNDUNI(1.0)))) ELSEIF(INS(I,1).EQ.26)THEN CONTEN(IHIST4,J)=DBLE(RNDPOL(REAL(CONTEN(IHIST3,J)))) ELSEIF(INS(I,1).EQ.27)THEN CONTEN(IHIST4,J)=DBLE(RNDFUN(REAL(CONTEN(IHIST3,J)))) ELSEIF(INS(I,1).EQ.29)THEN IF(CONTEN(IHIST3,J).GT.0)THEN CONTEN(IHIST4,J)= - DBLE(RNGAMA(REAL(CONTEN(IHIST3,J)))) ELSE CONTEN(IHIST4,J)=0 NAERR(14)=NAERR(14)+1 ENDIF ELSEIF(INS(I,1).EQ.30)THEN CONTEN(IHIST4,J)=DBLE(RNDLAP(REAL(CONTEN(IHIST3,J)))) ENDIF 110 CONTINUE * Binary logical operators between real type arguments. ELSEIF(INS(I,2).EQ.10)THEN MODREG(INS(I,4))=3 REG(INS(I,4))=1.0 DO 120 J=1,NNCHA IF(ABS(CONTEN(IHIST1,J)-CONTEN(IHIST3,J)).GT.EPS) - REG(INS(I,4))=0.0 120 CONTINUE ELSEIF(INS(I,2).EQ.11)THEN MODREG(INS(I,4))=3 REG(INS(I,4))=0.0 DO 130 J=1,NNCHA IF(ABS(CONTEN(IHIST1,J)-CONTEN(IHIST3,J)).GT.EPS) - REG(INS(I,4))=1.0 130 CONTINUE ELSEIF(INS(I,2).EQ.12)THEN MODREG(INS(I,4))=3 REG(INS(I,4))=1.0 DO 140 J=1,NNCHA IF(CONTEN(IHIST1,J).GE.CONTEN(IHIST3,J))REG(INS(I,4))=0.0 140 CONTINUE ELSEIF(INS(I,2).EQ.13)THEN MODREG(INS(I,4))=3 REG(INS(I,4))=1.0 DO 150 J=1,NNCHA IF(CONTEN(IHIST1,J).GT.CONTEN(IHIST3,J))REG(INS(I,4))=0.0 150 CONTINUE ELSEIF(INS(I,2).EQ.14)THEN MODREG(INS(I,4))=3 REG(INS(I,4))=1.0 DO 160 J=1,NNCHA IF(CONTEN(IHIST1,J).LE.CONTEN(IHIST3,J))REG(INS(I,4))=0.0 160 CONTINUE ELSEIF(INS(I,2).EQ.15)THEN MODREG(INS(I,4))=3 REG(INS(I,4))=1.0 DO 170 J=1,NNCHA IF(CONTEN(IHIST1,J).LT.CONTEN(IHIST3,J))REG(INS(I,4))=0.0 170 CONTINUE * Unidentified operation code. ELSE MODREG(INS(I,4))=0 RETURN ENDIF *** Delete auxiliary histograms. IF(INS(I,2).NE.6)THEN IF(MODREG(INS(I,1)).EQ.2) - CALL HISADM('DELETE',IHIST1,NNCHA,XXMIN,XXMAX, - .FALSE.,IFAIL1) ENDIF IF(MODREG(INS(I,3)).EQ.2) - CALL HISADM('DELETE',IHIST3,NNCHA,XXMIN,XXMAX, - .FALSE.,IFAIL1) *** Delete output histogram if not used. IF(MODREG(INS(I,4)).NE.4)THEN CALL HISADM('DELETE',IHIST4,NNCHA,XXMIN,XXMAX, - .FALSE.,IFAIL1) ELSE * Make visible if used. REG(INS(I,4))=IHIST4 * And provide the various sums. SX0(IHIST4)=0.0 SX1(IHIST4)=0.0 SX2(IHIST4)=0.0 DO 200 J=1,NNCHA XX=XXMIN+REAL(J-0.5)*(XXMAX-XXMIN)/REAL(NNCHA) SX0(IHIST4)=SX0(IHIST4)+CONTEN(IHIST4,J) SX1(IHIST4)=SX1(IHIST4)+CONTEN(IHIST4,J)*XX SX2(IHIST4)=SX2(IHIST4)+CONTEN(IHIST4,J)*XX**2 200 CONTINUE NENTRY(IHIST4)=1 ENDIF *** Reset IFAIL to 0 because the calculations were probably successful. IFAIL=0 END +DECK,ALGEX6. SUBROUTINE ALGEX6(I,IFAIL) *----------------------------------------------------------------------- * ALGEX6 - Routine executing instruction I (produced by ALGPRE). * This routine takes care of arithmetic operations between * matrices. * (Last changed on 17/ 2/12.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,ALGDATA. +SEQ,MATDATA. +SEQ,GLOBALS. +SEQ,PRINTPLOT. REAL DENLAN,RNDUNI,RANLAN,RNDEXP,RNDNOR,RNDPOL,RNDFUN,EPS,GAMMA, - ALGAMA,RNGAMA,RNDLAP DOUBLE PRECISION SX1,SX2 INTEGER IFAIL,IFAIL1,IMAT1,IMAT3,IMAT4,IREF1,IREF3,IREF4,I,J, - NDIM,IMOD,IDIM(MXMDIM),MATSLT,NPOIS,IREF,IERR,NC1,NCAUX,NOUT CHARACTER*(MXINCH) STR1,AUXSTR EXTERNAL RNDUNI,RANLAN,RNDEXP,RNDNOR,RNDPOL,RNDFUN,MATSLT,DENLAN, - GAMMA,ALGAMA,RNGAMA,RNDLAP *** Set IFAIL to 1 and EPS. IFAIL=1 +SELF,IF=CRAY. EPS=1.0E-10 +SELF,IF=-CRAY. EPS=1.0E-5 +SELF. *** For easier reference, define matrix references. IREF1=NINT(REG(INS(I,1))) IREF3=NINT(REG(INS(I,3))) IREF4=NINT(REG(INS(I,4))) IMAT1=MATSLT(IREF1) IMAT3=MATSLT(IREF3) IMAT4=MATSLT(IREF4) *** Verify that the objects are indeed valid matrices. IF(INS(I,2).NE.6.AND.MODREG(INS(I,1)).EQ.5.AND. - MODREG(INS(I,3)).EQ.5)THEN * Check that the matrices do indeed exist. IF(IMAT1.LE.0.OR.IMAT3.LE.0)THEN MODREG(INS(I,4))=0 REG(INS(I,4))=0 IF(LDEBUG)THEN PRINT *,' ++++++ ALGEX6 DEBUG : Reference to'// - ' an unbooked matrix.' PRINT *,' Arg 1: ref=', - IMAT1,', Arg 3: ref=',IMAT3 ENDIF NAERR(61)=NAERR(61)+1 RETURN * The matrices must have the same overall size. ELSEIF(INS(I,2).NE.16.AND.MLEN(IMAT1).NE.MLEN(IMAT3))THEN MODREG(INS(I,4))=0 REG(INS(I,4))=0 IF(LDEBUG)THEN PRINT *,' ++++++ ALGEX6 DEBUG : Matrices'// - ' have differing length.' PRINT *,' Arg 1: ref=', - IMAT1,' length=',MLEN(IMAT1) PRINT *,' Arg 3: ref=', - IMAT3,' length=',MLEN(IMAT3) ENDIF NAERR(62)=NAERR(62)+1 RETURN ENDIF * Validity of reference number. ELSEIF(INS(I,2).NE.6.AND.MODREG(INS(I,1)).EQ.5.AND. - IMAT1.LE.0)THEN MODREG(INS(I,4))=0 REG(INS(I,4))=0 IF(LDEBUG)PRINT *,' ++++++ ALGEX6 DEBUG :'// - ' Refering to unbooked matrix ',IMAT1 NAERR(61)=NAERR(61)+1 RETURN ELSEIF(MODREG(INS(I,3)).EQ.5.AND.IMAT3.LE.0)THEN MODREG(INS(I,4))=0 REG(INS(I,4))=0 IF(LDEBUG)PRINT *,' ++++++ ALGEX6 DEBUG :'// - ' Refering to unbooked matrix ',IMAT3 NAERR(61)=NAERR(61)+1 RETURN * Check nothing else than numbers and matrices appear. ELSEIF((INS(I,2).EQ.6.AND.MODREG(INS(I,3)).NE.5).OR. - (INS(I,2).NE.6.AND.((MODREG(INS(I,1)).NE.2.AND. - MODREG(INS(I,1)).NE.5).OR.(MODREG(INS(I,3)).NE.2.AND. - MODREG(INS(I,3)).NE.5))))THEN MODREG(INS(I,4))=0 REG(INS(I,4))=0 IF(LDEBUG)THEN PRINT *,' ++++++ ALGEX6 DEBUG : Unable to'// - ' handle received modes' PRINT *,' Arg 1: ref=', - IMAT1,' mode=',MODREG(INS(I,1)) PRINT *,' Arg 3: ref=', - IMAT3,' mode=',MODREG(INS(I,3)) ENDIF RETURN ENDIF *** Set parameters of resulting matrix: function calls. IF(INS(I,2).EQ.6)THEN IF(MODREG(INS(I,3)).EQ.5)THEN DO 340 J=1,MDIM(IMAT3) IDIM(J)=MSIZ(IMAT3,J) 340 CONTINUE NDIM=MDIM(IMAT3) IMOD=MMOD(IMAT3) ELSE IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ ALGEX6 DEBUG :'', - '' Unable to get output matrix format.'')') RETURN ENDIF * Concatenation. ELSEIF(INS(I,2).EQ.16)THEN IF(MODREG(INS(I,1)).EQ.5.AND.MODREG(INS(I,3)).EQ.5)THEN NDIM=1 IDIM(1)=MLEN(IMAT1)+MLEN(IMAT3) IMOD=MMOD(IMAT1) ELSEIF(MODREG(INS(I,1)).EQ.5)THEN NDIM=1 IDIM(1)=MLEN(IMAT1)+1 IMOD=MMOD(IMAT1) ELSEIF(MODREG(INS(I,3)).EQ.5)THEN NDIM=1 IDIM(1)=MLEN(IMAT3)+1 IMOD=MMOD(IMAT3) ELSE NDIM=1 IDIM(1)=2 IMOD=2 ENDIF * Numeric calls. ELSE IF(MODREG(INS(I,1)).EQ.5)THEN DO 350 J=1,MDIM(IMAT1) IDIM(J)=MSIZ(IMAT1,J) 350 CONTINUE NDIM=MDIM(IMAT1) IMOD=MMOD(IMAT1) ELSEIF(MODREG(INS(I,3)).EQ.5)THEN DO 360 J=1,MDIM(IMAT3) IDIM(J)=MSIZ(IMAT3,J) 360 CONTINUE NDIM=MDIM(IMAT3) IMOD=MMOD(IMAT3) ELSE IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ ALGEX6 DEBUG :'', - '' Unable to get output matrix format.'')') RETURN ENDIF ENDIF *** If one of the arguments is scalar, turn into a matrix. IF(INS(I,2).NE.6.AND.INS(I,2).NE.16.AND. - MODREG(INS(I,1)).EQ.2)THEN IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ ALGEX6 DEBUG :'', - '' Creating a replacement matrix for INS(I,1).'')') CALL MATADM('ALLOCATE',IREF1,NDIM,IDIM,IMOD,IFAIL1) IF(IFAIL1.NE.0)RETURN IMAT1=MATSLT(IREF1) IF(IMAT1.LE.0)THEN IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ ALGEX6'', - '' DEBUG : Unable to locate scalar'', - '' replacement matrix 1.'')') RETURN ENDIF DO 380 J=1,MLEN(IMAT1) MVEC(MORG(IMAT1)+J)=REG(INS(I,1)) 380 CONTINUE ENDIF IF(INS(I,2).NE.16.AND.MODREG(INS(I,3)).EQ.2)THEN IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ ALGEX6 DEBUG :'', - '' Creating a replacement matrix for INS(I,3).'')') CALL MATADM('ALLOCATE',IREF3,NDIM,IDIM,IMOD,IFAIL1) IF(IFAIL1.NE.0)RETURN IMAT3=MATSLT(IREF3) IF(IMAT3.LE.0)THEN IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ ALGEX6'', - '' DEBUG : Unable to locate scalar'', - '' replacement matrix 3.'')') RETURN ENDIF DO 400 J=1,MLEN(IMAT3) MVEC(MORG(IMAT3)+J)=REG(INS(I,3)) 400 CONTINUE ENDIF *** Allocate a matrix for the result. CALL MATADM('ALLOCATE',IREF4,NDIM,IDIM,IMOD,IFAIL1) IF(IFAIL1.NE.0)RETURN REG(INS(I,4))=IREF4 MODREG(INS(I,4))=5 *** Establish final locations for the various matrices, first word. IF(INS(I,2).NE.6.AND. - (INS(I,2).NE.16.OR.MODREG(INS(I,1)).EQ.5))THEN IMAT1=MATSLT(IREF1) IF(IMAT1.LE.0)THEN IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ ALGEX6'', - '' DEBUG : Unable to locate scalar'', - '' replacement matrix 1.'')') RETURN ENDIF ENDIF * Third word. IF(INS(I,2).NE.16.OR.MODREG(INS(I,3)).EQ.5)THEN IMAT3=MATSLT(IREF3) IF(IMAT3.LE.0)THEN IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ ALGEX6'', - '' DEBUG : Unable to locate scalar'', - '' replacement matrix 3.'')') RETURN ENDIF ENDIF * Result. IMAT4=MATSLT(IREF4) IF(IMAT4.LE.0)THEN IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ ALGEX6'', - '' DEBUG : Unable to locate scalar'', - '' replacement result matrix.'')') RETURN ENDIF *** Perform the actual calculation: binary numerical operators. IF(INS(I,2).EQ.1)THEN DO 10 J=1,MLEN(IMAT4) MVEC(MORG(IMAT4)+J)=MVEC(MORG(IMAT1)+J)+MVEC(MORG(IMAT3)+J) 10 CONTINUE MODREG(INS(I,4))=5 ELSEIF(INS(I,2).EQ.2)THEN DO 20 J=1,MLEN(IMAT4) MVEC(MORG(IMAT4)+J)=MVEC(MORG(IMAT1)+J)-MVEC(MORG(IMAT3)+J) 20 CONTINUE MODREG(INS(I,4))=5 ELSEIF(INS(I,2).EQ.3)THEN DO 30 J=1,MLEN(IMAT4) MVEC(MORG(IMAT4)+J)=MVEC(MORG(IMAT1)+J)*MVEC(MORG(IMAT3)+J) 30 CONTINUE MODREG(INS(I,4))=5 ELSEIF(INS(I,2).EQ.4)THEN DO 40 J=1,MLEN(IMAT4) IF(MVEC(MORG(IMAT3)+J).NE.0)THEN MVEC(MORG(IMAT4)+J)=MVEC(MORG(IMAT1)+J)/ - MVEC(MORG(IMAT3)+J) ELSE MVEC(MORG(IMAT4)+J)=0.0 ENDIF 40 CONTINUE MODREG(INS(I,4))=5 ELSEIF(INS(I,2).EQ.5)THEN DO 50 J=1,MLEN(IMAT4) IF(ABS(MVEC(MORG(IMAT3)+J)- - NINT(MVEC(MORG(IMAT3)+J))).LT.EPS)THEN IF(NINT(MVEC(MORG(IMAT3)+J)).LE.0.AND. - MVEC(MORG(IMAT1)+J).EQ.0)THEN MVEC(MORG(IMAT4)+J)=0.0 ELSEIF(2*(NINT(MVEC(MORG(IMAT3)+J))/2).EQ. - NINT(MVEC(MORG(IMAT3)+J)))THEN MVEC(MORG(IMAT4)+J)=ABS(MVEC(MORG(IMAT1)+J))** - NINT(MVEC(MORG(IMAT3)+J)) ELSE MVEC(MORG(IMAT4)+J)= - SIGN(ABS(MVEC(MORG(IMAT1)+J))** - NINT(MVEC(MORG(IMAT3)+J)), - MVEC(MORG(IMAT1)+J)) ENDIF ELSEIF(MVEC(MORG(IMAT1)+J).EQ.0.AND. - MVEC(MORG(IMAT3)+J).GT.0)THEN MVEC(MORG(IMAT4)+J)=0 ELSEIF(MVEC(MORG(IMAT1)+J).GT.0)THEN MVEC(MORG(IMAT4)+J)=MVEC(MORG(IMAT1)+J)** - MVEC(MORG(IMAT3)+J) ELSE MVEC(MORG(IMAT4)+J)=0.0 NAERR(11)=NAERR(11)+1 ENDIF 50 CONTINUE MODREG(INS(I,4))=5 * Numerical function calls. ELSEIF(INS(I,2).EQ.6)THEN MODREG(INS(I,4))=5 DO 60 J=1,MLEN(IMAT4) IF(INS(I,1).EQ. 1)THEN IF(MVEC(MORG(IMAT3)+J).GT.EXPMAX)THEN NAERR(2)=NAERR(2)+1 MVEC(MORG(IMAT4)+J)=EXP(EXPMAX) RETURN ELSEIF(MVEC(MORG(IMAT3)+J).LT.-EXPMAX)THEN IF(LIGUND)THEN MVEC(MORG(IMAT4)+J)=0 ELSE NAERR(3)=NAERR(3)+1 RETURN ENDIF ELSE MVEC(MORG(IMAT4)+J)=EXP(MVEC(MORG(IMAT3)+J)) ENDIF ELSEIF(INS(I,1).EQ.-1)THEN IF(MVEC(MORG(IMAT3)+J).LE.0.0)RETURN MVEC(MORG(IMAT4)+J)=LOG(MVEC(MORG(IMAT3)+J)) ENDIF IF((INS(I,1).EQ.-2.OR.INS(I,1).EQ.-3).AND. - ABS(MVEC(MORG(IMAT3)+J)).GT.1.0)THEN MVEC(MORG(IMAT4)+J)=0.0 ELSE IF(INS(I,1).EQ.-2)MVEC(MORG(IMAT4)+J)= - ASIN(MVEC(MORG(IMAT3)+J)) IF(INS(I,1).EQ.-3)MVEC(MORG(IMAT4)+J)= - ACOS(MVEC(MORG(IMAT3)+J)) ENDIF IF(INS(I,1).EQ. 2)MVEC(MORG(IMAT4)+J)= - SIN(MVEC(MORG(IMAT3)+J)) IF(INS(I,1).EQ. 3)MVEC(MORG(IMAT4)+J)= - COS(MVEC(MORG(IMAT3)+J)) IF(INS(I,1).EQ. 4)MVEC(MORG(IMAT4)+J)= - TAN(MVEC(MORG(IMAT3)+J)) IF(INS(I,1).EQ.-4)MVEC(MORG(IMAT4)+J)= - ATAN(MVEC(MORG(IMAT3)+J)) IF(INS(I,1).EQ. 5)MVEC(MORG(IMAT4)+J)= - ABS(MVEC(MORG(IMAT3)+J)) IF(INS(I,1).EQ.-5)THEN IF(MVEC(MORG(IMAT3)+J).LT.0.0)THEN MVEC(MORG(IMAT4)+J)=-1.0 ELSE MVEC(MORG(IMAT4)+J)=SQRT(MVEC(MORG(IMAT3)+J)) ENDIF ENDIF IF(INS(I,1).EQ. 6)MVEC(MORG(IMAT4)+J)= - MVEC(MORG(IMAT3)+J) IF(INS(I,1).EQ.-6)MVEC(MORG(IMAT4)+J)= - -MVEC(MORG(IMAT3)+J) IF(INS(I,1).EQ. 7)MVEC(MORG(IMAT4)+J)= - SINH(MVEC(MORG(IMAT3)+J)) IF(INS(I,1).EQ.-7)MVEC(MORG(IMAT4)+J)= - LOG(MVEC(MORG(IMAT3)+J)+ - SQRT(1+MVEC(MORG(IMAT3)+J)**2)) IF(INS(I,1).EQ. 8)MVEC(MORG(IMAT4)+J)= - COSH(MVEC(MORG(IMAT3)+J)) IF(INS(I,1).EQ.-8)THEN IF(MVEC(MORG(IMAT3)+J).LT.1)THEN MVEC(MORG(IMAT4)+J)=0.0 ELSE MVEC(MORG(IMAT4)+J)=LOG(MVEC(MORG(IMAT3)+J)+ - SQRT(MVEC(MORG(IMAT3)+J)**2-1)) ENDIF ENDIF IF(INS(I,1).EQ. 9)MVEC(MORG(IMAT4)+J)= - TANH(MVEC(MORG(IMAT3)+J)) IF(INS(I,1).EQ.-9)THEN IF(MVEC(MORG(IMAT3)+J).LE.-1.0.OR. - MVEC(MORG(IMAT3)+J).GE.1.0)THEN MVEC(MORG(IMAT4)+J)=0.0 ELSE MVEC(MORG(IMAT4)+J)= - 0.5*LOG((1+MVEC(MORG(IMAT3)+J))/ - (1-MVEC(MORG(IMAT3)+J))) ENDIF ENDIF * Truncation of a real number. IF(INS(I,1).EQ.11)THEN MVEC(MORG(IMAT4)+J)=INT(MVEC(MORG(IMAT3)+J)) IF(MVEC(MORG(IMAT3)+J).LT.0)MVEC(MORG(IMAT4)+J)= - MVEC(MORG(IMAT4)+J)-1.0 ELSEIF(INS(I,1).EQ.-11)THEN MVEC(MORG(IMAT4)+J)= - MVEC(MORG(IMAT3)+J)-INT(MVEC(MORG(IMAT3)+J)) IF(MVEC(MORG(IMAT3)+J).LT.0)MVEC(MORG(IMAT4)+J)= - MVEC(MORG(IMAT4)+J)+1.0 ENDIF * Landau density. IF(INS(I,1).EQ.18)MVEC(MORG(IMAT4)+J)= - DENLAN(MVEC(MORG(IMAT3)+J)) * Gamma function. IF(INS(I,1).EQ.47)THEN IF(MVEC(MORG(IMAT3)+J).LT.1E-20)THEN NAERR(12)=NAERR(12)+1 MVEC(MORG(IMAT4)+J)=0.0 ELSEIF(MVEC(MORG(IMAT3)+J).GT.25.0)THEN NAERR(13)=NAERR(13)+1 MVEC(MORG(IMAT4)+J)=0.0 ELSE MVEC(MORG(IMAT4)+J)=GAMMA(MVEC(MORG(IMAT3)+J)) ENDIF * log-Gamma function. ELSEIF(INS(I,1).EQ.48)THEN IF(MVEC(MORG(IMAT3)+J).LE.0)THEN NAERR(14)=NAERR(14)+1 MVEC(MORG(IMAT4)+J)=0.0 ELSE MVEC(MORG(IMAT4)+J)=ALGAMA(MVEC(MORG(IMAT3)+J)) ENDIF ENDIF 60 CONTINUE * Make a string from a matrix. IF(INS(I,1).EQ.12)THEN CALL OUTFMT(REG(INS(I,3)),MODREG(INS(I,3)), - AUXSTR,NCAUX,'LEFT') CALL STRBUF('STORE',IREF,AUXSTR(1:NCAUX),NCAUX,IFAIL) IF(IFAIL.NE.0)RETURN MODREG(INS(I,4))=1 REG(INS(I,4))=IREF * Return the real number of the matrix. ELSEIF(INS(I,1).EQ.-12)THEN REG(INS(I,4))=MVEC(MORG(IMAT3)+1) MODREG(INS(I,4))=2 * Sum and product. ELSEIF(INS(I,1).EQ.13)THEN REG(INS(I,4))=0 MODREG(INS(I,4))=2 DO 90 J=1,MLEN(IMAT4) REG(INS(I,4))=REG(INS(I,4))+MVEC(MORG(IMAT3)+J) 90 CONTINUE ELSEIF(INS(I,1).EQ.14)THEN REG(INS(I,4))=1 MODREG(INS(I,4))=2 DO 100 J=1,MLEN(IMAT4) REG(INS(I,4))=REG(INS(I,4))*MVEC(MORG(IMAT3)+J) 100 CONTINUE * Maximum and minimum. ELSEIF(INS(I,1).EQ.19)THEN REG(INS(I,4))=MVEC(MORG(IMAT3)+1) MODREG(INS(I,4))=2 DO 180 J=2,MLEN(IMAT3) REG(INS(I,4))=MIN(REG(INS(I,4)),MVEC(MORG(IMAT3)+J)) 180 CONTINUE ELSEIF(INS(I,1).EQ.20)THEN REG(INS(I,4))=MVEC(MORG(IMAT3)+1) MODREG(INS(I,4))=2 DO 190 J=2,MLEN(IMAT3) REG(INS(I,4))=MAX(REG(INS(I,4)),MVEC(MORG(IMAT3)+J)) 190 CONTINUE * Mean and RMS. ELSEIF(INS(I,1).EQ.41.OR.INS(I,1).EQ.42)THEN SX1=0 SX2=0 DO 200 J=1,MLEN(IMAT3) SX1=SX1+MVEC(MORG(IMAT3)+J) SX2=SX2+MVEC(MORG(IMAT3)+J)**2 200 CONTINUE IF(MLEN(IMAT3).LT.1)RETURN IF(INS(I,1).EQ.41)THEN REG(INS(I,4))=SX1/MLEN(IMAT3) ELSE REG(INS(I,4))=SQRT(MAX(0.0D0, - (SX2-SX1**2/MLEN(IMAT3))/MLEN(IMAT3))) ENDIF MODREG(INS(I,4))=2 * Overall size of a matrix. ELSEIF(INS(I,1).EQ.43)THEN REG(INS(I,4))=MLEN(IMAT3) MODREG(INS(I,4))=2 * Return the reference of the matrix. ELSEIF(INS(I,1).EQ.15)THEN REG(INS(I,4))=IMAT3 MODREG(INS(I,4))=2 * Locate a global variable from its name. ELSEIF(INS(I,1).EQ.16)THEN CALL STRBUF('READ',NINT(REG(INS(I,3))),STR1,NC1,IFAIL1) DO 70 J=1,NGLB IF(STR1(1:NC1).EQ.GLBVAR(J))THEN MODREG(INS(I,4))=GLBMOD(J) REG(INS(I,4))=GLBVAL(J) GOTO 75 ENDIF 70 CONTINUE MODREG(INS(I,4))=0 REG(INS(I,4))=0 75 CONTINUE * Return the type of the argument. ELSEIF(INS(I,1).EQ.17)THEN CALL STRBUF('STORE',IREF,'Matrix',6,IFAIL1) IF(IFAIL1.NE.0)RETURN REG(INS(I,4))=IREF MODREG(INS(I,4))=1 * Reverse a matrix. ELSEIF(INS(I,1).EQ.49)THEN DO 76 J=1,MLEN(IMAT3) MVEC(MORG(IMAT4)+J)=MVEC(MORG(IMAT3)+MLEN(IMAT3)-J+1) 76 CONTINUE ENDIF * Random number generators. DO 110 J=1,MLEN(IMAT4) IF(INS(I,1).EQ.21)THEN MVEC(MORG(IMAT4)+J)=RNDUNI(REG(INS(I,3))) ELSEIF(INS(I,1).EQ.22)THEN MVEC(MORG(IMAT4)+J)=RNDNOR(0.0,1.0) ELSEIF(INS(I,1).EQ.23)THEN MVEC(MORG(IMAT4)+J)=RNDEXP(MVEC(MORG(IMAT3)+J)) ELSEIF(INS(I,1).EQ.24)THEN CALL RNPSSN(MVEC(MORG(IMAT3)+J),NPOIS,IERR) MVEC(MORG(IMAT4)+J)=REAL(NPOIS) ELSEIF(INS(I,1).EQ.25)THEN MVEC(MORG(IMAT4)+J)=RANLAN(RNDUNI(1.0)) ELSEIF(INS(I,1).EQ.26)THEN MVEC(MORG(IMAT4)+J)=RNDPOL(MVEC(MORG(IMAT3)+J)) ELSEIF(INS(I,1).EQ.27)THEN MVEC(MORG(IMAT4)+J)=RNDFUN(MVEC(MORG(IMAT3)+J)) ELSEIF(INS(I,1).EQ.29)THEN IF(MVEC(MORG(IMAT3)+J).GT.0)THEN MVEC(MORG(IMAT4)+J)=RNGAMA(MVEC(MORG(IMAT3)+J)) ELSE NAERR(14)=NAERR(14)+1 MVEC(MORG(IMAT4)+J)=0 ENDIF ELSEIF(INS(I,1).EQ.30)THEN MVEC(MORG(IMAT4)+J)=RNDLAP(MVEC(MORG(IMAT3)+J)) ENDIF 110 CONTINUE * Random number generators not to be called. IF(INS(I,1).EQ.28)THEN IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ ALGEX6 DEBUG :'', - '' Generator '',I2,'' does not apply to'', - '' Matrix.'')') INS(I,1) RETURN ENDIF * Binary logical operators between real type arguments. ELSEIF(INS(I,2).EQ.10)THEN MODREG(INS(I,4))=3 REG(INS(I,4))=1.0 DO 120 J=1,MLEN(IMAT4) IF(ABS(MVEC(MORG(IMAT1)+J)-MVEC(MORG(IMAT3)+J)).GT.EPS) - REG(INS(I,4))=0.0 120 CONTINUE ELSEIF(INS(I,2).EQ.11)THEN MODREG(INS(I,4))=3 REG(INS(I,4))=0.0 DO 130 J=1,MLEN(IMAT4) IF(ABS(MVEC(MORG(IMAT1)+J)-MVEC(MORG(IMAT3)+J)).GT.EPS) - REG(INS(I,4))=1.0 130 CONTINUE ELSEIF(INS(I,2).EQ.12)THEN MODREG(INS(I,4))=3 REG(INS(I,4))=1.0 DO 140 J=1,MLEN(IMAT4) IF(MVEC(MORG(IMAT1)+J).GE.MVEC(MORG(IMAT3)+J)) - REG(INS(I,4))=0.0 140 CONTINUE ELSEIF(INS(I,2).EQ.13)THEN MODREG(INS(I,4))=3 REG(INS(I,4))=1.0 DO 150 J=1,MLEN(IMAT4) IF(MVEC(MORG(IMAT1)+J).GT.MVEC(MORG(IMAT3)+J)) - REG(INS(I,4))=0.0 150 CONTINUE ELSEIF(INS(I,2).EQ.14)THEN MODREG(INS(I,4))=3 REG(INS(I,4))=1.0 DO 160 J=1,MLEN(IMAT4) IF(MVEC(MORG(IMAT1)+J).LE.MVEC(MORG(IMAT3)+J)) - REG(INS(I,4))=0.0 160 CONTINUE ELSEIF(INS(I,2).EQ.15)THEN MODREG(INS(I,4))=3 REG(INS(I,4))=1.0 DO 170 J=1,MLEN(IMAT4) IF(MVEC(MORG(IMAT1)+J).LT.MVEC(MORG(IMAT3)+J)) - REG(INS(I,4))=0.0 170 CONTINUE * Concatenation. ELSEIF(INS(I,2).EQ.16)THEN NOUT=0 IF(MODREG(INS(I,1)).EQ.2)THEN NOUT=NOUT+1 MVEC(MORG(IMAT4)+NOUT)=REG(INS(I,1)) ELSE DO 210 J=1,MLEN(IMAT1) NOUT=NOUT+1 MVEC(MORG(IMAT4)+NOUT)=MVEC(MORG(IMAT1)+J) 210 CONTINUE ENDIF IF(MODREG(INS(I,3)).EQ.2)THEN NOUT=NOUT+1 MVEC(MORG(IMAT4)+NOUT)=REG(INS(I,3)) ELSE DO 220 J=1,MLEN(IMAT3) NOUT=NOUT+1 MVEC(MORG(IMAT4)+NOUT)=MVEC(MORG(IMAT3)+J) 220 CONTINUE ENDIF MODREG(INS(I,4))=5 * Unidentified operation code. ELSE MODREG(INS(I,4))=0 RETURN ENDIF *** Delete auxiliary matrices. IF(INS(I,2).NE.6.AND.INS(I,2).NE.16)THEN IF(MODREG(INS(I,1)).EQ.2) - CALL MATADM('DELETE',IREF1,NDIM,IDIM,IMOD,IFAIL1) ENDIF IF(MODREG(INS(I,3)).EQ.2.AND.INS(I,2).NE.16) - CALL MATADM('DELETE',IREF3,NDIM,IDIM,IMOD,IFAIL1) *** Delete output matrix if not used. IF(MODREG(INS(I,4)).NE.5) - CALL MATADM('DELETE',IREF4,NDIM,IDIM,IMOD,IFAIL1) *** Reset IFAIL to 0 because the calculations were probably successful. IFAIL=0 END +DECK,ALGGBC. SUBROUTINE ALGGBC *----------------------------------------------------------------------- * ALGGBC - Performs a garbage collect in the algebra memory. * (Last changed on 1/11/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,ALGDATA. +SEQ,PRINTPLOT. INTEGER NEOLD,NIOLD,NCOLD,I,J,K *** Clean up the entry point list. NEOLD=NALGE NALGE=0 ICONS0=-7 NCOLD=NCONS NCONS=-6 NIOLD=NINS NINS=0 *** Loop over the entry points that are to be kept. DO 10 I=1,NEOLD * But kill constant strings associated with dropped entry points. IF(ALGENT(I,2).EQ.0)THEN DO 15 J=ALGENT(I,8),ALGENT(I,8)-ALGENT(I,9)+1,-1 CALL ALGREU(NINT(REG(J)),MODREG(J),1) 15 CONTINUE GOTO 10 ENDIF * Shift the constants. ICONS0=NCONS-1 DO 70 J=ALGENT(I,8),ALGENT(I,8)-ALGENT(I,9)+1,-1 NCONS=NCONS-1 REG(NCONS)=REG(J) MODREG(NCONS)=MODREG(J) DO 80 K=ALGENT(I,5),ALGENT(I,5)+ALGENT(I,6)-1 IF(INS(K,1).EQ.J.AND.INS(K,2).NE.0.AND.INS(K,2).NE.6.AND. - INS(K,2).NE.8.AND.INS(K,2).NE.9)INS(K,1)=NCONS IF(INS(K,3).EQ.J.AND.ABS(INS(K,2)).NE.9)INS(K,3)=NCONS 80 CONTINUE 70 CONTINUE * Shift the instructions. IINS0=NINS+1 DO 40 J=ALGENT(I,5),ALGENT(I,5)+ALGENT(I,6)-1 NINS=NINS+1 DO 50 K=1,4 INS(NINS,K)=INS(J,K) 50 CONTINUE EXEC(NINS)=EXEC(J) 40 CONTINUE * Update the entry point record. NALGE=NALGE+1 DO 20 J=1,10 ALGENT(NALGE,J)=ALGENT(I,J) 20 CONTINUE ALGENT(NALGE,5)=IINS0 ALGENT(NALGE,8)=ICONS0 10 CONTINUE *** Set suitable starting points for additions. ICONS0=NCONS-1 IINS0=NINS+1 *** Print statistics if requested. IF(LDEBUG)WRITE(LUNOUT,'(/'' ++++++ ALGGBC DEBUG : Garbage'', - '' collection statistics:''// - 26X,''Entry points in use: '',I4,'' (was: '',I4,'')''/ - 26X,''Instructions in use: '',I4,'' (was: '',I4,'')''/ - 26X,''Constant registers: '',I4,'' (was: '',I4,'')''/)') - NALGE,NEOLD,NINS,NIOLD,-5-NCONS,-5-NCOLD *** Reset unused portion of the instruction and constants storage. DO 90 I=IINS0,MXINS EXEC(I)=.TRUE. INS(I,1)=0 INS(I,2)=0 INS(I,3)=0 INS(I,4)=0 90 CONTINUE DO 100 I=ICONS0,MXCONS,-1 REG(I)=0.0 100 CONTINUE END +DECK,ALGINP. SUBROUTINE ALGINP *----------------------------------------------------------------------- * ALGINP - Serves as a subsection reading algebra command lines. * (Last changed on 27/11/10.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,ALGDATA. +SEQ,PRINTPLOT. LOGICAL LOOP INTEGER INPCMP,INPTYP,NWORD,I,NC,NC1,NC2,IKEY, - NCPRT,IFAIL1,IFAIL2 CHARACTER*(MXCHAR) STRING CHARACTER*30 AUX1,AUX2 EXTERNAL INPCMP,INPTYP +SELF,IF=AST. EXTERNAL ASTCCH +SELF. *** Identify the subroutine if requested. IF(LIDENT)PRINT *,' /// ROUTINE ALGINP ///' *** First pick up the number of words and the first word. CALL INPNUM(NWORD) CALL INPSTR(1,1,STRING,NC) *** Check it is a algebra command. IF(STRING(1:1).NE.'@')RETURN *** Determine whether it is a single command or not. IF(NWORD.EQ.1.AND.NC.EQ.1)THEN LOOP=.TRUE. PRINT *,' ' PRINT *,' ------------------------------------------------' PRINT *,' ---------- Algebra subsection ----------' PRINT *,' ------------------------------------------------' PRINT *,' ' CALL INPPRM('Algebra','ADD-PRINT') ELSE LOOP=.FALSE. ENDIF *** Return here if LOOP is .TRUE. 10 CONTINUE IF(LOOP)THEN CALL INPGET CALL INPNUM(NWORD) +SELF,IF=AST. *** Set up ASTCCH as the condition handler. CALL LIB$ESTABLISH(ASTCCH) +SELF. ENDIF CALL INPSTR(1,1,STRING,NC) *** Skip blank lines and warn for section headers. IF(STRING(1:1).EQ.'&')THEN PRINT *,' !!!!!! ALGINP WARNING : The section cannot be'// - ' left at this point; first type EXIT.' GOTO 1010 ELSEIF(INDEX('$%?>&|^~',CHAR).NE.0 LETTER(CHAR)=INDEX('ABCDEFGHIJKLMNOPQRSTUVWXYZ'// - 'abcdefghijklmnopqrstuvwxyz',CHAR).NE.0 NUMBER(CHAR)=INDEX('.0123456789',CHAR).NE.0 PREC(I,J)=(J.EQ.0).OR.(I.LE.9.AND.J.LE.9.AND.I.GE.J).OR. - (I.GE.10.AND.I.LE.15.AND.J.GE.10.AND.J.LE.15.AND.I.GE.J).OR. - (I.GE.16.AND.I.LE.17.AND.J.GE.16.AND.J.LE.17.AND.I.GE.J).OR. - (I.LE.9.AND.J.GE.10).OR.(I.LE.15.AND.J.GE.16) PRECS(I,J)=(J.EQ.0).OR. - (I.LE.9.AND.J.LE.9.AND.I.GE.J.AND. - (I.NE.2.OR.J.NE.2).AND.(I.NE.4.OR.J.NE.4).AND. - (I.NE.5.OR.J.NE.5)).OR. - (I.GE.10.AND.I.LE.15.AND.J.GE.10.AND.J.LE.15.AND.I.GE.J).OR. - (I.GE.16.AND.I.LE.17.AND.J.GE.16.AND.J.LE.17.AND.I.GE.J).OR. - (I.LE.9.AND.J.GE.10).OR.(I.LE.15.AND.J.GE.16) *** Define a few output formats. 1010 FORMAT(26X,'Constant ',I4,' = ',E15.7,', type=',I2) 1030 FORMAT(/,26X,I4,' Instructions are in use (Max =',I5,')', - /,26X,I4,' Registers are needed (Max =',I5,')', - /,26X,I4,' Constants have been defined (Max =',I5,')', - /,26X,I4,' Results are obtained (No maximum)') 1040 FORMAT(26X,'Variable ',I4,' = "',A10,'"') 1050 FORMAT(26X,'Variable ',I4,' = "',A10,'" (not used)') 1060 FORMAT(26X,'REG(',I3,')=',E15.7:'; REG(',I3,')=',E15.7) *** Identify the subroutine. IF(LIDENT)PRINT *,' /// ROUTINE ALGPRE ///' *** Check that NT does not exceed 80 characters. IF(NT.GT.LEN(T))THEN PRINT *,' ###### ALGPRE ERROR : Input string length', - ' specification inconsistent; rejected (program bug).' RETURN ENDIF *** Preset the counter variables etc. CALL ALGGBC +SELF,IF=CRAY. EPS=1.0E-10 +SELF,IF=-CRAY. EPS=1.0E-5 +SELF. IFAIL=1 REJECT=.FALSE. IT=0 IS=1 NBRACK=0 NINDEX=0 NRES=0 NNRES=0 S='$' DO 2 I=1,LEN(S) P(I)=0 2 CONTINUE *** Assign an entry point to the instruction list. IENTRY=IENTRL+1 IENTRL=IENTRL+1 IINS0=NINS+1 ICONS0=NCONS-1 * Check storage, perform a garbage collect if necessary. IF(NALGE+1.GT.MXALGE)THEN CALL ALGGBC IF(NALGE+1.GT.MXALGE)THEN PRINT *,' !!!!!! ALGPRE WARNING : Unable to allocate'// - ' an entry point to the instruction list.' PRINT *,' Increase MXALGE'// - ' and recompile the program.' IFAIL=1 IENTRY=-1 RETURN ENDIF ENDIF NALGE=NALGE+1 * Initialise the entry point record. ALGENT(NALGE,1)=IENTRY ALGENT(NALGE,2)=1 ALGENT(NALGE,3)=0 ALGENT(NALGE,4)=0 ALGENT(NALGE,5)=IINS0 ALGENT(NALGE,6)=0 ALGENT(NALGE,7)=NVAR ALGENT(NALGE,8)=ICONS0 ALGENT(NALGE,9)=0 ALGENT(NALGE,10)=0 *** Print the input expression if LDEBUG is on. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ ALGPRE DEBUG : Start of'', - '' the translation.''//26X,''Input string (length'',I3, - ''):''/26X,A)') NT,T(1:NT) *** First translation step: operaters -> O, numbers -> R, funct -> F. 10 CONTINUE IT=IT+1 * Check that it does not exceed NT. IF(IT.GT.NT)THEN IF(IS.GE.LEN(S))GOTO 3010 IS=IS+1 S(IS:IS)='$' IF(NBRACK.NE.0)THEN PRINT *,' ###### ALGPRE ERROR : Excess of opening'// - ' brackets.' REJECT=.TRUE. ENDIF GOTO 150 ENDIF * Skip blanks. IF(T(IT:IT).EQ.' ')GOTO 10 * Increment IS and check that IS < LEN(S). IS=IS+1 IF(IS.GT.LEN(S))GOTO 3010 ** Identify operators. IF(OPER(T(IT:IT)))THEN S(IS:IS)='O' IF(T(IT:IT).EQ.'+')THEN P(IS)=1 ELSEIF(T(IT:IT).EQ.'-')THEN P(IS)=2 ELSEIF(T(IT:IT).EQ.'*')THEN P(IS)=3 IF(IT.LT.NT)THEN IF(T(IT+1:IT+1).EQ.'*')THEN P(IS)=5 IT=IT+1 ENDIF ENDIF ELSEIF(T(IT:IT).EQ.'/')THEN P(IS)=4 ELSEIF(T(IT:IT).EQ.'=')THEN P(IS)=10 IF(IT.LT.NT)THEN IF(T(IT+1:IT+1).EQ.'<')THEN P(IS)=13 IT=IT+1 ELSEIF(T(IT+1:IT+1).EQ.'>')THEN P(IS)=15 IT=IT+1 ENDIF ENDIF ELSEIF(T(IT:IT).EQ.'#')THEN P(IS)=11 ELSEIF(T(IT:IT).EQ.'<')THEN P(IS)=12 IF(IT.LT.NT)THEN IF(T(IT+1:IT+1).EQ.'=')THEN P(IS)=13 IT=IT+1 ELSEIF(T(IT+1:IT+1).EQ.'>')THEN P(IS)=11 IT=IT+1 ENDIF ENDIF ELSEIF(T(IT:IT).EQ.'>')THEN P(IS)=14 IF(IT.LT.NT)THEN IF(T(IT+1:IT+1).EQ.'=')THEN P(IS)=15 IT=IT+1 ELSEIF(T(IT+1:IT+1).EQ.'<')THEN P(IS)=11 IT=IT+1 ENDIF ENDIF ELSEIF(T(IT:IT).EQ.'&')THEN P(IS)=16 ELSEIF(T(IT:IT).EQ.'|')THEN P(IS)=17 ELSEIF(T(IT:IT).EQ.'^'.OR.T(IT:IT).EQ.'~')THEN P(IS)=18 ENDIF ** Identify variable and function names. ELSEIF(LETTER(T(IT:IT)))THEN IV=IT 20 CONTINUE IV=IV+1 IF(IV.GT.NT)GOTO 30 IF((.NOT.OPER(T(IV:IV))).AND. - INDEX(' ([)],;',T(IV:IV)).EQ.0)GOTO 20 30 CONTINUE NEXT=',' DO 40 IN=IV,NT IF(T(IN:IN).NE.' ')THEN NEXT=T(IN:IN) GOTO 50 ENDIF 40 CONTINUE 50 CONTINUE CALL CLTOU(T(IT:IV-1)) IF(OPER(NEXT).OR.INDEX(',)[];',NEXT).NE.0)THEN S(IS:IS)='R' DO 60 IR=1,NVAR IF(T(IT:MIN(IT+LEN(VARLIS(IR))-1,IV-1)).EQ. - VARLIS(IR))THEN IF(IV-IT.GT.LEN(VARLIS(IR)))PRINT *, - ' !!!!!! ALGPRE WARNING : ',T(IT:IV-1), - ' is too long for a variable name; has'// - ' been matched with '//VARLIS(IR) P(IS)=IR GOTO 70 ENDIF 60 CONTINUE IF(T(IT:IV-1).EQ.'PI')THEN P(IS)=-3 ELSEIF(T(IT:IV-1).EQ.'FALSE')THEN P(IS)=-4 ELSEIF(T(IT:IV-1).EQ.'TRUE')THEN P(IS)=-5 ELSEIF(T(IT:IV-1).EQ.'NILL')THEN P(IS)=-6 ELSEIF(T(IT:IV-1).EQ.'RND_UNIFORM')THEN S(IS:IS)='G' P(IS)=1 ELSEIF(T(IT:IV-1).EQ.'RND_GAUSS'.OR. - T(IT:IV-1).EQ.'RND_NORMAL')THEN S(IS:IS)='G' P(IS)=2 ELSEIF(T(IT:IV-1).EQ.'RND_EXP'.OR. - T(IT:IV-1).EQ.'RND_EXPONENTIAL')THEN S(IS:IS)='G' P(IS)=3 ELSEIF(T(IT:IV-1).EQ.'RND_POISSON')THEN S(IS:IS)='G' P(IS)=4 ELSEIF(T(IT:IV-1).EQ.'RND_LANDAU')THEN S(IS:IS)='G' P(IS)=5 ELSEIF(T(IT:IV-1).EQ.'RND_POLYA')THEN S(IS:IS)='G' P(IS)=6 ELSEIF(T(IT:IV-1).EQ.'RND_FUNCTION')THEN S(IS:IS)='G' P(IS)=7 ELSEIF(T(IT:IV-1).EQ.'RND_GAMMA')THEN S(IS:IS)='G' P(IS)=9 ELSEIF(T(IT:IV-1).EQ.'RND_LAPLACE')THEN S(IS:IS)='G' P(IS)=10 ELSE PRINT *,' ###### ALGPRE ERROR : ',T(IT:IV-1), - ' is not a valid parameter.' REJECT=.TRUE. ENDIF 70 CONTINUE ELSE P(IS)=0 IF(T(IT:IV-1).EQ.'EXP') P(IS)= 1 IF(T(IT:IV-1).EQ.'LOG') P(IS)=-1 IF(T(IT:IV-1).EQ.'SIN') P(IS)= 2 IF(T(IT:IV-1).EQ.'COS') P(IS)= 3 IF(T(IT:IV-1).EQ.'TAN') P(IS)= 4 IF(T(IT:IV-1).EQ.'ARCSIN') P(IS)=-2 IF(T(IT:IV-1).EQ.'ARCCOS') P(IS)=-3 IF(T(IT:IV-1).EQ.'ARCTAN') P(IS)=-4 IF(T(IT:IV-1).EQ.'ABS') P(IS)= 5 IF(T(IT:IV-1).EQ.'SQRT') P(IS)=-5 IF(T(IT:IV-1).EQ.'SINH') P(IS)= 7 IF(T(IT:IV-1).EQ.'COSH') P(IS)= 8 IF(T(IT:IV-1).EQ.'TANH') P(IS)= 9 IF(T(IT:IV-1).EQ.'ARCSINH') P(IS)=-7 IF(T(IT:IV-1).EQ.'ARCCOSH') P(IS)=-8 IF(T(IT:IV-1).EQ.'ARCTANH') P(IS)=-9 IF(T(IT:IV-1).EQ.'NOT') P(IS)=10 IF(T(IT:IV-1).EQ.'ENTIER') P(IS)=11 IF(T(IT:IV-1).EQ.'TRAILING')P(IS)=-11 IF(T(IT:IV-1).EQ.'STRING' )P(IS)=12 IF(T(IT:IV-1).EQ.'NUMBER' )P(IS)=-12 IF(T(IT:IV-1).EQ.'SUM' )P(IS)=13 IF(T(IT:IV-1).EQ.'PRODUCT' )P(IS)=14 IF(T(IT:IV-1).EQ.'REFERENCE'.OR. - T(IT:IV-1).EQ.'REF')P(IS)=15 IF(T(IT:IV-1).EQ.'REF_STRING')P(IS)=51 IF(T(IT:IV-1).EQ.'REF_HISTOGRAM'.OR. - T(IT:IV-1).EQ.'REF_HIST')P(IS)=54 IF(T(IT:IV-1).EQ.'REF_MATRIX')P(IS)=55 IF(T(IT:IV-1).EQ.'GLOBAL' )P(IS)=16 IF(T(IT:IV-1).EQ.'TYPE' )P(IS)=17 IF(T(IT:IV-1).EQ.'LANDAU' )P(IS)=18 IF(T(IT:IV-1).EQ.'MINIMUM' )P(IS)=19 IF(T(IT:IV-1).EQ.'MAXIMUM' )P(IS)=20 IF(T(IT:IV-1).EQ.'RND_UNIFORM')P(IS)=21 IF(T(IT:IV-1).EQ.'RND_EXP'.OR. - T(IT:IV-1).EQ.'RND_EXPONENTIAL')P(IS)=23 IF(T(IT:IV-1).EQ.'RND_POISSON')P(IS)=24 IF(T(IT:IV-1).EQ.'RND_POLYA')P(IS)=26 IF(T(IT:IV-1).EQ.'RND_HISTOGRAM')P(IS)=28 IF(T(IT:IV-1).EQ.'RND_GAMMA')P(IS)=29 IF(T(IT:IV-1).EQ.'RND_LAPLACE')P(IS)=30 IF(T(IT:IV-1).EQ.'ROW' )P(IS)=40 IF(T(IT:IV-1).EQ.'MEAN' )P(IS)=41 IF(T(IT:IV-1).EQ.'RMS' )P(IS)=42 IF(T(IT:IV-1).EQ.'SIZE' )P(IS)=43 IF(T(IT:IV-1).EQ.'ZEROES' )P(IS)=44 IF(T(IT:IV-1).EQ.'ONES' )P(IS)=45 IF(T(IT:IV-1).EQ.'EXIST'.OR. - T(IT:IV-1).EQ.'EXISTS' )P(IS)=46 IF(T(IT:IV-1).EQ.'GAMMA' )P(IS)=47 IF(T(IT:IV-1).EQ.'LOG_GAMMA')P(IS)=48 IF(T(IT:IV-1).EQ.'REVERSE' )P(IS)=49 IF(P(IS).EQ.0)THEN PRINT *,' ###### ALGPRE ERROR : ',T(IT:IV-1), - ' is not a valid function.' REJECT=.TRUE. ENDIF S(IS:IS)='F' ENDIF IT=IV-1 ** Pick up strings. ELSEIF(T(IT:IT).EQ.'"'.OR.T(IT:IT).EQ.'`')THEN IC=IT 80 CONTINUE IC=IC+1 * Make sure we did see the terminating quote. IF(IC.GT.NT)THEN PRINT *,' !!!!!! ALGPRE WARNING : Strings should be'// - ' terminated by a double quote; quote assumed.' GOTO 90 ELSEIF(T(IC:IC).EQ.T(IT:IT))THEN GOTO 90 ENDIF GOTO 80 90 CONTINUE * Assign the string pointer to the constant list. S(IS:IS)='R' NCONS=NCONS-1 IF(NCONS.LT.MXCONS)GOTO 3020 * If the string isn't empty, put it in the string buffer. IF(IC-1.GE.IT+1)THEN CALL STRBUF('STORE',IAUX,T(IT+1:IC-1),IC-IT-1,IFAILS) IF(IFAILS.NE.0)THEN PRINT *,' !!!!!! ALGPRE WARNING : Unable to'// - ' store the string "',T(IT+1:IC-1), - '"; formula rejected.' REJECT=.TRUE. REG(NCONS)=0.0 ELSE REG(NCONS)=REAL(IAUX) ENDIF * A null string is stored as a blank string with length zero. ELSE CALL STRBUF('STORE',IAUX,' ',0,IFAILS) IF(IFAILS.NE.0)THEN PRINT *,' !!!!!! ALGPRE WARNING : Unable to'// - ' store the null string; formula rejected.' REJECT=.TRUE. REG(NCONS)=0.0 ELSE REG(NCONS)=REAL(IAUX) ENDIF ENDIF * Keep track of the type of the variable. MODREG(NCONS)=1 P(IS)=NCONS * Update string pointer. IT=IC * Identify numbers (constants) and assign them to a register. ELSEIF(NUMBER(T(IT:IT)))THEN IC=IT 100 CONTINUE IC=IC+1 IF(IC.GT.NT)GOTO 110 IF(NUMBER(T(IC:IC)))GOTO 100 IF(T(IC:IC).EQ.'E')THEN IC=IC+1 IF(IC.GT.NT)GOTO 110 IF(T(IC:IC).EQ.'+'.OR.T(IC:IC).EQ.'-')IC=IC+1 GOTO 100 ENDIF 110 CONTINUE S(IS:IS)='R' CALL INPRRC(T(IT:IC-1),AUX,0.0,IFAILR) IF(IFAILR.NE.0)THEN PRINT *,' ###### ALGPRE ERROR : ',T(IT:IC-1), - ' is not acceptable as a number.' REJECT=.TRUE. ENDIF * See whether the number is already known globally or in this list. DO 120 II=0,NCONS,-1 IF(MODREG(II).EQ.2.AND.(II.GE.-3.OR.II.LE.ICONS0).AND. - ABS(REG(II)-AUX).LE.EPS*(ABS(REG(II))+ABS(AUX)))THEN P(IS)=II GOTO 130 ENDIF 120 CONTINUE * If not known, add it to the list. NCONS=NCONS-1 IF(NCONS.LT.MXCONS)GOTO 3020 REG(NCONS)=AUX MODREG(NCONS)=2 P(IS)=NCONS 130 CONTINUE * Update string pointer. IT=IC-1 * Count brackets, reject if at any time < 0. ELSEIF(INDEX(')',T(IT:IT)).NE.0)THEN NBRACK=NBRACK-1 S(IS:IS)=')' IF(NBRACK.LT.0)THEN PRINT *,' ###### ALGPRE ERROR : Excess of closing'// - ' brackets.' REJECT=.TRUE. ENDIF ELSEIF(INDEX('(',T(IT:IT)).NE.0)THEN NBRACK=NBRACK+1 S(IS:IS)='(' * Matrix indices, check that there is no nesting. ELSEIF(INDEX(']',T(IT:IT)).NE.0)THEN NINDEX=NINDEX-1 S(IS:IS)=']' IF(NINDEX.LT.0)THEN PRINT *,' ###### ALGPRE ERROR : Incorrect array'// - ' indexing.' REJECT=.TRUE. ENDIF ELSEIF(INDEX('[',T(IT:IT)).NE.0)THEN NINDEX=NINDEX+1 S(IS:IS)='[' C IF(NINDEX.GT.1)THEN C PRINT *,' ###### ALGPRE ERROR : Index nesting is'// C - ' not permitted.' C REJECT=.TRUE. C ENDIF ELSEIF(INDEX(';',T(IT:IT)).NE.0)THEN S(IS:IS)=';' IF(NINDEX.NE.1)THEN PRINT *,' ###### ALGPRE ERROR : Semicolons can'// - ' only be used in indexing expressions' REJECT=.TRUE. ENDIF ELSEIF(INDEX(',',T(IT:IT)).NE.0.AND.NINDEX.EQ.1)THEN S(IS:IS)=',' * Expression delimiter, check balance of brackets. ELSEIF(T(IT:IT).EQ.',')THEN S(IS:IS)='$' IF(NBRACK.NE.0)THEN PRINT *,' ###### ALGPRE ERROR : Excess of opening'// - ' brackets in a sub expression.' REJECT=.TRUE. ENDIF IF(NINDEX.NE.0)THEN PRINT *,' ###### ALGPRE ERROR : Index expression'// - ' not ended before end of formula.' REJECT=.TRUE. ENDIF * Invalid element. ELSE PRINT *,' !!!!!! ALGPRE WARNING : Invalid element "', - T(IT:IT),'" ignored.' IS=IS-1 ENDIF * End of loop. GOTO 10 150 CONTINUE * Store current string length NS=IS * Print the list if LDEBUG is on. IF(LDEBUG)WRITE(LUNOUT,'(/26X,''Code string:''/26X,A)') S(1:NS) * Replace $-, (-, O- and F- by functions (-6), $+ etc by F +6. DO 160 IS=1,NS-1 IF(INDEX('$(OF',S(IS:IS)).NE.0.AND.S(IS+1:IS+1).EQ.'O'.AND. - (P(IS+1).EQ.1.OR.P(IS+1).EQ.2.OR.P(IS+1).EQ.18))THEN S(IS+1:IS+1)='F' IF(P(IS+1).EQ.1)P(IS+1)=+6 IF(P(IS+1).EQ.2)P(IS+1)=-6 IF(P(IS+1).EQ.18)P(IS+1)=10 ENDIF IF(S(IS+1:IS+1).EQ.'O'.AND.P(IS+1).EQ.18)THEN C PRINT *,' ###### ALGPRE ERROR : A "not" symbol (^ or ~)'// C - ' has been used as a binary operator ; rejected.' C REJECT=.TRUE. P(IS+1)=5 ENDIF 160 CONTINUE *** Next check syntax: sequence of symbols. DO 200 IS=1,NS-1 IF( (S(IS:IS).EQ.'$'.AND.INDEX('RG(F ' ,S(IS+1:IS+1)).EQ.0).OR. - (S(IS:IS).EQ.'('.AND.INDEX('RGF(' ,S(IS+1:IS+1)).EQ.0).OR. - (S(IS:IS).EQ.')'.AND.INDEX('O$),;[]',S(IS+1:IS+1)).EQ.0).OR. - (S(IS:IS).EQ.'['.AND.INDEX('RGF(;]' ,S(IS+1:IS+1)).EQ.0).OR. - (S(IS:IS).EQ.']'.AND.INDEX('O$),;]' ,S(IS+1:IS+1)).EQ.0).OR. - (S(IS:IS).EQ.';'.AND.INDEX('R(F];' ,S(IS+1:IS+1)).EQ.0).OR. - (S(IS:IS).EQ.','.AND.INDEX('R(F' ,S(IS+1:IS+1)).EQ.0).OR. - (S(IS:IS).EQ.'R'.AND.INDEX(')O$,;[]',S(IS+1:IS+1)).EQ.0).OR. - (S(IS:IS).EQ.'G'.AND.INDEX(')O$' ,S(IS+1:IS+1)).EQ.0).OR. - (S(IS:IS).EQ.'O'.AND.INDEX('RGF(' ,S(IS+1:IS+1)).EQ.0).OR. - (S(IS:IS).EQ.'F'.AND.INDEX('RG(F' ,S(IS+1:IS+1)).EQ.0)) - THEN PRINT *,' ###### ALGPRE ERROR : Syntax error (illegal'// - ' sequence of symbols).' IF(LDEBUG)WRITE(LUNOUT,'(26X,''Error occurs at IS='',I2, - '' in "'',A2,''".'')') IS,S(IS:IS+1) REJECT=.TRUE. ENDIF 200 CONTINUE *** Return if syntax errors have been found. IF(REJECT)THEN PRINT *,' ###### ALGPRE ERROR : ',T(1:NT), - ' is rejected because of the above errors.' IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ ALGPRE DEBUG : End'', - '' of the debugging output.'')') RETURN ENDIF * Print the values of the constants if LDEBUG is on. IF(LDEBUG)THEN IF(NCONS.LT.ICONS0)THEN WRITE(LUNOUT,'(/,26X,''Constants used in the'', - '' expression, apart from 0, 1, 2 and PI:'')') DO 180 I=ICONS0,NCONS,-1 WRITE(LUNOUT,1010) I,REG(I),MODREG(I) 180 CONTINUE WRITE(LUNOUT,'('' '')') ELSE WRITE(LUNOUT,'(/,26X,''Apart from 0, 1, 2 and PI,'', - '' no constants have been defined.'',/)') ENDIF ENDIF *** Transform into a list of executable instructions. IF(LDEBUG)WRITE(LUNOUT,'(26X,''Instruction list building:''/)') NREG=NVAR NPASS=0 RNDUSE=.FALSE. 210 CONTINUE NPASS=NPASS+1 CHANGE=.FALSE. ** Replace 'G' by 'R' DO 219 IS=2,NS IF(S(IS:IS).EQ.'G')THEN RNDUSE=.TRUE. NINS=NINS+1 IF(NINS.GT.MXINS)GOTO 3040 INS(NINS,1)=20+P(IS) INS(NINS,2)=6 INS(NINS,3)=-1 NREG=NREG+1 IF(NREG.GT.MXREG)GOTO 3030 P(IS)=NREG INS(NINS,4)=P(IS) S(IS:IS)='R' CHANGE=.TRUE. ENDIF 219 CONTINUE ** Replace 'FR' by a new 'R'. DO 220 IS=2,NS-1 IF(S(IS:IS+1).EQ.'FR')THEN NINS=NINS+1 IF(NINS.GT.MXINS)GOTO 3040 INS(NINS,1)=P(IS) IF(P(IS).GT.20.AND.P(IS).LE.39)RNDUSE=.TRUE. INS(NINS,2)=6 INS(NINS,3)=P(IS+1) IF(P(IS+1).LE.0.AND.(P(IS).LE.20.OR.P(IS).GT.39).AND. - P(IS).NE.15.AND.P(IS).NE.40.AND.P(IS).NE.44.AND. - P(IS).NE.45)THEN NCONS=NCONS-1 IF(NCONS.LT.MXCONS)GOTO 3020 P(IS)=NCONS ELSE NREG=NREG+1 IF(NREG.GT.MXREG)GOTO 3030 P(IS)=NREG ENDIF INS(NINS,4)=P(IS) S(IS:IS+1)='R ' P(IS+1)=0 CHANGE=.TRUE. ENDIF 220 CONTINUE ** Replace 'ROR' by a new 'R'. DO 230 IS=2,NS-3 LASTOP=0 DO 231 IIS=IS-1,1,-1 IF(S(IIS:IIS).EQ.'O')THEN LASTOP=P(IIS) ELSEIF(S(IIS:IIS).NE.' ')THEN GOTO 232 ENDIF 231 CONTINUE 232 CONTINUE IF((S(IS:IS+3).EQ.'ROR)'.OR.S(IS:IS+3).EQ.'ROR$'.OR. - S(IS:IS+3).EQ.'ROR]'.OR.S(IS:IS+3).EQ.'ROR,'.OR. - S(IS:IS+3).EQ.'ROR;'.OR. - (S(IS:IS+3).EQ.'RORO'.AND.PREC(P(IS+1),P(IS+3)))).AND. - PRECS(P(IS+1),LASTOP))THEN NINS=NINS+1 IF(NINS.GT.MXINS)GOTO 3040 INS(NINS,1)=P(IS) INS(NINS,2)=P(IS+1) INS(NINS,3)=P(IS+2) IF(P(IS).LE.0.AND.P(IS+2).LE.0)THEN NCONS=NCONS-1 IF(NCONS.LT.MXCONS)GOTO 3020 P(IS+2)=NCONS ELSE NREG=NREG+1 IF(NREG.GT.MXREG)GOTO 3030 P(IS+2)=NREG ENDIF S(IS:IS+2)=' R' P(IS)=0 P(IS+1)=0 INS(NINS,4)=P(IS+2) CHANGE=.TRUE. ENDIF 230 CONTINUE ** Process indexing expressions. DO 260 IS=1,NS-1 * Look for opening 'R[' patterns. IF(S(IS:IS+1).EQ.'R[')THEN * If found, scan for the closing ] and quit if expressions remain. NDIM=1 DO 261 JS=IS+2,NS IF(S(JS:JS).EQ.']')THEN ISEND=JS GOTO 262 ELSEIF(S(JS:JS).EQ.';')THEN NDIM=NDIM+1 ELSEIF(INDEX(' ,R',S(JS:JS)).EQ.0)THEN GOTO 260 ENDIF 261 CONTINUE * Closing ] not present, issue warning and quit. PRINT *,' !!!!!! ALGPRE WARNING : End of index expression'// - ' not found.' IFAIL=1 RETURN * Generate the argument list for the procedure call. 262 CONTINUE IARG=0 * Number of dimensions. NINS=NINS+1 IF(NINS.GT.MXINS)GOTO 3040 NCONS=NCONS-1 IF(NCONS.LT.MXCONS)GOTO 3020 REG(NCONS)=REAL(NDIM) MODREG(NCONS)=2 INS(NINS,1)=3 INS(NINS,2)=8 INS(NINS,3)=NCONS IARG=IARG+1 INS(NINS,4)=IARG * Number of declarations per dimension. IDIM0=NCONS DO 263 IDIM=1,NDIM NINS=NINS+1 IF(NINS.GT.MXINS)GOTO 3040 NCONS=NCONS-1 IF(NCONS.LT.MXCONS)GOTO 3020 REG(IDIM0-IDIM)=0 MODREG(IDIM0-IDIM)=2 IARG=IARG+1 INS(NINS,1)=3 INS(NINS,2)=8 INS(NINS,3)=IDIM0-IDIM INS(NINS,4)=IARG 263 CONTINUE * Each of the dimensions. IDIM=0 DO 264 JS=IS+1,ISEND-1 IF(S(JS:JS).EQ.' ')THEN GOTO 264 ELSEIF(S(JS:JS).EQ.'R')THEN NINS=NINS+1 IF(NINS.GT.MXINS)GOTO 3040 IARG=IARG+1 INS(NINS,1)=3 INS(NINS,2)=8 INS(NINS,3)=P(JS) INS(NINS,4)=IARG REG(IDIM0-IDIM)=REG(IDIM0-IDIM)+1 ELSEIF(INDEX(';[',S(JS:JS)).NE.0)THEN IDIM=IDIM+1 ENDIF 264 CONTINUE * Update the string. S(IS+1:IS+1)='I' P(IS+1)=IARG DO 265 JS=IS+2,ISEND S(JS:JS)=' ' P(JS)=0 265 CONTINUE * Replace 'RI' by 'R', add the input matrix as argument. NINS=NINS+1 IF(NINS.GT.MXINS)GOTO 3040 INS(NINS,1)=3 INS(NINS,2)=8 INS(NINS,3)=P(IS) INS(NINS,4)=P(IS+1)+1 * Find the location for the output matrix. IF(P(IS).LE.0)THEN NCONS=NCONS-1 IF(NCONS.LT.MXCONS)GOTO 3020 P(IS)=NCONS ELSE NREG=NREG+1 IF(NREG.GT.MXREG)GOTO 3030 P(IS)=NREG ENDIF * Add the output matrix as argument. NINS=NINS+1 IF(NINS.GT.MXINS)GOTO 3040 INS(NINS,1)=1 INS(NINS,2)=8 INS(NINS,3)=P(IS) INS(NINS,4)=P(IS+1)+2 * Generate procedure call. NINS=NINS+1 IF(NINS.GT.MXINS)GOTO 3040 INS(NINS,1)=-80 INS(NINS,2)=9 INS(NINS,3)=P(IS+1)+2 INS(NINS,4)=0 * Update the string. S(IS:IS+1)='R ' P(IS+1)=0 * Remember that we changed something. CHANGE=.TRUE. ENDIF * Next element. 260 CONTINUE ** Replace '(R)' by 'R' and remove blanks. IS=1 DO 240 I=2,NS IF(S(I:I).EQ.' ')GOTO 240 IS=IS+1 S(IS:IS)=S(I:I) IF(I.NE.IS)S(I:I)=' ' P(IS)=P(I) IF(I.NE.IS)P(I)=0 IF(IS.LE.2)GOTO 240 IF(S(IS-2:IS).EQ.'(R)')THEN S(IS-2:IS)='R ' P(IS-2)=P(IS-1) P(IS-1)=0 P(IS)=0 IS=IS-2 CHANGE=.TRUE. ENDIF 240 CONTINUE * Store new string length NS=IS ** Print the current string. IF(LDEBUG)THEN IF(CHANGE)THEN WRITE(LUNOUT,'(26X,''Pass'',I3,'': '',A)') - NPASS,S(1:NS) ELSE WRITE(LUNOUT,'(26X,''No further passes.''/)') ENDIF ENDIF * Check whether further cycles are needed. IF(CHANGE)GOTO 210 ** Generate instructions to delete temporary matrices. DO 270 I=IINS0+1,NINS * Select STORE_SUBMATRIX calls. IF(INS(I,1).NE.-80.OR.INS(I,2).NE.9)GOTO 270 * Make sure the output matrix isn't used as a result. DO 280 IS=1,NS-2 IF(S(IS:IS+2).EQ.'$R$'.AND.P(IS+1).EQ.INS(I-1,3))GOTO 270 280 CONTINUE * Add the DELETE_MATRIX call to the list. IF(NINS+2.GT.MXINS)GOTO 3040 NINS=NINS+1 INS(NINS,1)=0 INS(NINS,2)=8 INS(NINS,3)=INS(I-1,3) INS(NINS,4)=1 NINS=NINS+1 INS(NINS,1)=-86 INS(NINS,2)=9 INS(NINS,3)=1 INS(NINS,4)=0 270 CONTINUE ** Find the results. NRES=0 DO 250 IS=1,NS-2 IF(S(IS:IS+2).EQ.'$R$')THEN NRES=NRES+1 IF(NINS.GE.MXINS)GOTO 3040 NINS=NINS+1 INS(NINS,2)=0 INS(NINS,3)=P(IS+1) INS(NINS,4)=NRES ENDIF 250 CONTINUE * Make sure there is at least one. IF(NRES.LE.0)THEN PRINT *,' !!!!!! ALGPRE WARNING : Unable to find a result'// - ' in the expression;' RETURN ENDIF NNRES=NRES ** Add a return statement. IF(NINS.GE.MXINS)GOTO 3040 NINS=NINS+1 INS(NINS,1)=-1 INS(NINS,2)=-9 INS(NINS,3)=0 INS(NINS,4)=0 *** Skip simplications if there are randon number generators. IF(RNDUSE)THEN IF(LDEBUG)WRITE(LUNOUT,'(26X,''Simplication is skipped'', - '' because of the use of random number generators.'')') GOTO 600 ENDIF *** Start of the ALGSIM entry for simplifications. ENTRY ALGSIM(VARLIS,NVAR,USE,IFAIL) * First check whether there are loop structures. LOOP=.FALSE. DO 310 I=IINS0,NINS IF(INS(I,2).EQ.7)LOOP=.TRUE. 310 CONTINUE IF(LDEBUG)WRITE(LUNOUT,'(26X,''Loop structure flag:'',L2/)') LOOP * Print the list if LDEBUG is on. IF(LDEBUG)THEN WRITE(LUNOUT,'(26X,''Raw instruction list:'')') CALL ALGPRT(IINS0,NINS) WRITE(LUNOUT,'(/,26X,''Simplifications (if any):'')') ENDIF ** Repeat the simplification step until no further changes occur. 300 CONTINUE CHANGE=.FALSE. MODFLG=' ' * First simplify the expressions. DO 320 I=IINS0,NINS IF(INS(I,2).EQ.1.AND.(INS(I,1).EQ.0.OR.INS(I,3).EQ.0))THEN IF(INS(I,3).EQ.0)INS(I,3)=INS(I,1) INS(I,1)=6 INS(I,2)=6 CHANGE=.TRUE. MODFLG(1:1)='S' ENDIF IF(INS(I,2).EQ.2.AND.INS(I,1).EQ.INS(I,3))THEN INS(I,1)=6 INS(I,2)=6 INS(I,3)=0 CHANGE=.TRUE. MODFLG(1:1)='S' ENDIF IF(INS(I,2).EQ.2.AND.INS(I,3).EQ.0)THEN INS(I,3)=INS(I,1) INS(I,1)=6 INS(I,2)=6 CHANGE=.TRUE. MODFLG(1:1)='S' ENDIF IF(INS(I,2).EQ.2.AND.INS(I,1).EQ.0)THEN INS(I,1)=-6 INS(I,2)=6 CHANGE=.TRUE. MODFLG(1:1)='S' ENDIF IF(INS(I,2).EQ.3.AND.(INS(I,1).EQ.0.OR.INS(I,3).EQ.0))THEN INS(I,1)=6 INS(I,2)=6 INS(I,3)=0 CHANGE=.TRUE. MODFLG(1:1)='S' ENDIF IF(INS(I,2).EQ.3.AND.(INS(I,1).EQ.-1.OR.INS(I,3).EQ.-1))THEN IF(INS(I,3).EQ.-1)INS(I,3)=INS(I,1) INS(I,1)=6 INS(I,2)=6 CHANGE=.TRUE. MODFLG(1:1)='S' ENDIF IF(INS(I,2).EQ.4.AND.INS(I,1).EQ.INS(I,3))THEN INS(I,1)=6 INS(I,2)=6 INS(I,3)=-1 CHANGE=.TRUE. MODFLG(1:1)='S' ENDIF IF(INS(I,2).EQ.4.AND.INS(I,3).EQ.0)THEN PRINT *,' ###### ALGPRE ERROR : Division by 0;'// - ' expression is rejected.' RETURN ENDIF IF(INS(I,2).EQ.5.AND.INS(I,3).EQ.0)THEN INS(I,1)=6 INS(I,2)=6 INS(I,3)=-1 CHANGE=.TRUE. MODFLG(1:1)='S' ENDIF IF(INS(I,2).EQ.5.AND.INS(I,3).EQ.-1)THEN INS(I,3)=INS(I,1) INS(I,1)=6 INS(I,2)=6 CHANGE=.TRUE. MODFLG(1:1)='S' ENDIF IF(INS(I,2).EQ.5.AND.INS(I,3).EQ.-2)THEN INS(I,2)=3 INS(I,3)=INS(I,1) CHANGE=.TRUE. MODFLG(1:1)='S' ENDIF IF(INS(I,2).EQ.16.AND.(INS(I,1).EQ.-4.OR.INS(I,3).EQ.-4))THEN INS(I,1)=6 INS(I,2)=6 INS(I,3)=-4 CHANGE=.TRUE. MODFLG(1:1)='S' ENDIF IF(INS(I,2).EQ.16.AND.(INS(I,1).EQ.-5.OR.INS(I,3).EQ.-5))THEN IF(INS(I,3).EQ.-5)INS(I,3)=INS(I,1) INS(I,1)=6 INS(I,2)=6 CHANGE=.TRUE. MODFLG(1:1)='S' ENDIF IF(INS(I,2).EQ.17.AND.(INS(I,1).EQ.-5.OR.INS(I,3).EQ.-5))THEN INS(I,1)=6 INS(I,2)=6 INS(I,3)=-5 CHANGE=.TRUE. MODFLG(1:1)='S' ENDIF IF(INS(I,2).EQ.17.AND.(INS(I,1).EQ.-4.OR.INS(I,3).EQ.-4))THEN IF(INS(I,3).EQ.-4)INS(I,3)=INS(I,1) INS(I,1)=6 INS(I,2)=6 CHANGE=.TRUE. MODFLG(1:1)='S' ENDIF 320 CONTINUE * Remove assignments where possible. IF(.NOT.LOOP)THEN DO 330 I1=IINS0,NINS IF((.NOT.EXEC(I1)).OR.INS(I1,1).NE.6.OR. - INS(I1,2).NE.6.OR.INS(I1,2).EQ.0)GOTO 330 DO 340 I2=I1+1,NINS IF(.NOT.EXEC(I2))GOTO 340 IF(INS(I2,4).EQ.INS(I1,4).AND.INS(I2,2).NE.0)GOTO 330 IF(INS(I2,1).EQ.INS(I1,4).AND.INS(I2,2).NE.0.AND. - INS(I2,2).NE.6.AND.INS(I2,2).NE.8.AND. - INS(I2,2).NE.9)INS(I2,1)=INS(I1,3) IF(INS(I2,3).EQ.INS(I1,4).AND.ABS(INS(I2,2)).NE.9) - INS(I2,3)=INS(I1,3) EXEC(I1)=.FALSE. CHANGE=.TRUE. MODFLG(2:2)='A' 340 CONTINUE 330 CONTINUE ELSE MODFLG(2:2)='a' ENDIF * Evaluate constant expressions, and identify them if possible. IFAILC=0 DO 350 I=IINS0,NINS IF((.NOT.EXEC(I)).OR.INS(I,3).GT.0.OR.INS(I,2).EQ.0.OR. - INS(I,2).EQ.7.OR.INS(I,2).EQ.8.OR.ABS(INS(I,2)).EQ.9.OR. - (INS(I,1).GT.0.AND.INS(I,2).NE.6).OR. - (INS(I,1).EQ.6.AND.INS(I,2).EQ.6).OR. - (INS(I,1).EQ.15.AND.INS(I,2).EQ.6).OR. - (INS(I,1).EQ.40.AND.INS(I,2).EQ.6).OR. - (INS(I,1).EQ.44.AND.INS(I,2).EQ.6).OR. - (INS(I,1).EQ.45.AND.INS(I,2).EQ.6))GOTO 350 IF((INS(I,2).EQ.6.AND.MODREG(INS(I,3)).EQ.0).OR. - (INS(I,2).NE.6.AND.(MODREG(INS(I,1)).EQ.0.OR. - MODREG(INS(I,3)).EQ.0)))THEN CALL ALGEX0(I,IFAILC) ELSEIF((INS(I,2).EQ.6.AND.MODREG(INS(I,3)).EQ.2).OR. - (INS(I,2).NE.6.AND.MODREG(INS(I,1)).EQ.2.AND. - MODREG(INS(I,3)).EQ.2))THEN CALL ALGEX2(I,IFAILC) ELSEIF((INS(I,2).EQ.6.AND.MODREG(INS(I,3)).EQ.3).OR. - (INS(I,2).NE.6.AND.MODREG(INS(I,1)).EQ.3.AND. - MODREG(INS(I,3)).EQ.3))THEN CALL ALGEX3(I,IFAILC) ELSEIF((INS(I,2).EQ.6.AND.MODREG(INS(I,3)).EQ.1).OR. - (INS(I,2).NE.6.AND.MODREG(INS(I,1)).EQ.1.AND. - MODREG(INS(I,3)).EQ.1))THEN CALL ALGEX4(I,IFAILC) ELSEIF((INS(I,2).EQ.6.AND.MODREG(INS(I,3)).EQ.4).OR. - (INS(I,2).NE.6.AND.MODREG(INS(I,1)).EQ.4.OR. - MODREG(INS(I,3)).EQ.4))THEN IF(INS(I,2).NE.6.OR.INS(I,1).NE.15)CALL ALGEX5(I,IFAILC) ELSEIF((INS(I,2).EQ.6.AND.MODREG(INS(I,3)).EQ.5).OR. - (INS(I,2).NE.6.AND.MODREG(INS(I,1)).EQ.5.OR. - MODREG(INS(I,3)).EQ.5))THEN CALL ALGEX6(I,IFAILC) ELSE PRINT *,' ###### ALGPRE ERROR : Unable to evaluate'// - ' a constant because of mode incompatibility.' IF(LDEBUG)THEN WRITE(LUNOUT,'(26X,''Error occured in:'')') CALL ALGPRT(I,I) IF(INS(I,2).EQ.6)PRINT 1060,INS(I,3),REG(INS(I,3)) IF(INS(I,2).NE.6)PRINT 1060,INS(I,1),REG(INS(I,1)), - INS(I,3),REG(INS(I,3)) ENDIF IFAIL=1 RETURN ENDIF IF(IFAILC.NE.0)THEN CALL ALGERR PRINT *,' ###### ALGPRE ERROR : Arithmetic error while'// - ' evaluating a constant; expression rejected.' IF(LDEBUG)THEN WRITE(LUNOUT,'(26X,''Error occured in:'')') CALL ALGPRT(I,I) IF(INS(I,2).EQ.6)PRINT 1060,INS(I,3),REG(INS(I,3)) IF(INS(I,2).NE.6)PRINT 1060,INS(I,1),REG(INS(I,1)), - INS(I,3),REG(INS(I,3)) ENDIF IFAIL=1 RETURN ENDIF IFAIL=1 INS(I,1)=6 INS(I,2)=6 DO 351 J=0,NCONS,-1 IF(J.LT.-5.AND.J.GT.ICONS0)GOTO 351 IF(ABS(REG(J)-REG(INS(I,4))).LT. - EPS*(ABS(REG(J))+ABS(REG(INS(I,4)))).AND. - MODREG(J).EQ.MODREG(INS(I,4)))THEN INS(I,3)=J GOTO 352 ENDIF 351 CONTINUE NCONS=NCONS-1 IF(NCONS.LT.MXCONS)GOTO 3020 REG(NCONS)=REG(INS(I,4)) MODREG(NCONS)=MODREG(INS(I,4)) INS(I,3)=NCONS 352 CONTINUE IF(INS(I,4).LT.0)THEN EXEC(I)=.FALSE. DO 353 J=I+1,NINS IF(INS(J,4).EQ.INS(I,4))GOTO 350 IF(EXEC(J).AND.INS(J,1).EQ.INS(I,4).AND.INS(J,2).NE.0.AND. - INS(J,2).NE.6.AND.INS(J,2).NE.8.AND. - INS(J,2).NE.9)INS(J,1)=INS(I,3) IF(EXEC(J).AND.INS(J,3).EQ.INS(I,4).AND. - ABS(INS(J,2)).NE.9)INS(J,3)=INS(I,3) 353 CONTINUE ENDIF CHANGE=.TRUE. MODFLG(3:3)='C' 350 CONTINUE C* Rearrange the arguments for +, *, & and |. C DO 360 I=IINS0,NINS C IF(.NOT.EXEC(I))GOTO 360 C IF((INS(I,2).EQ.1.OR.INS(I,2).EQ.3.OR.INS(I,2).EQ.16.OR. C - INS(I,2).EQ.17).AND.INS(I,1).GT.INS(I,3))THEN C IAUX=INS(I,3) C INS(I,3)=INS(I,1) C INS(I,1)=IAUX C CHANGE=.TRUE. C MODFLG(4:4)='R' C ENDIF C360 CONTINUE * Identify equal expressions. IF(.NOT.LOOP)THEN DO 370 I1=IINS0,NINS IF((.NOT.EXEC(I1)).OR.INS(I1,2).EQ.0.OR.INS(I1,2).EQ.7.OR. - INS(I1,2).EQ.8.OR.ABS(INS(I1,2)).EQ.9)GOTO 370 DO 380 I2=I1+1,NINS IF(EXEC(I2).AND.INS(I2,4).EQ.INS(I1,4))GOTO 370 IF((.NOT.EXEC(I2)).OR.INS(I2,2).EQ.0.OR.INS(I2,2).EQ.7.OR. - INS(I2,2).EQ.8.OR.ABS(INS(I2,2)).EQ.9)GOTO 380 IF(INS(I1,1).EQ.INS(I2,1).AND.INS(I1,2).EQ.INS(I2,2).AND. - INS(I1,3).EQ.INS(I2,3))THEN INS(I2,1)=6 INS(I2,2)=6 INS(I2,3)=INS(I1,4) CHANGE=.TRUE. MODFLG(5:5)='E' ENDIF 380 CONTINUE 370 CONTINUE * Remove complementary function calls like log(exp(...)). DO 390 I1=IINS0,NINS IF((.NOT.EXEC(I1)).OR.INS(I1,2).NE.6)GOTO 390 IF(ABS(INS(I1,1)).EQ.5.OR.INS(I1,1).EQ.6)GOTO 390 DO 400 I2=I1+1,NINS IF(EXEC(I2).AND.INS(I1,4).EQ.INS(I2,4))GOTO 390 IF((.NOT.EXEC(I2)).OR.INS(I2,2).NE.6.OR. - ABS(INS(I2,1)).EQ.5.OR.ABS(INS(I2,1)).EQ.12.OR. - INS(I2,1).EQ.6.OR.INS(I2,3).NE.INS(I1,4))GOTO 400 IF(INS(I1,1).EQ.-INS(I2,1).AND.ABS(INS(I1,1)).EQ.11)THEN INS(I2,1)=6 INS(I2,2)=6 INS(I2,3)=0 CHANGE=.TRUE. MODFLG(6:6)='F' ELSEIF(INS(I1,1).EQ.-INS(I2,1).OR. - (INS(I1,1).EQ.-6.AND.INS(I2,1).EQ.-6).OR. - (INS(I1,1).EQ.10.AND.INS(I2,1).EQ.10))THEN INS(I2,1)=6 INS(I2,2)=6 INS(I2,3)=INS(I1,3) CHANGE=.TRUE. MODFLG(6:6)='F' ENDIF 400 CONTINUE 390 CONTINUE * Substitute minus x in the expressions when possible. DO 430 I1=IINS0,NINS IF(INS(I1,1).NE.-6.OR.INS(I1,2).NE.6)GOTO 430 DO 440 I2=I1+1,NINS IF(INS(I1,4).EQ.INS(I2,4))GOTO 430 IF(INS(I2,3).EQ.INS(I1,4).AND. - (INS(I2,2).EQ.1.OR.INS(I2,2).EQ.2))THEN INS(I2,2)=3-INS(I2,2) INS(I2,3)=INS(I1,3) CHANGE=.TRUE. MODFLG(7:7)='M' ELSEIF(INS(I2,1).EQ.INS(I1,4).AND.INS(I2,2).EQ.1)THEN INS(I2,1)=INS(I2,3) INS(I2,2)=2 INS(I2,3)=INS(I1,3) CHANGE=.TRUE. MODFLG(7:7)='M' ENDIF 440 CONTINUE 430 CONTINUE * Remove complementary operations like x-y -> z, z-x -> w. DO 410 I1=IINS0,NINS IF(.NOT.EXEC(I1))GOTO 410 DO 420 I2=I1+1,NINS IF(.NOT.EXEC(I2))GOTO 420 IF(INS(I1,4).EQ.INS(I2,4))GOTO 410 IF(((INS(I1,2).EQ.1.AND.INS(I2,2).EQ.2).OR. - (INS(I1,2).EQ.3.AND.INS(I2,2).EQ.4)).AND. - INS(I1,4).EQ.INS(I2,1).AND. - (INS(I1,1).EQ.INS(I2,3).OR.INS(I1,3).EQ.INS(I2,3)))THEN INS(I2,1)=6 INS(I2,2)=6 IF(INS(I1,1).EQ.INS(I2,3))THEN INS(I2,3)=INS(I1,3) ELSE INS(I2,3)=INS(I1,1) ENDIF CHANGE=.TRUE. MODFLG(8:8)='O' ENDIF IF(((INS(I1,2).EQ.2.AND.INS(I2,2).EQ.1).OR. - (INS(I1,2).EQ.4.AND.INS(I2,2).EQ.3)).AND. - ((INS(I1,4).EQ.INS(I2,1).AND.INS(I1,3).EQ.INS(I2,3)).OR. - (INS(I1,4).EQ.INS(I2,3).AND.INS(I1,3).EQ.INS(I2,1)))) - THEN INS(I2,1)=6 INS(I2,2)=6 INS(I2,3)=INS(I1,1) CHANGE=.TRUE. MODFLG(8:8)='O' ENDIF IF(INS(I1,2).EQ.2.AND.INS(I2,2).EQ.2.AND. - INS(I1,1).EQ.INS(I2,3).AND.INS(I1,4).EQ.INS(I2,1))THEN INS(I2,1)=-6 INS(I2,2)=6 INS(I2,3)=INS(I1,3) CHANGE=.TRUE. MODFLG(8:8)='O' ENDIF 420 CONTINUE 410 CONTINUE ELSE MODFLG(5:5)='e' MODFLG(6:6)='f' MODFLG(7:7)='m' MODFLG(8:8)='o' ENDIF * Mark the instructions whose results are not used as EXEC=F. DO 470 I1=NINS,IINS0,-1 IF(.NOT.EXEC(I1).OR.INS(I1,2).EQ.0.OR.INS(I1,2).EQ.7.OR. - INS(I1,2).EQ.8.OR.ABS(INS(I1,2)).EQ.9)GOTO 470 IF(LOOP)THEN ISTART=IINS0 ELSE ISTART=I1+1 ENDIF DO 480 I2=ISTART,NINS IF(.NOT.EXEC(I2))GOTO 480 IF((INS(I2,1).EQ.INS(I1,4).AND.INS(I2,2).NE.0.AND. - INS(I2,2).NE.6.AND.INS(I2,2).NE.8.AND.INS(I2,2).NE.9).OR. - (INS(I2,3).EQ.INS(I1,4).AND.ABS(INS(I2,2)).NE.9))GOTO 470 480 CONTINUE CHANGE=.TRUE. MODFLG(9:9)='X' EXEC(I1)=.FALSE. 470 CONTINUE * Remove statements marked not to be executed. IEXEC=IINS0-1 DO 490 I=IINS0,NINS IF(EXEC(I))THEN IEXEC=IEXEC+1 INS(IEXEC,1)=INS(I,1) INS(IEXEC,2)=INS(I,2) INS(IEXEC,3)=INS(I,3) INS(IEXEC,4)=INS(I,4) EXEC(IEXEC)=.TRUE. ENDIF 490 CONTINUE IF(IEXEC.EQ.0)THEN PRINT *,' ###### ALGPRE ERROR : No instructions left'// - ' (program bug); expression can not be handled.' RETURN ENDIF NINS=IEXEC * Check whether any further cycles are needed. IF(LDEBUG.AND.CHANGE)THEN WRITE(LUNOUT,'(/26X,''Modification flags: '',A9)') MODFLG CALL ALGPRT(IINS0,NINS) ENDIF IF(CHANGE)GOTO 300 *** Continue here if simplication was skipped. 600 CONTINUE *** Remove unused registers, first find smallest and largest register. MAXREG=0 MINREG=1 DO 500 I=IINS0,NINS IF(INS(I,2).NE.0.AND.INS(I,2).NE.6.AND.INS(I,2).NE.8.AND. - INS(I,2).NE.9)THEN MAXREG=MAX(MAXREG,INS(I,1)) MINREG=MIN(MINREG,INS(I,1)) ENDIF IF(ABS(INS(I,2)).NE.9)THEN MAXREG=MAX(MAXREG,INS(I,3)) MINREG=MIN(MINREG,INS(I,3)) ENDIF 500 CONTINUE * Remove the largest unused registers. NREG=NVAR DO 510 I1=NVAR+1,MAXREG NREG=NREG+1 CHANGE=.FALSE. DO 520 I2=IINS0,NINS IF(INS(I2,1).EQ.I1.AND.INS(I2,2).NE.0.AND.INS(I2,2).NE.6.AND. - INS(I2,2).NE.8.AND.INS(I2,2).NE.9)THEN CHANGE=.TRUE. INS(I2,1)=NREG ENDIF IF(INS(I2,3).EQ.I1.AND.ABS(INS(I2,2)).NE.9)THEN CHANGE=.TRUE. INS(I2,3)=NREG ENDIF IF(INS(I2,4).EQ.I1)THEN CHANGE=.TRUE. INS(I2,4)=NREG ENDIF 520 CONTINUE IF(.NOT.CHANGE)NREG=NREG-1 510 CONTINUE * Free memory associated with no longer used constants. DO 570 I1=ICONS0,MINREG,-1 USECON=.FALSE. DO 580 I2=IINS0,NINS IF((INS(I2,1).EQ.I1.AND.INS(I2,2).NE.0.AND.INS(I2,2).NE.6).OR. - INS(I2,3).EQ.I1)USECON=.TRUE. 580 CONTINUE IF(.NOT.USECON)CALL ALGREU(NINT(REG(I1)),MODREG(I1),0) 570 CONTINUE * Remove the smallest unused constants. NCONS=ICONS0+1 DO 530 I1=ICONS0,MINREG,-1 NCONS=NCONS-1 CHANGE=.FALSE. DO 540 I2=IINS0,NINS IF(INS(I2,1).EQ.I1.AND.INS(I2,2).NE.0.AND.INS(I2,2).NE.6.AND. - INS(I2,2).NE.8.AND.INS(I2,2).NE.9)THEN CHANGE=.TRUE. REG(NCONS)=REG(INS(I2,1)) MODREG(NCONS)=MODREG(INS(I2,1)) INS(I2,1)=NCONS ENDIF IF(INS(I2,3).EQ.I1.AND.ABS(INS(I2,2)).NE.9)THEN CHANGE=.TRUE. REG(NCONS)=REG(INS(I2,3)) MODREG(NCONS)=MODREG(INS(I2,3)) INS(I2,3)=NCONS ENDIF 540 CONTINUE IF(.NOT.CHANGE)NCONS=NCONS+1 530 CONTINUE * Find out which variables are effectively used. DO 550 I1=1,NVAR USE(I1)=.FALSE. DO 560 I2=IINS0,NINS IF((INS(I2,1).EQ.I1.AND.INS(I2,2).NE.0.AND.INS(I2,2).NE.6).OR. - INS(I2,3).EQ.I1)USE(I1)=.TRUE. 560 CONTINUE 550 CONTINUE *** Update entry point. ALGENT(NALGE,3)=1 IF(LOOP)THEN ALGENT(NALGE,4)=0 ELSE ALGENT(NALGE,4)=1 ENDIF ALGENT(NALGE,6)=NINS-IINS0+1 ALGENT(NALGE,9)=ICONS0-NCONS+1 ALGENT(NALGE,10)=NRES *** Print the final version of the instruction list. IF(LDEBUG)THEN WRITE(LUNOUT,'(/,26X,''Final instruction list:'')') CALL ALGPRT(IINS0,NINS) IF(NCONS.LT.ICONS0)THEN WRITE(LUNOUT,'(/,26X,''Constants appearing'', - '' in the final instruction list:'')') DO 700 I=ICONS0,NCONS,-1 WRITE(LUNOUT,1010) I,REG(I),MODREG(I) 700 CONTINUE ENDIF WRITE(LUNOUT,'(/26X,''Valid variable names:'')') DO 710 I=1,NVAR IF(USE(I))WRITE(LUNOUT,1040) I,VARLIS(I) IF(.NOT.USE(I))WRITE(LUNOUT,1050) I,VARLIS(I) 710 CONTINUE WRITE(LUNOUT,1030) NINS-IINS0+1,MXINS, - NREG,MXREG,ICONS0-NCONS+1,1-MXCONS,NRES IF(LDEBUG)WRITE(LUNOUT,'(/26X, - ''Entry point '',I4,'' assigned to this list:''/ - 26X,''Reference number: '',I4/ - 26X,''In use (1) or not (0): '',I4/ - 26X,''Correct (1) or not (0): '',I4/ - 26X,''Sequential (1) or not (0): '',I4/ - 26X,''First instruction at line: '',I4/ - 26X,''Number of instructions: '',I4/ - 26X,''Number of registers used: '',I4/ - 26X,''First local constant at: '',I4/ - 26X,''Number of local constants: '',I4/ - 26X,''Number of results produced: '',I4/)') - NALGE,(ALGENT(NALGE,I),I=1,10) WRITE(LUNOUT,'('' ++++++ ALGPRE DEBUG : End of'', - '' the debugging output.'')') ENDIF *** Normal end of this routine. IFAIL=0 RETURN *** Handle error conditions due to lack of storage space. 3010 CONTINUE PRINT *,' ###### ALGPRE ERROR : String resulting from first'// - ' translation (see writeup)' PRINT *,' is longer than 82 chars;'// - ' expression can not be handled.' RETURN 3020 CONTINUE PRINT *,' ###### ALGPRE ERROR : Number of constants used in'// - ' the expression is larger than MXCONS;' PRINT *,' increase this parameter'// - ' and recompile or simplify the expression.' RETURN 3030 CONTINUE PRINT *,' ###### ALGPRE ERROR : Number of registers needed'// - ' is larger than MXREG;' PRINT *,' increase this parameter'// - ' and recompile or simplify the expression.' RETURN 3040 CONTINUE PRINT *,' ###### ALGPRE ERROR : Number of instructions'// - ' needed exceeds MXINS;' PRINT *,' increase this parameter'// - ' and recompile or simplify the expression.' RETURN END +DECK,ALGPRT. SUBROUTINE ALGPRT(ISTART,IEND) *----------------------------------------------------------------------- * ALGPRT - Routine printing the instructions produced by ALGPRE in a * somewhat legible manner. * (Last changed on 15/11/08.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,ALGDATA. +SEQ,PRINTPLOT. CHARACTER*132 AUX CHARACTER*(MXINCH) OUTPUT INTEGER ISTART,IEND,NO,NNO,I,J,NCAUX REAL EPS *** Identify the routine IF(LIDENT)PRINT *,' /// ROUTINE ALGPRT ///' EPS=1.0E-5 *** Loop over the instructions. DO 10 I=ISTART,IEND * Write the instruction number to the output string WRITE(OUTPUT,'(''Ins%'',I4,'':%'')') I NO=10 * Do nothing IF(INS(I,2).EQ.-1)THEN OUTPUT(NO+1:NO+10)='Do%nothing' NO=NO+10 * The instruction is a RESULT type statement ELSEIF(INS(I,2).EQ.0)THEN IF(INS(I,3).GT.0)THEN WRITE(AUX,'(''Result%'',I4,''%=%R'',I4)') - INS(I,4),INS(I,3) OUTPUT(NO+1:NO+19)=AUX(1:19) NO=NO+19 ELSE WRITE(AUX,'(''Result%'',I4,''%=%'')') INS(I,4) OUTPUT(NO+1:NO+14)=AUX(1:14) NO=NO+14 CALL OUTFMT(REG(INS(I,3)),MODREG(INS(I,3)), - AUX,NCAUX,'LEFT') OUTPUT(NO+1:NO+NCAUX)=AUX(1:NCAUX) NO=NO+NCAUX ENDIF * The instruction is a real- or logical-arithmetic expression ELSEIF((INS(I,2).GE.1.AND.INS(I,2).LE.5).OR. - (INS(I,2).GE.10.AND.INS(I,2).LE.17))THEN IF(INS(I,4).GE.0)THEN WRITE(AUX,'(''R'',I4,''%:=%'')') INS(I,4) OUTPUT(NO+1:NO+9)=AUX(1:9) NO=NO+9 ELSE WRITE(AUX,'(''R('',I4,'')%:=%'')') INS(I,4) OUTPUT(NO+1:NO+11)=AUX(1:11) NO=NO+11 ENDIF IF(INS(I,1).GT.0)THEN WRITE(AUX,'(''R'',I4,''%'')') INS(I,1) OUTPUT(NO+1:NO+6)=AUX(1:6) NO=NO+6 ELSE CALL OUTFMT(REG(INS(I,1)),MODREG(INS(I,1)), - AUX,NCAUX,'LEFT') OUTPUT(NO+1:NO+NCAUX+1)=AUX(1:NCAUX)//'%' NO=NO+NCAUX+1 ENDIF IF(INS(I,2).EQ.1) OUTPUT(NO+1:NO+2)='+%' IF(INS(I,2).EQ.2) OUTPUT(NO+1:NO+2)='-%' IF(INS(I,2).EQ.3) OUTPUT(NO+1:NO+2)='*%' IF(INS(I,2).EQ.4) OUTPUT(NO+1:NO+2)='/%' IF(INS(I,2).EQ.5) OUTPUT(NO+1:NO+3)='**%' IF(INS(I,2).EQ.10)OUTPUT(NO+1:NO+2)='=%' IF(INS(I,2).EQ.11)OUTPUT(NO+1:NO+2)='#%' IF(INS(I,2).EQ.12)OUTPUT(NO+1:NO+2)='<%' IF(INS(I,2).EQ.13)OUTPUT(NO+1:NO+3)='<=%' IF(INS(I,2).EQ.14)OUTPUT(NO+1:NO+2)='>%' IF(INS(I,2).EQ.15)OUTPUT(NO+1:NO+3)='>=%' IF(INS(I,2).EQ.16)OUTPUT(NO+1:NO+2)='&%' IF(INS(I,2).EQ.17)OUTPUT(NO+1:NO+2)='|%' NO=NO+2 IF(INS(I,2).EQ.5.OR.INS(I,2).EQ.13.OR.INS(I,2).EQ.15)NO=NO+1 IF(INS(I,3).GT.0)THEN WRITE(AUX,'(''R'',I4)') INS(I,3) OUTPUT(NO+1:NO+5)=AUX(1:5) NO=NO+5 ELSE CALL OUTFMT(REG(INS(I,3)),MODREG(INS(I,3)), - AUX,NCAUX,'LEFT') OUTPUT(NO+1:NO+NCAUX+1)=AUX(1:NCAUX)//'%' NO=NO+NCAUX+1 ENDIF * The instruction is a function ELSEIF(INS(I,2).EQ.6)THEN IF(INS(I,4).GE.0)THEN WRITE(AUX,'(''R'',I4,''%:=%'')') INS(I,4) OUTPUT(NO+1:NO+9)=AUX(1:9) NO=NO+9 ELSE WRITE(AUX,'(''R('',I4,'')%:=%'')') INS(I,4) OUTPUT(NO+1:NO+11)=AUX(1:11) NO=NO+11 ENDIF IF(INS(I,1).EQ.-12)THEN OUTPUT(NO+1:NO+7)='Number(' NO=NO+7 ELSEIF(INS(I,1).EQ.-11)THEN OUTPUT(NO+1:NO+9)='Trailing(' NO=NO+9 ELSEIF(INS(I,1).EQ.-9)THEN OUTPUT(NO+1:NO+8)='arctanh(' NO=NO+8 ELSEIF(INS(I,1).EQ.-8)THEN OUTPUT(NO+1:NO+8)='arccosh(' NO=NO+8 ELSEIF(INS(I,1).EQ.-7)THEN OUTPUT(NO+1:NO+8)='arcsinh(' NO=NO+8 ELSEIF(INS(I,1).EQ.-6)THEN OUTPUT(NO+1:NO+1)='-' NO=NO+1 ELSEIF(INS(I,1).EQ.-5)THEN OUTPUT(NO+1:NO+5)='sqrt(' NO=NO+5 ELSEIF(INS(I,1).EQ.-4)THEN OUTPUT(NO+1:NO+6)='arctan(' NO=NO+6 ELSEIF(INS(I,1).EQ.-3)THEN OUTPUT(NO+1:NO+6)='arccos(' NO=NO+6 ELSEIF(INS(I,1).EQ.-2)THEN OUTPUT(NO+1:NO+6)='arcsin(' NO=NO+6 ELSEIF(INS(I,1).EQ.-1)THEN OUTPUT(NO+1:NO+4)='log(' NO=NO+4 ELSEIF(INS(I,1).EQ.+1)THEN OUTPUT(NO+1:NO+4)='exp(' NO=NO+4 ELSEIF(INS(I,1).EQ.+2)THEN OUTPUT(NO+1:NO+4)='sin(' NO=NO+4 ELSEIF(INS(I,1).EQ.+3)THEN OUTPUT(NO+1:NO+4)='cos(' NO=NO+4 ELSEIF(INS(I,1).EQ.+4)THEN OUTPUT(NO+1:NO+4)='tan(' NO=NO+4 ELSEIF(INS(I,1).EQ.+5)THEN OUTPUT(NO+1:NO+1)='|' NO=NO+1 ELSEIF(INS(I,1).EQ.+6)THEN OUTPUT(NO+1:NO+1)='+' NO=NO+1 ELSEIF(INS(I,1).EQ.+7)THEN OUTPUT(NO+1:NO+5)='sinh(' NO=NO+5 ELSEIF(INS(I,1).EQ.+8)THEN OUTPUT(NO+1:NO+5)='cosh(' NO=NO+5 ELSEIF(INS(I,1).EQ.+9)THEN OUTPUT(NO+1:NO+5)='tanh(' NO=NO+5 ELSEIF(INS(I,1).EQ.+10)THEN OUTPUT(NO+1:NO+4)='not(' NO=NO+4 ELSEIF(INS(I,1).EQ.+11)THEN OUTPUT(NO+1:NO+7)='Entier(' NO=NO+7 ELSEIF(INS(I,1).EQ.+12)THEN OUTPUT(NO+1:NO+7)='String(' NO=NO+7 ELSEIF(INS(I,1).EQ.+13)THEN OUTPUT(NO+1:NO+4)='Sum(' NO=NO+4 ELSEIF(INS(I,1).EQ.+14)THEN OUTPUT(NO+1:NO+8)='Product(' NO=NO+8 ELSEIF(INS(I,1).EQ.+15)THEN OUTPUT(NO+1:NO+10)='Reference(' NO=NO+10 ELSEIF(INS(I,1).EQ.+16)THEN OUTPUT(NO+1:NO+7)='Global(' NO=NO+7 ELSEIF(INS(I,1).EQ.+17)THEN OUTPUT(NO+1:NO+5)='Type(' NO=NO+5 ELSEIF(INS(I,1).EQ.+18)THEN OUTPUT(NO+1:NO+7)='Landau(' NO=NO+7 ELSEIF(INS(I,1).EQ.+19)THEN OUTPUT(NO+1:NO+8)='Minimum(' NO=NO+8 ELSEIF(INS(I,1).EQ.+20)THEN OUTPUT(NO+1:NO+8)='Maximum(' NO=NO+8 ELSEIF(INS(I,1).EQ.+21)THEN OUTPUT(NO+1:NO+19)='Random_uniform[0,1]' NO=NO+19 GOTO 30 ELSEIF(INS(I,1).EQ.+22)THEN OUTPUT(NO+1:NO+20)='Random_Gaussian(0,1)' NO=NO+20 GOTO 30 ELSEIF(INS(I,1).EQ.+23)THEN OUTPUT(NO+1:NO+19)='Random_exponential(' NO=NO+19 ELSEIF(INS(I,1).EQ.+24)THEN OUTPUT(NO+1:NO+15)='Random_Poisson(' NO=NO+15 ELSEIF(INS(I,1).EQ.+25)THEN OUTPUT(NO+1:NO+13)='Random_Landau' NO=NO+13 GOTO 30 ELSEIF(INS(I,1).EQ.+26)THEN OUTPUT(NO+1:NO+13)='Random_Polya(' NO=NO+13 ELSEIF(INS(I,1).EQ.+27)THEN OUTPUT(NO+1:NO+15)='Random_function' NO=NO+15 GOTO 30 ELSEIF(INS(I,1).EQ.+28)THEN OUTPUT(NO+1:NO+17)='Random_histogram(' NO=NO+17 ELSEIF(INS(I,1).EQ.+29)THEN OUTPUT(NO+1:NO+13)='Random_gamma(' NO=NO+13 ELSEIF(INS(I,1).EQ.+30)THEN OUTPUT(NO+1:NO+13)='Random_Laplace(' NO=NO+15 ELSEIF(INS(I,1).EQ.+40)THEN OUTPUT(NO+1:NO+4)='Row(' NO=NO+4 ELSEIF(INS(I,1).EQ.+41)THEN OUTPUT(NO+1:NO+5)='Mean(' NO=NO+5 ELSEIF(INS(I,1).EQ.+42)THEN OUTPUT(NO+1:NO+4)='RMS(' NO=NO+4 ELSEIF(INS(I,1).EQ.+43)THEN OUTPUT(NO+1:NO+5)='Size(' NO=NO+5 ELSEIF(INS(I,1).EQ.+44)THEN OUTPUT(NO+1:NO+7)='Zeroes(' NO=NO+7 ELSEIF(INS(I,1).EQ.+45)THEN OUTPUT(NO+1:NO+5)='Ones(' NO=NO+5 ELSEIF(INS(I,1).EQ.+46)THEN OUTPUT(NO+1:NO+6)='Exist(' NO=NO+6 ELSEIF(INS(I,1).EQ.+47)THEN OUTPUT(NO+1:NO+6)='Gamma(' NO=NO+6 ELSEIF(INS(I,1).EQ.+48)THEN OUTPUT(NO+1:NO+9)='LogGamma(' NO=NO+9 ELSEIF(INS(I,1).EQ.+49)THEN OUTPUT(NO+1:NO+8)='Reverse(' NO=NO+8 ELSEIF(INS(I,1).EQ.+51)THEN OUTPUT(NO+1:NO+17)='String_reference(' NO=NO+17 ELSEIF(INS(I,1).EQ.+54)THEN OUTPUT(NO+1:NO+20)='Histogram_reference(' NO=NO+20 ELSEIF(INS(I,1).EQ.+55)THEN OUTPUT(NO+1:NO+17)='Matrix_reference(' NO=NO+17 ELSE OUTPUT(NO+1:NO+20)='%(' NO=NO+20 ENDIF IF(INS(I,3).GT.0)THEN WRITE(AUX,'(''R'',I4)') INS(I,3) OUTPUT(NO+1:NO+6)=AUX(1:5) NO=NO+5 ELSE CALL OUTFMT(REG(INS(I,3)),MODREG(INS(I,3)), - AUX,NCAUX,'LEFT') OUTPUT(NO+1:NO+NCAUX)=AUX(1:NCAUX) NO=NO+NCAUX ENDIF IF(INS(I,1).NE.+5.AND.ABS(INS(I,1)).NE.+6)THEN OUTPUT(NO+1:NO+1)=')' NO=NO+1 ELSEIF(INS(I,1).EQ.+5)THEN OUTPUT(NO+1:NO+1)='|' NO=NO+1 ENDIF 30 CONTINUE * The instruction is an (un)conditional RETURN, EXIT or QUIT. ELSEIF(INS(I,2).EQ.-9)THEN IF(INS(I,1).GT.0)THEN WRITE(AUX,'(''If%R'',I4,''%Then%'')') INS(I,1) OUTPUT(NO+1:NO+14)=AUX(1:14) NO=NO+14 ELSEIF(ABS(REG(INS(I,1))).LT.EPS)THEN OUTPUT(NO+1:NO+6)='Never%' NO=NO+6 ELSEIF(ABS(REG(INS(I,1))-1.0).LT.EPS)THEN OUTPUT(NO+1:NO+7)='Always%' NO=NO+7 ELSE OUTPUT(NO+1:NO+35)= - 'If%%Then%' NO=NO+35 ENDIF IF(INS(I,3).EQ.0)THEN OUTPUT(NO+1:NO+6)='Return' NO=NO+6 ELSEIF(INS(I,3).EQ.1)THEN OUTPUT(NO+1:NO+4)='Exit' NO=NO+4 ELSEIF(INS(I,3).EQ.2)THEN OUTPUT(NO+1:NO+4)='Stop' NO=NO+4 ELSE OUTPUT(NO+1:NO+27)='Return%with%invalid%operand' NO=NO+27 ENDIF * The instruction is a RETURN by means of a GOTO. ELSEIF(INS(I,1).EQ.-1.AND.INS(I,2).EQ.7.AND.INS(I,3).EQ.0)THEN OUTPUT(NO+1:NO+28)='Return%by%out-of-bounds%Goto' NO=NO+28 * The instruction is an (un)conditional GOTO ELSEIF(INS(I,2).EQ.7)THEN IF(INS(I,1).GT.0)THEN WRITE(AUX,'(''If%R'',I4,''%Then%Goto%Ins%'')') INS(I,1) OUTPUT(NO+1:NO+23)=AUX(1:23) NO=NO+23 ELSEIF(ABS(REG(INS(I,1))).LT.EPS)THEN OUTPUT(NO+1:NO+15)='Never%Goto%Ins%' NO=NO+15 ELSEIF(ABS(REG(INS(I,1))-1.0).LT.EPS)THEN OUTPUT(NO+1:NO+16)='Always%Goto%Ins%' NO=NO+16 ELSE OUTPUT(NO+1:NO+39)= - 'If%%Goto%Ins%' NO=NO+39 ENDIF IF(INS(I,3).GE.0)THEN WRITE(AUX,'(''R'',I4)') INS(I,3) OUTPUT(NO+1:NO+5)=AUX(1:5) NO=NO+5 ELSE WRITE(AUX,'(I4)') NINT(REG(INS(I,3))) OUTPUT(NO+1:NO+4)=AUX(1:4) NO=NO+4 ENDIF * Instruction is an argument building function. ELSEIF(INS(I,2).EQ.8)THEN IF(INS(I,3).GT.0)THEN WRITE(AUX,'(''Arg'',I4,''%:=%R'',I4)') - INS(I,4),INS(I,3) OUTPUT(NO+1:NO+16)=AUX(1:16) NO=NO+16 ELSE WRITE(AUX,'(''Arg'',I4,''%:=%'')') INS(I,4) OUTPUT(NO+1:NO+11)=AUX(1:11) NO=NO+11 CALL OUTFMT(REG(INS(I,3)),MODREG(INS(I,3)), - AUX,NCAUX,'LEFT') OUTPUT(NO+1:NO+NCAUX)=AUX(1:NCAUX) NO=NO+NCAUX ENDIF IF(INS(I,1).EQ.0)THEN OUTPUT(NO+1:NO+21)=',%modifiable,%global.' NO=NO+21 ELSEIF(INS(I,1).EQ.1)THEN OUTPUT(NO+1:NO+25)=',%modifiable,%non-global.' NO=NO+25 ELSEIF(INS(I,1).EQ.2)THEN OUTPUT(NO+1:NO+25)=',%non-modifiable,%global.' NO=NO+25 ELSEIF(INS(I,1).EQ.3)THEN OUTPUT(NO+1:NO+29)=',%non-modifiable,%non-global.' NO=NO+29 ELSE OUTPUT(NO+1:NO+28)=',%invalid%modification%flag.' NO=NO+28 ENDIF * Instruction is an external function call. ELSEIF(INS(I,2).EQ.9)THEN WRITE(AUX,'(''Call%procedure%'',I4,''%with%'',I4, - ''%arguments.'')') INS(I,1),INS(I,3) OUTPUT(NO+1:NO+40)=AUX(1:40) NO=NO+40 * Instruction not identified ELSE OUTPUT(NO+1:NO+37)='Unidentified,%unexecutable%statement.' NO=NO+37 ENDIF * Remove blanks NNO=0 DO 20 J=1,NO IF(OUTPUT(J:J).NE.' ')THEN NNO=NNO+1 IF(OUTPUT(J:J).EQ.'%')OUTPUT(NNO:NNO)=' ' IF(OUTPUT(J:J).NE.'%')OUTPUT(NNO:NNO)=OUTPUT(J:J) ENDIF 20 CONTINUE * Add the string '(deleted)' if marked not executable IF(.NOT.EXEC(I))OUTPUT(56:64)='(deleted)' * And write the string to the output WRITE(LUNOUT,'(26X,A)') OUTPUT(1:NNO) 10 CONTINUE *** Add a blank line to make the output more legible WRITE(LUNOUT,'('' '')') END +DECK,ALGREU. SUBROUTINE ALGREU(IREG,IMOD,IUSAGE) *----------------------------------------------------------------------- * ALGREU - Clears storage associated with strings and the like that * are being reused. * VARIABLES: IUSAGE : Flag with the same meaning as ARGREF(I,1). * (Last changed on 20/ 1/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,ALGDATA. +SEQ,GLOBALS. +SEQ,PRINTPLOT. INTEGER IUSAGE,NUSEG,NUSEC,IDUM(1),IREG,IMOD,I,IFAIL *** Identify the routine. IF(LIDENT)PRINT *,' /// ROUTINE ALGREU ///' *** Debugging output. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ ALGREU DEBUG : Reuse'', - '' request for ref='',I5,'', mode='',I2,'' usage='',I2)') - IREG,IMOD,IUSAGE *** If not String, Histogram or Matrix, simply return. IF(IMOD.NE.1.AND.IMOD.NE.4.AND.IMOD.NE.5)THEN IMOD=0 RETURN ENDIF *** Count references from globals. NUSEG=0 DO 10 I=1,NGLB IF(GLBMOD(I).EQ.IMOD.AND.NINT(GLBVAL(I)).EQ.IREG)NUSEG=NUSEG+1 10 CONTINUE *** Count references from constants in active instruction lists. NUSEC=0 DO 20 I=-6,NCONS,-1 IF(MODREG(I).EQ.IMOD.AND.NINT(REG(I)).EQ.IREG)NUSEC=NUSEC+1 20 CONTINUE *** Delete the String, Histogram or Matrix if not needed anymore. IF((IUSAGE.EQ.0.AND.NUSEG+NUSEC.LE.1).OR. - (IUSAGE.EQ.1.AND.NUSEG+NUSEC.LE.0))THEN IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ ALGREU DEBUG :'', - '' Deleting, global ref: '',I5,'' const ref: '',I5)') - NUSEG,NUSEC IF(IMOD.EQ.1)THEN CALL STRBUF('DELETE',IREG,' ',1,IFAIL) ELSEIF(IMOD.EQ.4)THEN CALL HISADM('DELETE',IREG,0,0.0,0.0,.FALSE.,IFAIL) ELSEIF(IMOD.EQ.5)THEN CALL MATADM('DELETE',IREG,0,IDUM,0,IFAIL) ENDIF IMOD=0 ELSEIF(LDEBUG)THEN WRITE(LUNOUT,'('' ++++++ ALGREU DEBUG : Not'', - '' deleting, global ref: '',I5,'' const ref: '',I5)') - NUSEG,NUSEC ENDIF END +DECK,ALGSTC. SUBROUTINE ALGSTC *----------------------------------------------------------------------- * ALGSTC - Saves current environment. * ALGUST - Restores current environment. * (Last changed on 11/11/99.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,ALGDATA. +SEQ,PRINTPLOT. REAL ARGSAV(MXARG),REGSAV(MXCONS:MXREG) INTEGER MODARS(MXARG),ARGRFS(MXARG,2),MODRGS(MXCONS:MXREG),I +SELF,IF=SAVE. SAVE ARGSAV,MODARS,ARGRFS,REGSAV,MODRGS +SELF. *** Save the argument block. DO 10 I=1,MXARG ARGSAV(I)=ARG(I) MODARS(I)=MODARG(I) ARGRFS(I,1)=ARGREF(I,1) ARGRFS(I,2)=ARGREF(I,2) 10 CONTINUE *** Save the registers. DO 20 I=MXCONS,MXREG REGSAV(I)=REG(I) MODRGS(I)=MODREG(I) 20 CONTINUE *** End of the saving part. RETURN *** Restore. ENTRY ALGUST *** Save the argument block. DO 30 I=1,MXARG ARG(I)=ARGSAV(I) MODARG(I)=MODARS(I) ARGREF(I,1)=ARGRFS(I,1) ARGREF(I,2)=ARGRFS(I,2) 30 CONTINUE *** Save the registers. DO 40 I=MXCONS,MXREG REG(I)=REGSAV(I) MODREG(I)=MODRGS(I) 40 CONTINUE END +DECK,ALGTYP. SUBROUTINE ALGTYP(VARINP,IMODE) *----------------------------------------------------------------------- * ALGTYP - Determines the type of the argument string. Return one of * the following: 0 - Undefined, 1 - String, 2 - Number, * 3 - Logical, 4 - Histogram or 5 - Matrix. * (Last changed on 9/11/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. CHARACTER*(*) VARINP CHARACTER*(MXINCH) VAR INTEGER IMODE,I,NC LOGICAL MANT,POWER,DOT,NUMBER,PASS,END,SIGN *** Store the length. NC=LEN(VARINP) *** Ensure the length is not nill or too large. IF(NC.LT.1.OR.NC.GT.MXINCH)THEN PRINT *,' !!!!!! ALGTYP WARNING : Argument string is too'// - ' long or too short; returning Undefined as type.' IMODE=0 RETURN ENDIF *** Convert to upper case. VAR=VARINP CALL CLTOU(VAR) *** Check for Undefined. IF(VAR(1:NC).EQ.'NILL')THEN IMODE=0 *** Check for Logical. ELSEIF(VAR(1:NC).EQ.'TRUE'.OR.VAR(1:NC).EQ.'FALSE')THEN IMODE=3 *** Separate numbers and strings. ELSE * Preset the state flags. MANT=.FALSE. POWER=.FALSE. DOT=.FALSE. END=.FALSE. NUMBER=.FALSE. SIGN=.FALSE. PASS=.TRUE. END=.FALSE. * Loop over the string. DO 10 I=1,NC * Only leading and trailing blanks. IF(VAR(I:I).EQ.' ')THEN IF(MANT.OR.POWER.OR.DOT)END=.TRUE. * Only only dot and only in the mantissa. ELSEIF(VAR(I:I).EQ.'.')THEN IF(END.OR.DOT.OR.POWER)PASS=.FALSE. DOT=.TRUE. IF(.NOT.POWER)MANT=.TRUE. * Only one exponent; switch from mantissa to exponent. ELSEIF(VAR(I:I).EQ.'E')THEN IF(END.OR.POWER)PASS=.FALSE. MANT=.FALSE. POWER=.TRUE. NUMBER=.FALSE. DOT=.FALSE. SIGN=.FALSE. * Only one leading sign per mantissa and per exponent. ELSEIF(INDEX('+-',VAR(I:I)).NE.0)THEN IF(END.OR.SIGN.OR.NUMBER)PASS=.FALSE. SIGN=.TRUE. IF(.NOT.POWER)MANT=.TRUE. * Numbers anywhere, except after blanks. ELSEIF(INDEX('0123456789',VAR(I:I)).NE.0)THEN IF(END)PASS=.FALSE. NUMBER=.TRUE. IF(.NOT.POWER)MANT=.TRUE. * Unknown characters are rejected. ELSE PASS=.FALSE. ENDIF 10 CONTINUE * If there is an exponent part, there must be a number. IF(POWER.AND..NOT.NUMBER)PASS=.FALSE. * If all tests passed, assign Number, otherwise String. IF(PASS)THEN IMODE=2 ELSE IMODE=1 ENDIF ENDIF END +DECK,NUMSAV. SUBROUTINE NUMSAV(VAL,NAME,IFAIL) *----------------------------------------------------------------------- * NUMSAV - Assigns a number to a global variable. * (Last changed on 24/ 4/96.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,GLOBALS. +SEQ,PRINTPLOT. CHARACTER*(*) NAME REAL VAL INTEGER IFAIL,JVAR,I *** Tracing and debugging output. IF(LIDENT)PRINT *,' /// ROUTINE NUMSAV ///' IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ NUMSAV WARNING : Storing '', - E15.8,'' as '',A)') VAL,NAME *** Initial failure flag setting. IFAIL=1 *** Scan the list of global variables. JVAR=0 DO 10 I=1,NGLB IF(GLBVAR(I).EQ.NAME)JVAR=I 10 CONTINUE *** If it didn't exist, create a new global ... IF(JVAR.EQ.0)THEN * if there still is space, IF(NGLB.LT.MXVAR)THEN NGLB=NGLB+1 GLBVAR(NGLB)=NAME JVAR=NGLB * otherwise issue a warning. ELSE PRINT *,' !!!!!! NUMSAV WARNING : No global variable'// - ' space left for ',NAME,'; number not saved.' RETURN ENDIF *** Otherwise re-use an existing global. ELSE CALL ALGREU(NINT(GLBVAL(JVAR)),GLBMOD(JVAR),0) ENDIF *** Assign the number to the global. GLBVAL(JVAR)=VAL GLBMOD(JVAR)=2 *** Things seem to have worked. IFAIL=0 END +DECK,LOGSAV. SUBROUTINE LOGSAV(VAL,NAME,IFAIL) *----------------------------------------------------------------------- * LOGSAV - Assigns a logical to a global variable. * (Last changed on 16/ 6/97.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,GLOBALS. +SEQ,PRINTPLOT. CHARACTER*(*) NAME LOGICAL VAL INTEGER IFAIL,JVAR,I *** Tracing and debugging output. IF(LIDENT)PRINT *,' /// ROUTINE LOGSAV ///' IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ LOGSAV WARNING : Storing '', - L1,'' as '',A)') VAL,NAME *** Initial failure flag setting. IFAIL=1 *** Scan the list of global variables. JVAR=0 DO 10 I=1,NGLB IF(GLBVAR(I).EQ.NAME)JVAR=I 10 CONTINUE *** If it didn't exist, create a new global ... IF(JVAR.EQ.0)THEN * if there still is space, IF(NGLB.LT.MXVAR)THEN NGLB=NGLB+1 GLBVAR(NGLB)=NAME JVAR=NGLB * otherwise issue a warning. ELSE PRINT *,' !!!!!! LOGSAV WARNING : No global variable'// - ' space left for ',NAME,'; logical not saved.' RETURN ENDIF *** Otherwise re-use an existing global. ELSE CALL ALGREU(NINT(GLBVAL(JVAR)),GLBMOD(JVAR),0) ENDIF *** Assign the number to the global. IF(VAL)THEN GLBVAL(JVAR)=1 ELSE GLBVAL(JVAR)=0 ENDIF GLBMOD(JVAR)=3 *** Things seem to have worked. IFAIL=0 END +PATCH,GRAPHICS. +DECK,COLSCL. REAL FUNCTION COLSCL(COL,FRAC) *----------------------------------------------------------------------- * COLSCL - Makes a given colour COL lighter or darker by an amount * FRAC. FRAC close to 0 is dark, close to 1 is light. * VARIABLES: EPS1 : Minimum (darkest) colour value returned. * EPS2 : Maximum (lightest) colour value returned. * is returned. * (Last changed on 7/10/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PARAMETERS. REAL COL,FRAC,EPS1,EPS2,CPEAK,CLOC,A,B,C PARAMETER(EPS1=0.2,EPS2=0.0) *** Parabola parameters. A=(PRFCAL-COL+EPS1-EPS1*PRFCAL-EPS2*PRFCAL)/(PRFCAL-PRFCAL**2) B=(COL-EPS1-PRFCAL**2+EPS1*PRFCAL**2+EPS2*PRFCAL**2)/ - (PRFCAL-PRFCAL**2) C=EPS1 *** Parabolic estimate. COLSCL=MAX(EPS1,MIN(1-EPS2,A*FRAC**2+B*FRAC+C)) *** If not a straight conversion, avoid negative sections. IF(A.NE.0)THEN CPEAK=C-B**2/(4*A) IF(CPEAK.LT.EPS1.OR.CPEAK.GT.1-EPS2)THEN CLOC=-B/(2*A) IF(CLOC.LE.PRFCAL.AND.FRAC.LE.PRFCAL)THEN COLSCL=EPS1+FRAC*(MAX(EPS1,MIN(1-EPS2,COLSCL))- - EPS1)/PRFCAL ELSEIF(CLOC.GE.PRFCAL.AND.FRAC.GE.PRFCAL)THEN COLSCL=MAX(EPS1,MIN(1-EPS2,COLSCL))+ - (FRAC-PRFCAL)*(1-EPS2- - MAX(EPS1,MIN(1-EPS2,COLSCL)))/(1-PRFCAL) ENDIF ENDIF ENDIF END +DECK,COLSHD. SUBROUTINE COLSHD(IOFF) *----------------------------------------------------------------------- * COLSHD - Generates a set of NPRCOL colours, starting at index IOFF, * which are gradually lighter versions of the current * fill area colour. * (Last changed on 7/10/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PARAMETERS. +SEQ,PRINTPLOT. INTEGER IOFF,IERR,ICOL,I REAL RED,GREEN,BLUE,COLSCL,F EXTERNAL COLSCL *** Obtain current fill area colour. CALL GQFACI(IERR,ICOL) *** Find out what this colour is in RGB. CALL GRQCR(1,ICOL,1,IERR,RED,GREEN,BLUE) *** Verify that the number is not zero. IF(NPRCOL.LE.0)THEN PRINT *,' !!!!!! COLSHD WARNING : Incorrect number of'// - ' shades given (program bug, please report).' RETURN ENDIF *** Debugging output. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ COLSHD DEBUG : Creating '', - I2,'' colours starting at '',I2/ - 26X,''Calibration point: '',F6.2/ - 26X,''Scaling range: '',F6.2,'' to '',F6.2/ - 26X,''Reference:'','' Red '',F6.2,'', Green '',F6.2, - '', Blue '',F6.2)') NPRCOL,IOFF,PRFCAL,PRFMIN,PRFMAX, - RED,GREEN,BLUE *** Generate the colour table. DO 10 I=1,NPRCOL F=PRFMIN+(PRFMAX-PRFMIN)*REAL(I-1)/REAL(NPRCOL-1) CALL GRSCR(1,IOFF+I-1, - COLSCL(RED,F),COLSCL(GREEN,F),COLSCL(BLUE,F)) IF(LDEBUG)WRITE(LUNOUT,'(26X,''Colour '',I2,'': Red '',F6.2, - '', Green '',F6.2,'', Blue '',F6.2)') IOFF+I-1, - COLSCL(RED,F),COLSCL(GREEN,F),COLSCL(BLUE,F) 10 CONTINUE END +DECK,COLRBW. SUBROUTINE COLRBW(IOFF) *----------------------------------------------------------------------- * COLRBW - Generates a set of NPRCOL colours, starting at index IOFF, * which are an approximation of a rainbow. * (Last changed on 12/11/02.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PARAMETERS. +SEQ,PRINTPLOT. INTEGER IOFF,I REAL RED,GREEN,BLUE,WL *** Verify that the number is not zero. IF(NPRCOL.LE.0)THEN PRINT *,' !!!!!! COLRBW WARNING : Incorrect number of'// - ' shades given (program bug, please report).' RETURN ENDIF *** Debugging output. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ COLRBW DEBUG : Creating '', - I2,'' colours starting at '',I2/ - 26X,''Lowest wave length: '',F6.2,'' nm''/ - 26X,''Highest wave length: '',F6.2,'' nm'')') - NPRCOL,IOFF,WLMIN,WLMAX *** Generate the colour table. DO 10 I=1,NPRCOL WL=WLMIN+(WLMAX-WLMIN)*REAL(I-1)/REAL(NPRCOL-1) CALL RAIN(WL,RED,GREEN,BLUE) CALL GRSCR(1,IOFF+I-1,RED,GREEN,BLUE) IF(LDEBUG)WRITE(LUNOUT,'(26X,''Colour '',I2,'': Red '',F6.2, - '', Green '',F6.2,'', Blue '',F6.2)') IOFF+I-1, - RED,GREEN,BLUE 10 CONTINUE END +DECK,COLSHM. SUBROUTINE COLSHM *----------------------------------------------------------------------- * COLSHM - Plots a colour map for the shadowing effects. * (Last changed on 12/11/02.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PARAMETERS. REAL XPL(5),YPL(5),XMIN,YMIN,XMAX,YMAX INTEGER I,J,NC,NTAB CHARACTER*20 STR *** Switch to graphics mode. CALL GRGRAF(.TRUE.) * Switch to normalised device coordinates. CALL GSELNT(0) *** Attributes, start with the solid interior style. CALL GSFAIS(1) * Set reasonable character attributes. CALL GSTXFP(0,2) CALL GSCHXP(1.0) CALL GSCHSP(0.0) CALL GSCHH(0.012) CALL GSTXAL(2,3) CALL GSCHUP(0.0,1.0) CALL GSTXCI(1) * Set reasonable polyline attributes. CALL GSPLCI(1) CALL GSLN(1) CALL GSLWSC(1.0) *** Loop over colour tables. NTAB=10 DO 10 I=1,NTAB * Make sure this table exists. IF( (I.EQ. 1.AND.ICOLBX.LE.0).OR. - (I.EQ. 2.AND.ICOLPL.LE.0).OR. - (I.EQ. 3.AND.ICOLW1.LE.0).OR. - (I.EQ. 4.AND.ICOLW2.LE.0).OR. - (I.EQ. 5.AND.ICOLW3.LE.0).OR. - (I.EQ. 6.AND.ICOLD1.LE.0).OR. - (I.EQ. 7.AND.ICOLD2.LE.0).OR. - (I.EQ. 8.AND.ICOLD3.LE.0).OR. - (I.EQ. 9.AND.ICOLST.LE.0).OR. - (I.EQ.10.AND.ICOLRB.LE.0))GOTO 10 * Set the horizontal extent covered by this table. XMIN=0.05+REAL(I-1)*0.91/REAL(NTAB) XMAX=0.05+REAL(I )*0.91/REAL(NTAB)-0.01 * Label the tables. IF(I.EQ.1)THEN CALL GTX(0.5*(XMIN+XMAX),0.95,'Box') ELSEIF(I.EQ.2)THEN CALL GTX(0.5*(XMIN+XMAX),0.95,'Planes') ELSEIF(I.EQ.3)THEN CALL GTX(0.5*(XMIN+XMAX),0.95,'Conductor 1') ELSEIF(I.EQ.4)THEN CALL GTX(0.5*(XMIN+XMAX),0.95,'Conductor 2') ELSEIF(I.EQ.5)THEN CALL GTX(0.5*(XMIN+XMAX),0.95,'Conductor 3') ELSEIF(I.EQ.6)THEN CALL GTX(0.5*(XMIN+XMAX),0.95,'Dielectric 1') ELSEIF(I.EQ.7)THEN CALL GTX(0.5*(XMIN+XMAX),0.95,'Dielectric 2') ELSEIF(I.EQ.8)THEN CALL GTX(0.5*(XMIN+XMAX),0.95,'Dielectric 3') ELSEIF(I.EQ.9)THEN CALL GTX(0.5*(XMIN+XMAX),0.95,'Strips') ELSEIF(I.EQ.10)THEN CALL GTX(0.5*(XMIN+XMAX),0.95,'Rainbow') ELSE CALL GTX(0.5*(XMIN+XMAX),0.95,'Unknown') ENDIF *** Loop over the colours. DO 20 J=1,NPRCOL YMIN=0.1+REAL(J-1)*0.8/REAL(NPRCOL) YMAX=0.1+REAL(J )*0.8/REAL(NPRCOL) * On first pass, label the colours. IF(I.EQ.1)THEN CALL OUTFMT(REAL(J),2,STR,NC,'LEFT') CALL GTX(0.025,0.5*(YMIN+YMAX),STR(1:NC)) ENDIF * Plot a rectangle with the colour. XPL(1)=XMIN YPL(1)=YMIN XPL(2)=XMIN YPL(2)=YMAX XPL(3)=XMAX YPL(3)=YMAX XPL(4)=XMAX YPL(4)=YMIN XPL(5)=XMIN YPL(5)=YMIN IF(I.EQ.1)THEN CALL GSFACI(ICOLBX+J-1) ELSEIF(I.EQ.2)THEN CALL GSFACI(ICOLPL+J-1) ELSEIF(I.EQ.3)THEN CALL GSFACI(ICOLW1+J-1) ELSEIF(I.EQ.4)THEN CALL GSFACI(ICOLW2+J-1) ELSEIF(I.EQ.5)THEN CALL GSFACI(ICOLW3+J-1) ELSEIF(I.EQ.6)THEN CALL GSFACI(ICOLD1+J-1) ELSEIF(I.EQ.7)THEN CALL GSFACI(ICOLD2+J-1) ELSEIF(I.EQ.8)THEN CALL GSFACI(ICOLD3+J-1) ELSEIF(I.EQ.9)THEN CALL GSFACI(ICOLST+J-1) ELSEIF(I.EQ.10)THEN CALL GSFACI(ICOLRB+J-1) ELSE PRINT *,' !!!!!! COLSHM WARNING : Unknown index.' CALL GSFACI(0) ENDIF CALL GFA(5,XPL,YPL) * Next shade. 20 CONTINUE * Draw an overall box around this table. XPL(1)=XMIN YPL(1)=0.1 XPL(2)=XMIN YPL(2)=0.9 XPL(3)=XMAX YPL(3)=0.9 XPL(4)=XMAX YPL(4)=0.1 XPL(5)=XMIN YPL(5)=0.1 CALL GPL(5,XPL,YPL) * Next colour table. 10 CONTINUE *** Next page. CALL GRALOG('Colour shading map:') CALL GRNEXT *** Keep track of CPU time consumption. CALL TIMLOG('Producing a colour shading map: ') END +DECK,COLWGT. SUBROUTINE COLWGT(APLANE,BPLANE,CPLANE,W) *----------------------------------------------------------------------- * COLWGT - Computes an illumination index for a plane with parameters * (APLANE,BPLANE,CPLANE). * (Last changed on 7/10/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PARAMETERS. +SEQ,PRINTPLOT. +SEQ,CONSTANTS. DOUBLE PRECISION APLANE,BPLANE,CPLANE,AP,BP,CP,W,AV,BV,CV,FNORM, - WR,WS,PHI,PHIR,PHIS PARAMETER(PHIR=PI/10,PHIS=PI/3) *** Compute a normalised viewing vector. IF(FPROJN.NE.0)THEN AV=FPROJA/FPROJN BV=FPROJB/FPROJN CV=FPROJC/FPROJN ELSE AV=0 BV=0 CV=1 PRINT *,' !!!!!! COLWGT WARNING : Zero norm view vector'// - ' (program bug) ; set to (0,0,1).' ENDIF *** Compute a normalised plane vector. FNORM=SQRT(APLANE**2+BPLANE**2+CPLANE**2) IF(FNORM.NE.0)THEN AP=APLANE/FNORM BP=BPLANE/FNORM CP=CPLANE/FNORM ELSE AP=0 BP=0 CP=1 PRINT *,' !!!!!! COLWGT WARNING : Zero norm plane vector'// - ' (program bug) ; set to (0,0,1).' ENDIF *** Check that the plane is at all visible. IF(AP*AV+BP*BV+CP*CV.LT.0)THEN W=-1 IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ COLWGT DEBUG :'', - '' Plane '',3F6.2,'' is not visible; W=-1.'')') - AP,BP,CP RETURN ENDIF *** Reflective component, see whether there is reflection at all. FNORM=SQRT((AV+PRAL)**2+(BV+PRBL)**2+(CV+PRCL)**2) IF(FNORM.NE.0)THEN * Angle between optimal reflection normal and normal of the plane. PHI=ACOS(((AV+PRAL)*AP+(BV+PRBL)*BP+(CV+PRCL)*CP)/FNORM) * Weight associated with this angle. WR=EXP(-0.5*(PHI/PHIR)**2) * No reflection possible. ELSE WR=0 IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ COLWGT DEBUG :'', - '' Light and view direction are back to back.'')') ENDIF *** Scattered component. PHI=ACOS(PRAL*AP+PRBL*BP+PRCL*CP) WS=EXP(-0.5*(PHI/PHIS)**2) *** Merge the two weights. W=PRFREF*WR+(1-PRFREF)*(1-PRFABS)*WS IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ COLWGT DEBUG : Wrefl='', - F6.2,'', Wscat='',F6.2,'', W='',F6.2)') WR,WS,W END +DECK,GERHND. SUBROUTINE GERHND(IERR,IFCT,IFIL) *----------------------------------------------------------------------- * GERHND - Routine which is supposed to handle error conditions in * GKS. It outputs an error message to unit 10 and logs. * (Last changed on 19/ 3/92.) *----------------------------------------------------------------------- implicit none INTEGER IERR,IFCT,IFIL IF(IERR.GE.1.AND.IERR.LE.8)THEN WRITE(10,'('' ###### GERHND ERROR : GKS is not in the'', - '' proper state; please report (No '',I1,'').'')') IERR ELSEIF(IERR.EQ.21)THEN WRITE(10,'('' !!!!!! GERHND WARNING : The connection'', - '' identifier you specified is not valid.'')') ELSEIF(IERR.EQ.23)THEN WRITE(10,'('' !!!!!! GERHND WARNING : Workstation type'', - '' is not known to GKS; try using another.'')') ELSEIF(IERR.EQ.38)THEN WRITE(10,'('' !!!!!! GERHND WARNING : Workstation not of'', - '' type INPUT or OUTIN; please report.'')') ELSEIF(IERR.EQ.51)THEN WRITE(10,'('' !!!!!! GERHND WARNING : Rectangle'', - '' is not valid ; please report.'')') ELSEIF(IERR.EQ.78)THEN WRITE(10,'('' ###### GERHND ERROR : Non-positive'', - '' character height requested ; please report.'')') ELSEIF(IERR.EQ.92)THEN WRITE(10,'('' !!!!!! GERHND WARNING : Colour index is'', - '' less than zero ; program bug - please report.'')') ELSEIF(IERR.EQ.93)THEN WRITE(10,'('' !!!!!! GERHND WARNING : Colour index is'', - '' invalid ; program bug - please report.'')') ELSEIF(IERR.EQ.94)THEN WRITE(10,'('' !!!!!! GERHND WARNING : Representation of'', - '' colour index not defined ; please report.'')') ELSEIF(IERR.EQ.95)THEN WRITE(10,'('' ###### GERHND ERROR : Representation of'', - '' colour index not predefined ; please report.'')') ELSEIF(IERR.EQ.96)THEN WRITE(10,'('' !!!!!! GERHND WARNING : Colour intensity'', - '' RBG invalid ; program bug - please report.'')') ELSEIF(IERR.EQ.100)THEN WRITE(10,'('' ###### GERHND ERROR : Invalid number of'', - '' points in an output primitive; please report.'')') ELSEIF(IERR.EQ.101)THEN WRITE(10,'('' !!!!!! GERHND WARNING : Invalid character'', - '' (perhaps a break) in a string ; please ignore.'')') ELSEIF(IERR.EQ.120)THEN WRITE(10,'('' !!!!!! GERHND WARNING : The segment name'', - '' is not valid (program bug - please report).'')') ELSEIF(IERR.EQ.121)THEN WRITE(10,'('' !!!!!! GERHND WARNING : Segment name'', - '' already in use (program bug - please report).'')') ELSEIF(IERR.EQ.122)THEN WRITE(10,'('' !!!!!! GERHND WARNING : The segment does'', - '' not exist (program bug - please report).'')') ELSEIF(IERR.EQ.125)THEN WRITE(10,'('' !!!!!! GERHND WARNING : The segment is'', - '' still open (program bug - please report).'')') ELSEIF(IERR.EQ.144)THEN WRITE(10,'('' !!!!!! GERHND WARNING : The prompt echo'', - '' type is not supported by the workstation.'')') ELSEIF(IERR.EQ.147)THEN WRITE(10,'('' !!!!!! GERHND WARNING : Overflow in the'', - '' input queue; probably of no importance.'')') ELSEIF(IERR.EQ.152)THEN WRITE(10,'('' !!!!!! GERHND WARNING : The initial value'', - '' is out of range; probably of no importance.'')') ELSEIF(IERR.EQ.300)THEN WRITE(10,'('' !!!!!! GERHND WARNING : Unimplemented'', - '' feature used; ignore, normal with mGKS.'')') ELSE WRITE(10,'('' !!!!!! GERHND WARNING : GKS error '',I6, - '' detected; please report.'')') IERR ENDIF IF(IFCT.EQ.0)THEN WRITE(10,'(25X,''Applies to GOPKS (id '',I1,'').'')') IFCT ELSEIF(IFCT.EQ.1)THEN WRITE(10,'(25X,''Applies to GCLKS (id '',I1,'').'')') IFCT ELSEIF(IFCT.EQ.2)THEN WRITE(10,'(25X,''Applies to GOPWK (id '',I1,'').'')') IFCT ELSEIF(IFCT.EQ.3)THEN WRITE(10,'(25X,''Applies to GCLWK (id '',I1,'').'')') IFCT ELSEIF(IFCT.EQ.4)THEN WRITE(10,'(25X,''Applies to GACWK (id '',I1,'').'')') IFCT ELSEIF(IFCT.EQ.5)THEN WRITE(10,'(25X,''Applies to GDAWK (id '',I1,'').'')') IFCT ELSEIF(IFCT.EQ.6)THEN WRITE(10,'(25X,''Applies to GCLRWK (id '',I1,'').'')') IFCT ELSEIF(IFCT.EQ.8)THEN WRITE(10,'(25X,''Applies to GUWK (id '',I1,'').'')') IFCT ELSEIF(IFCT.EQ.12)THEN WRITE(10,'(25X,''Applies to GPL (id '',I2,'').'')') IFCT ELSEIF(IFCT.EQ.13)THEN WRITE(10,'(25X,''Applies to GPM (id '',I2,'').'')') IFCT ELSEIF(IFCT.EQ.14)THEN WRITE(10,'(25X,''Applies to GTX (id '',I2,'').'')') IFCT ELSEIF(IFCT.EQ.15)THEN WRITE(10,'(25X,''Applies to GFA (id '',I2,'').'')') IFCT ELSEIF(IFCT.EQ.19)THEN WRITE(10,'(25X,''Applies to GSLN (id '',I2,'').'')') IFCT ELSEIF(IFCT.EQ.24)THEN WRITE(10,'(25X,''Applies to GSMKSC (id '',I2,'').'')') IFCT ELSEIF(IFCT.EQ.28)THEN WRITE(10,'(25X,''Applies to GSCHXP (id '',I2,'').'')') IFCT ELSEIF(IFCT.EQ.29)THEN WRITE(10,'(25X,''Applies to GSCHSP (id '',I2,'').'')') IFCT ELSEIF(IFCT.EQ.31)THEN WRITE(10,'(25X,''Applies to GSCHH (id '',I2,'').'')') IFCT ELSEIF(IFCT.EQ.33)THEN WRITE(10,'(25X,''Applies to GSTXP (id '',I2,'').'')') IFCT ELSEIF(IFCT.EQ.41)THEN WRITE(10,'(25X,''Applies to GSASF (id '',I2,'').'')') IFCT ELSEIF(IFCT.EQ.48)THEN WRITE(10,'(25X,''Applies to GSCR (id '',I2,'').'')') IFCT ELSEIF(IFCT.EQ.49)THEN WRITE(10,'(25X,''Applies to GSWN (id '',I2,'').'')') IFCT ELSEIF(IFCT.EQ.50)THEN WRITE(10,'(25X,''Applies to GSVP (id '',I2,'').'')') IFCT ELSEIF(IFCT.EQ.56)THEN WRITE(10,'(25X,''Applies to GCRSG (id '',I2,'').'')') IFCT ELSEIF(IFCT.EQ.57)THEN WRITE(10,'(25X,''Applies to GCLSG (id '',I2,'').'')') IFCT ELSEIF(IFCT.EQ.59)THEN WRITE(10,'(25X,''Applies to GDSG (id '',I2,'').'')') IFCT ELSEIF(IFCT.EQ.69)THEN WRITE(10,'(25X,''Applies to GINLC (id '',I2,'').'')') IFCT ELSEIF(IFCT.EQ.70)THEN WRITE(10,'(25X,''Applies to GINSK (id '',I2,'').'')') IFCT ELSEIF(IFCT.EQ.71)THEN WRITE(10,'(25X,''Applies to GINVL (id '',I2,'').'')') IFCT ELSEIF(IFCT.EQ.72)THEN WRITE(10,'(25X,''Applies to GINCH (id '',I2,'').'')') IFCT ELSEIF(IFCT.EQ.73)THEN WRITE(10,'(25X,''Applies to GINPK (id '',I2,'').'')') IFCT ELSEIF(IFCT.EQ.74)THEN WRITE(10,'(25X,''Applies to GINST (id '',I2,'').'')') IFCT ELSEIF(IFCT.EQ.86)THEN WRITE(10,'(25X,''Applies to GRQST (id '',I2,'').'')') IFCT ELSEIF(IFCT.EQ.107)THEN WRITE(10,'(25X,''Applies to GPREC (id '',I3,'').'')') IFCT ELSEIF(IFCT.EQ.525)THEN WRITE(10,'(25X,''Applies to GQCHXP (id '',I3,'').'')') IFCT ELSE WRITE(10,'(25X,''Applies to function '',I4,''.'')') IFCT ENDIF C CALL GERLOG(IERR,IFCT,IFIL) END +DECK,GRACAL. SUBROUTINE GRACAL(INSTR,IFAIL) *----------------------------------------------------------------------- * GRACAL - Handles graphics related calls. * (Last changed on 2/ 8/09.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. +SEQ,ALGDATA. +SEQ,GLOBALS. +SEQ,MATDATA. +SEQ,CONSTANTS. +SEQ,GRAPHICS. CHARACTER*256 XTXT,YTXT,TITLE REAL XPL(MXARG),YPL(MXARG),SIZE,UPX,UPY, - CPX,CPY,XBOX(5),YBOX(5),YSHIFT INTEGER INPCMX,IFAIL,INSTR,IPROC,NARG,IREF(6),ISLOT(6),ISIZ(1), - IFAIL1,IFAIL2,IFAIL3,NC,ILEN,IFORM,MATSLT,NCXTXT,NCYTXT, - NCTIT,I,J,IALHOR,IALVER,IUD,ILR,IVERT,IHOR,ICOL,IPREC,IERR, - IWK EXTERNAL INPCMX,MATSLT *** Indentify the routine if requested. IF(LIDENT)PRINT *,' /// ROUTINE GRACAL ///' *** Set a workstation for box size inquiries. IWK=1 *** Assume the CALL will fail. IFAIL=1 *** Some easy reference variables. NARG=INS(INSTR,3) IPROC=INS(INSTR,1) *** Open a plot frame. IF(IPROC.EQ.-801)THEN * Check number of arguments. IF(NARG.LT.4.OR.NARG.GT.7)THEN PRINT *,' !!!!!! GRACAL WARNING : Incorrect number'// - ' of arguments for PLOT_FRAME.' RETURN * Check argument mode. ELSEIF(MODARG(1).NE.2.OR.MODARG(2).NE.2.OR. - MODARG(3).NE.2.OR.MODARG(4).NE.2.OR. - (NARG.GE.5.AND.MODARG(5).NE.1).OR. - (NARG.GE.6.AND.MODARG(6).NE.1).OR. - (NARG.GE.7.AND.MODARG(7).NE.1))THEN PRINT *,' !!!!!! GRACAL WARNING : Some arguments of'// - ' PLOT_FRAME are of incorrect type.' RETURN ENDIF * Carry out the calculation. IF(NARG.GE.5)THEN CALL STRBUF('READ',NINT(ARG(5)),XTXT,NCXTXT,IFAIL1) IF(NCXTXT.LT.1)THEN XTXT=' ' NCXTXT=1 ENDIF ELSE XTXT='x' NCXTXT=1 IFAIL1=0 ENDIF IF(NARG.GE.6)THEN CALL STRBUF('READ',NINT(ARG(6)),YTXT,NCYTXT,IFAIL2) IF(NCYTXT.LT.1)THEN YTXT=' ' NCYTXT=1 ENDIF ELSE YTXT='y' NCYTXT=1 IFAIL2=0 ENDIF IF(NARG.GE.7)THEN CALL STRBUF('READ',NINT(ARG(7)),TITLE,NCTIT,IFAIL3) IF(NCTIT.LT.1)THEN TITLE=' ' NCTIT=1 ENDIF ELSE TITLE=' ' NCTIT=1 IFAIL3=0 ENDIF CALL GRCART(ARG(1),ARG(2),ARG(3),ARG(4), - XTXT(1:NCXTXT),YTXT(1:NCYTXT),TITLE(1:NCTIT)) * Switch back to normal screen. CALL GRALPH * Error processing. IF(IFAIL1.NE.0.OR.IFAIL2.NE.0.OR.IFAIL3.NE.0) - PRINT *,' !!!!!! GRACAL WARNING : Error'// - ' retrieving a string for PLOT_FRAME.' *** Close a plot frame. ELSEIF(IPROC.EQ.-802)THEN * Check number of arguments. IF(NARG.GT.1)THEN PRINT *,' !!!!!! GRACAL WARNING : Incorrect number'// - ' of arguments for PLOT_END.' RETURN ENDIF * If the last argument is present, fetch it (log record). IF(NARG.GE.1)THEN CALL STRBUF('READ',NINT(ARG(1)),TITLE,NCTIT,IFAIL1) ELSE TITLE='< User plot >' NCTIT=13 ENDIF * Log the plot. IF(NCTIT.GE.1)CALL GRALOG(TITLE(1:NCTIT)) * Switch to graphics. CALL GRGRAF(.FALSE.) * Close graphics. CALL GRNEXT *** Plot a marker. ELSEIF(IPROC.EQ.-803)THEN * Check number of arguments. IF(NARG.EQ.1.OR. - (NARG.NE.2*(NARG/2).AND.MODARG(NARG).NE.1))THEN PRINT *,' !!!!!! GRACAL WARNING : Incorrect set of'// - ' arguments for PLOT_MARKERS.' RETURN ENDIF * Check argument mode. IF(MODARG(1).NE.5)THEN DO 45 I=1,2*(NARG/2) IF(MODARG(I).NE.2)THEN PRINT *,' !!!!!! GRACAL WARNING : Incorrect'// - ' argument type in PLOT_MARKERS call.' RETURN ENDIF 45 CONTINUE ELSEIF(MODARG(2).NE.5)THEN PRINT *,' !!!!!! GRACAL WARNING : Incorrect'// - ' argument type in PLOT_MARKERS call.' RETURN ENDIF * Switch to graphics screen. CALL GRGRAF(.FALSE.) * If there is a 3rd argument, set the polymarker type. IF(NARG.NE.2*(NARG/2))THEN CALL STRBUF('READ',NINT(ARG(NARG)),TITLE,NCTIT,IFAIL1) IF(NCTIT.GE.1)THEN CALL CLTOU(TITLE(1:NCTIT)) CALL GRATTS(TITLE(1:NCTIT),'POLYMARKER') ENDIF ELSE CALL GRATTS('CIRCLE','POLYMARKER') IFAIL1=0 ENDIF * Plot the markers. IF(MODARG(1).NE.5)THEN DO 55 I=1,NARG/2 XPL(I)=ARG(2*I-1) YPL(I)=ARG(2*I) 55 CONTINUE CALL GRMARK(NARG/2,XPL,YPL) ELSE CALL MATMRK(NINT(ARG(1)),NINT(ARG(2)),' ') ENDIF * Switch back to alphanumeric screen. CALL GRALPH * Error processing. IF(IFAIL1.NE.0)PRINT *,' !!!!!! GRACAL WARNING : Error'// - ' retrieving a string for PLOT_MARKERS.' *** Plot a polyline. ELSEIF(IPROC.EQ.-804)THEN * Check number of arguments. IF(NARG.EQ.1.OR. - (NARG.LE.3.AND.(MODARG(1).NE.5.OR.MODARG(2).NE.5)).OR. - (NARG.NE.2*(NARG/2).AND.MODARG(NARG).NE.1))THEN PRINT *,' !!!!!! GRACAL WARNING : Incorrect set of'// - ' arguments for PLOT_LINE.' RETURN ENDIF * Check argument mode. IF(NARG.GE.4)THEN DO 40 I=1,2*(NARG/2) IF(MODARG(I).NE.2)THEN PRINT *,' !!!!!! GRACAL WARNING : Incorrect'// - ' argument type in PLOT_LINE call.' RETURN ENDIF 40 CONTINUE ENDIF * Switch to graphics screen. CALL GRGRAF(.FALSE.) * If there is a 3rd argument, set the polyline type. IF(NARG.NE.2*(NARG/2))THEN CALL STRBUF('READ',NINT(ARG(NARG)),TITLE,NCTIT,IFAIL1) IF(NCTIT.LT.1)THEN TITLE=' ' NCTIT=1 ENDIF CALL CLTOU(TITLE(1:NCTIT)) ELSE TITLE='SOLID' NCTIT=5 IFAIL1=0 ENDIF IF(INDEX(TITLE(1:NCTIT),'SOLID').NE.0)THEN CALL GRATTS('SOLID','POLYLINE') ELSEIF(INDEX(TITLE(1:NCTIT),'COMMENT').NE.0)THEN CALL GRATTS('COMMENT','POLYLINE') ELSEIF(INDEX(TITLE(1:NCTIT),'DASHED').NE.0)THEN CALL GRATTS('DASHED','POLYLINE') ELSEIF(INDEX(TITLE(1:NCTIT),'DOTTED').NE.0)THEN CALL GRATTS('DOTTED','POLYLINE') ELSEIF(INDEX(TITLE(1:NCTIT),'DASH-DOTTED').NE.0)THEN CALL GRATTS('DASH-DOTTED','POLYLINE') ELSEIF(INDEX(TITLE(1:NCTIT),'FUNCTION-1').NE.0)THEN CALL GRATTS('FUNCTION-1','POLYLINE') ELSEIF(INDEX(TITLE(1:NCTIT),'FUNCTION-2').NE.0)THEN CALL GRATTS('FUNCTION-2','POLYLINE') ELSEIF(INDEX(TITLE(1:NCTIT),'FUNCTION-3').NE.0)THEN CALL GRATTS('FUNCTION-3','POLYLINE') ELSEIF(INDEX(TITLE(1:NCTIT),'FUNCTION-4').NE.0)THEN CALL GRATTS('FUNCTION-4','POLYLINE') ELSEIF(INDEX(TITLE(1:NCTIT),'FUNCTION-5').NE.0)THEN CALL GRATTS('FUNCTION-5','POLYLINE') ELSEIF(INDEX(TITLE(1:NCTIT),'FUNCTION-6').NE.0)THEN CALL GRATTS('FUNCTION-6','POLYLINE') ELSEIF(INDEX(TITLE(1:NCTIT),'FUNCTION-7').NE.0)THEN CALL GRATTS('FUNCTION-7','POLYLINE') ELSEIF(INDEX(TITLE(1:NCTIT),'ERROR-BAR').NE.0)THEN CALL GRATTS('ERROR-BAR','POLYLINE') ELSEIF(INDEX(TITLE(1:NCTIT),'BOX-TICKMARKS').NE.0)THEN CALL GRATTS('BOX-TICKMARKS','POLYLINE') ELSE CALL GRATTS('SOLID','POLYLINE') ENDIF * Plot the line segment. IF(NARG.GE.4)THEN DO 50 I=1,NARG/2 XPL(I)=ARG(2*I-1) YPL(I)=ARG(2*I) 50 CONTINUE IF(INDEX(TITLE(1:NCTIT),'SMOOTH').NE.0.AND. - INDEX(TITLE(1:NCTIT),'NOSMOOTH').EQ.0)THEN CALL GRSPLN(NARG/2,XPL,YPL) ELSE CALL GRLINE(NARG/2,XPL,YPL) ENDIF ELSE IF(INDEX(TITLE(1:NCTIT),'SMOOTH').NE.0.AND. - INDEX(TITLE(1:NCTIT),'NOSMOOTH').EQ.0)THEN CALL MATLIN(NINT(ARG(1)),NINT(ARG(2)),'SMOOTH') ELSE CALL MATLIN(NINT(ARG(1)),NINT(ARG(2)),' ') ENDIF ENDIF * Switch back to alphanumeric screen. CALL GRALPH * Error processing. IF(IFAIL1.NE.0)PRINT *,' !!!!!! GRACAL WARNING : Error'// - ' retrieving a string for PLOT_LINE.' *** Plot a string. ELSEIF(IPROC.EQ.-805)THEN * Check number of arguments. IF(NARG.LT.3.OR.NARG.GT.6)THEN PRINT *,' !!!!!! GRACAL WARNING : Incorrect number'// - ' of arguments for PLOT_TEXT.' RETURN * Check argument mode. ELSEIF(MODARG(1).NE.2.OR.MODARG(2).NE.2.OR. - MODARG(3).NE.1.OR. - (NARG.GE.4.AND.MODARG(4).NE.1).OR. - (NARG.GE.5.AND.MODARG(5).NE.1).OR. - (NARG.GE.6.AND.MODARG(6).NE.2))THEN PRINT *,' !!!!!! GRACAL WARNING : Some arguments of'// - ' PLOT_TEXT are of incorrect type.' RETURN ENDIF * Switch to graphics screen. CALL GRGRAF(.FALSE.) * If there is a 4th argument, set the text type. IF(NARG.GE.4)THEN CALL STRBUF('READ',NINT(ARG(4)),TITLE,NCTIT,IFAIL1) IF(NCTIT.GE.1)THEN CALL CLTOU(TITLE(1:NCTIT)) CALL GRATTS(TITLE(1:NCTIT),'TEXT') ENDIF ELSE CALL GRATTS('COMMENT','TEXT') IFAIL1=0 ENDIF * If there is a 5th argument, set the text alignment. IF(NARG.GE.5)THEN CALL STRBUF('READ',NINT(ARG(5)),TITLE,NCTIT,IFAIL2) IF(NCTIT.LT.1)THEN TITLE=' ' NCTIT=1 ENDIF CALL CLTOU(TITLE(1:NCTIT)) IF(INDEX(TITLE(1:NCTIT),'LEFT').NE.0)THEN IALHOR=1 ELSEIF(INDEX(TITLE(1:NCTIT),'CENTER')+ - INDEX(TITLE(1:NCTIT),'CENTRE').NE.0)THEN IALHOR=2 ELSEIF(INDEX(TITLE(1:NCTIT),'RIGHT').NE.0)THEN IALHOR=3 ELSEIF(INDEX(TITLE(1:NCTIT),'NORMAL').NE.0)THEN IALHOR=0 ELSE IALHOR=0 ENDIF IF(INDEX(TITLE(1:NCTIT),'TOP').NE.0)THEN IALVER=1 ELSEIF(INDEX(TITLE(1:NCTIT),'CAP').NE.0)THEN IALVER=2 ELSEIF(INDEX(TITLE(1:NCTIT),'HALF').NE.0)THEN IALVER=3 ELSEIF(INDEX(TITLE(1:NCTIT),'BASE').NE.0)THEN IALVER=4 ELSEIF(INDEX(TITLE(1:NCTIT),'BOTTOM').NE.0)THEN IALVER=5 ELSEIF(INDEX(TITLE(1:NCTIT),'NORMAL').NE.0)THEN IALVER=0 ELSE IALVER=0 ENDIF CALL GSTXAL(IALHOR,IALVER) ELSE CALL GSTXAL(0,0) IFAIL2=0 ENDIF * If there is a 6th argument, set the text orientation. IF(NARG.GE.5)THEN UPX=COS(PI*(ARG(6)+90.0)/180.0) UPY=SIN(PI*(ARG(6)+90.0)/180.0) CALL GSCHUP(UPX,UPY) ELSE CALL GSCHUP(0.0,1.0) ENDIF * Plot the string. CALL STRBUF('READ',NINT(ARG(3)),TITLE,NCTIT,IFAIL3) IF(NCTIT.GE.1)CALL GRTEXT(ARG(1),ARG(2),TITLE(1:NCTIT)) * Switch back to alphanumeric screen. CALL GRALPH * Error processing. IF(IFAIL1.NE.0.OR.IFAIL2.NE.0.OR.IFAIL3.NE.0) - PRINT *,' !!!!!! GRACAL WARNING : Error'// - ' retrieving a string for PLOT_TEXT.' *** Plot a comment string. ELSEIF(IPROC.EQ.-806)THEN * Check number of arguments and argument type. IF(NARG.NE.2.OR.MODARG(1).NE.1.OR.MODARG(2).NE.1)THEN PRINT *,' !!!!!! GRACAL WARNING : Incorrect set of'// - ' arguments for PLOT_COMMENT.' RETURN ENDIF * Figure out where the comment should be placed. CALL STRBUF('READ',NINT(ARG(1)),TITLE,NCTIT,IFAIL1) IF(NCTIT.LT.1)THEN TITLE=' ' NCTIT=1 ENDIF CALL CLTOU(TITLE(1:NCTIT)) IF(INDEX(TITLE(1:NCTIT),'UP')+ - INDEX(TITLE(1:NCTIT),'HIGH').NE.0)THEN IUD=1 ELSEIF(INDEX(TITLE(1:NCTIT),'DOWN')+ - INDEX(TITLE(1:NCTIT),'LOW').NE.0)THEN IUD=2 ELSE PRINT *,' !!!!!! GRACAL WARNING : Up/down'// - ' location missing; comment not plotted.' RETURN ENDIF IF(INDEX(TITLE(1:NCTIT),'LEFT').NE.0)THEN ILR=0 ELSEIF(INDEX(TITLE(1:NCTIT),'RIGHT').NE.0)THEN ILR=2 ELSE PRINT *,' !!!!!! GRACAL WARNING : Left/right'// - ' location missing; comment not plotted.' RETURN ENDIF * Fetch the string to be plotted. CALL STRBUF('READ',NINT(ARG(2)),TITLE,NCTIT,IFAIL2) * Switch to graphics screen. CALL GRGRAF(.FALSE.) * Plot the comment. IF(NCTIT.GE.1)CALL GRCOMM(IUD+ILR,TITLE(1:NCTIT)) * Switch back to alphanumeric screen. CALL GRALPH * Error processing. IF(IFAIL1.NE.0.OR.IFAIL2.NE.0) - PRINT *,' !!!!!! GRACAL WARNING : Error'// - ' retrieving a string for PLOT_COMMENT.' *** Plot an area. ELSEIF(IPROC.EQ.-807)THEN * Check number of arguments. IF(NARG.EQ.1.OR. - (NARG.LE.3.AND.(MODARG(1).NE.5.OR.MODARG(2).NE.5)).OR. - (NARG.NE.2*(NARG/2).AND.MODARG(NARG).NE.1))THEN PRINT *,' !!!!!! GRACAL WARNING : Incorrect set of'// - ' arguments for PLOT_AREA.' RETURN ENDIF * Check argument mode. IF(NARG.GE.4)THEN DO 60 I=1,2*(NARG/2) IF(MODARG(I).NE.2)THEN PRINT *,' !!!!!! GRACAL WARNING : Incorrect'// - ' argument type in a PLOT_AREA call.' RETURN ENDIF 60 CONTINUE IF(NARG.LT.6)THEN PRINT *,' !!!!!! GRACAL WARNING : Insufficient'// - ' number of points in a PLOT_AREA call.' RETURN ENDIF ENDIF * Switch to graphics screen. CALL GRGRAF(.FALSE.) * If there is a 3rd argument, set the area type. IF(NARG.NE.2*(NARG/2))THEN CALL STRBUF('READ',NINT(ARG(NARG)),TITLE,NCTIT,IFAIL1) IF(NCTIT.LT.1)THEN TITLE=' ' NCTIT=1 ENDIF CALL CLTOU(TITLE(1:NCTIT)) ELSE TITLE='FUNCTION-1' NCTIT=10 IFAIL1=0 ENDIF CALL GRATTS(TITLE(1:NCTIT),'AREA') * Plot the area. IF(NARG.GE.4)THEN DO 70 I=1,NARG/2 XPL(I)=ARG(2*I-1) YPL(I)=ARG(2*I) 70 CONTINUE CALL GRAREA(NARG/2,XPL,YPL) ELSE CALL MATFAR(NINT(ARG(1)),NINT(ARG(2)),' ') ENDIF * Switch back to alphanumeric screen. CALL GRALPH * Error processing. IF(IFAIL1.NE.0)PRINT *,' !!!!!! GRACAL WARNING : Error'// - ' retrieving a string for PLOT_AREA.' *** Plot a graph. ELSEIF(IPROC.EQ.-808)THEN * Check number of arguments. IF(NARG.LT.2.OR.NARG.GT.5)THEN PRINT *,' !!!!!! GRACAL WARNING : Incorrect number'// - ' of arguments for PLOT_GRAPH.' RETURN * Check argument mode. ELSEIF(MODARG(1).NE.5.OR.MODARG(2).NE.5.OR. - (NARG.GE.3.AND.MODARG(3).NE.1).OR. - (NARG.GE.4.AND.MODARG(4).NE.1).OR. - (NARG.GE.5.AND.MODARG(5).NE.1))THEN PRINT *,' !!!!!! GRACAL WARNING : Some arguments of'// - ' PLOT_GRAPH are of incorrect type.' RETURN ENDIF * Fetch the x-axis label. IF(NARG.GE.3)THEN CALL STRBUF('READ',NINT(ARG(3)),XTXT,NCXTXT,IFAIL1) IF(NCXTXT.LT.1)THEN XTXT=' ' NCXTXT=1 ENDIF ELSE DO 71 J=1,NGLB IF(GLBMOD(J).NE.5)GOTO 71 IF(NINT(GLBVAL(J)).EQ.NINT(ARG(1)))THEN XTXT=GLBVAR(J) NCXTXT=10 GOTO 72 ENDIF 71 CONTINUE XTXT='x-axis' NCXTXT=6 72 CONTINUE IFAIL1=0 ENDIF * Fetch the y-axis label. IF(NARG.GE.4)THEN CALL STRBUF('READ',NINT(ARG(4)),YTXT,NCYTXT,IFAIL2) IF(NCYTXT.LT.1)THEN YTXT=' ' NCYTXT=1 ENDIF ELSE DO 73 J=1,NGLB IF(GLBMOD(J).NE.5)GOTO 73 IF(NINT(GLBVAL(J)).EQ.NINT(ARG(2)))THEN YTXT=GLBVAR(J) NCYTXT=10 GOTO 74 ENDIF 73 CONTINUE YTXT='y-axis' NCYTXT=6 74 CONTINUE IFAIL2=0 ENDIF * Fetch the global title. IF(NARG.GE.5)THEN CALL STRBUF('READ',NINT(ARG(5)),TITLE,NCTIT,IFAIL3) IF(NCTIT.LT.1)THEN TITLE=' ' NCTIT=1 ENDIF ELSEIF(XTXT.NE.'x-axis'.AND.XTXT.NE.' '.AND. - YTXT.NE.'y-axis'.AND.YTXT.NE.' '.AND. - NARG.LT.3)THEN TITLE=XTXT(1:NCXTXT)//' vs '//YTXT(1:NCYTXT) NCTIT=MIN(LEN(TITLE),NCXTXT+4+NCYTXT) ELSE TITLE=' ' NCTIT=1 IFAIL3=0 ENDIF * Plot the graph. CALL MATGRA(NINT(ARG(1)),NINT(ARG(2)), - XTXT(1:NCXTXT),YTXT(1:NCYTXT),TITLE(1:NCTIT)) * Switch back to normal screen. CALL GRALPH * Error processing. IF(IFAIL1.NE.0.OR.IFAIL2.NE.0.OR.IFAIL3.NE.0) - PRINT *,' !!!!!! GRACAL WARNING : Error'// - ' retrieving a string for PLOT_GRAPH.' *** Plotting error bars. ELSEIF(IPROC.EQ.-809)THEN * Identify provisionally the chosen format. IF(NARG.GE.7.OR.(NARG.EQ.6.AND.MODARG(5).NE.1))THEN IFORM=3 ELSEIF(NARG.GE.5.OR.(NARG.EQ.4.AND.MODARG(3).NE.1))THEN IFORM=2 ELSEIF(NARG.GE.2)THEN IFORM=1 ELSE PRINT *,' !!!!!! GRACAL WARNING : Not a recognised'// - ' format of PLOT_ERROR_BARS; no error bars.' RETURN ENDIF * Verify the types for each format. IF((MODARG(1).NE.2.AND.MODARG(1).NE.5).OR. - (MODARG(2).NE.2.AND.MODARG(2).NE.5))THEN PRINT *,' !!!!!! GRACAL WARNING : PLOT_ERROR_BARS'// - ' needs at least an (x,y) pair; no error bars.' RETURN ELSEIF(IFORM.EQ.1.AND.( - NARG.GT.4.OR. - (NARG.GE.3.AND.MODARG(3).NE.1).OR. - (NARG.GE.4.AND.MODARG(4).NE.2)))THEN PRINT *,' !!!!!! GRACAL WARNING : Incorrect option'// - ' list for PLOT_ERROR_BARS; no error bars.' RETURN ELSEIF(IFORM.GT.1.AND.( - (MODARG(3).NE.2.AND.MODARG(3).NE.5).OR. - (MODARG(4).NE.2.AND.MODARG(4).NE.5)))THEN PRINT *,' !!!!!! GRACAL WARNING : Incorrect set of'// - ' (ex-,ey-) in PLOT_ERROR_BARS; no error bars.' RETURN ELSEIF(IFORM.EQ.2.AND.( - NARG.GT.6.OR. - (NARG.GE.5.AND.MODARG(5).NE.1).OR. - (NARG.GE.6.AND.MODARG(6).NE.2)))THEN PRINT *,' !!!!!! GRACAL WARNING : Incorrect option'// - ' list for PLOT_ERROR_BARS; no error bars.' RETURN ELSEIF(IFORM.GT.2.AND.( - (MODARG(5).NE.2.AND.MODARG(5).NE.5).OR. - (MODARG(6).NE.2.AND.MODARG(6).NE.5)))THEN PRINT *,' !!!!!! GRACAL WARNING : Incorrect set of'// - ' (ex+,ey+) in PLOT_ERROR_BARS; no error bars.' RETURN ELSEIF(IFORM.EQ.3.AND.( - NARG.GT.8.OR. - (NARG.GE.7.AND.MODARG(7).NE.1).OR. - (NARG.GE.8.AND.MODARG(8).NE.2)))THEN PRINT *,' !!!!!! GRACAL WARNING : Incorrect option'// - ' list for PLOT_ERROR_BARS; no error bars.' RETURN ENDIF * Fetch the option string, if present. IF(IFORM.EQ.1.AND.NARG.GE.3.AND.MODARG(3).EQ.1)THEN CALL STRBUF('READ',NINT(ARG(3)),TITLE,NC,IFAIL1) IF(NC.LT.1)THEN TITLE=' ' NC=1 ENDIF CALL CLTOU(TITLE(1:NC)) ELSEIF(IFORM.EQ.2.AND.NARG.GE.5.AND.MODARG(5).EQ.1)THEN CALL STRBUF('READ',NINT(ARG(5)),TITLE,NC,IFAIL1) IF(NC.LT.1)THEN TITLE=' ' NC=1 ENDIF CALL CLTOU(TITLE(1:NC)) ELSEIF(IFORM.EQ.3.AND.NARG.GE.7.AND.MODARG(7).EQ.1)THEN CALL STRBUF('READ',NINT(ARG(7)),TITLE,NC,IFAIL1) IF(NC.LT.1)THEN TITLE=' ' NC=1 ENDIF CALL CLTOU(TITLE(1:NC)) ELSE TITLE='CIRCLE' NC=6 IFAIL1=0 ENDIF * Fetch the character size if present. IF(IFORM.EQ.1.AND.NARG.GE.4.AND.MODARG(4).EQ.2)THEN SIZE=ARG(4) ELSEIF(IFORM.EQ.2.AND.NARG.GE.6.AND.MODARG(6).EQ.2)THEN SIZE=ARG(6) ELSEIF(IFORM.EQ.3.AND.NARG.GE.8.AND.MODARG(8).EQ.2)THEN SIZE=ARG(8) ELSE SIZE=0.01 ENDIF * Locate the arrays, get hold of and check dimensions. ILEN=0 DO 301 I=1,NARG IF(MODARG(I).EQ.5)THEN IREF(I)=NINT(ARG(I)) ISLOT(I)=MATSLT(IREF(I)) IF(ISLOT(I).NE.0)THEN IF(MDIM(ISLOT(I)).NE.1)PRINT *,' ------ GRACAL'// - ' MESSAGE : Non 1-dimensional vector'// - ' found; unraveled.' IF(ILEN.EQ.0)THEN ILEN=MLEN(ISLOT(I)) ELSEIF(ILEN.NE.MLEN(ISLOT(I)))THEN PRINT *,' !!!!!! GRACAL WARNING : Vectors'// - ' have different lengths; no error bars.' RETURN ENDIF ELSE PRINT *,' !!!!!! GRACAL WARNING : Vector'// - ' not found; no error bars.' RETURN ENDIF ENDIF 301 CONTINUE * If none are arrays, then assign a size of 1. IF(ILEN.EQ.0)THEN ISIZ(1)=1 ELSE ISIZ(1)=ILEN ENDIF * Expand those numbers that are not matrices. DO 302 I=1,6 IF((I.EQ.5.OR.I.EQ.6).AND.(IFORM.EQ.1.OR.IFORM.EQ.2))THEN IREF(I)=IREF(I-2) ELSEIF((I.EQ.3.OR.I.EQ.4).AND.IFORM.EQ.1)THEN CALL MATADM('ALLOCATE',IREF(I),1,ISIZ,2,IFAIL2) IF(IFAIL2.NE.0)THEN PRINT *,' !!!!!! GRACAL WARNING : Unable to'// - ' create a null-vector; no error bars.' RETURN ENDIF ISLOT(I)=MATSLT(IREF(I)) IF(ISLOT(I).LE.0)THEN PRINT *,' !!!!!! GRACAL WARNING : Unable to'// - ' locate a null-vector; no error bars.' RETURN ENDIF DO 303 J=1,ISIZ(1) MVEC(MORG(ISLOT(I))+J)=0 303 CONTINUE ELSEIF(MODARG(I).EQ.2)THEN CALL MATADM('ALLOCATE',IREF(I),1,ISIZ,2,IFAIL2) IF(IFAIL2.NE.0)THEN PRINT *,' !!!!!! GRACAL WARNING : Unable to'// - ' expand a number; no error bars.' RETURN ENDIF ISLOT(I)=MATSLT(IREF(I)) IF(ISLOT(I).LE.0)THEN PRINT *,' !!!!!! GRACAL WARNING : Unable to'// - ' locate an expanded number; no error bars.' RETURN ENDIF DO 305 J=1,ISIZ(1) MVEC(MORG(ISLOT(I))+J)=ARG(I) 305 CONTINUE ENDIF 302 CONTINUE * Switch to graphics screen. CALL GRGRAF(.FALSE.) * Plot the error bars. CALL MATERR(IREF(1),IREF(2),IREF(3), - IREF(4),IREF(5),IREF(6),TITLE(1:NC),SIZE) * Switch to alpha screen. CALL GRALPH * Get rid of temporary arrays. DO 304 I=1,6 IF((I.EQ.1.OR.I.EQ.2).AND.MODARG(I).EQ.2)THEN CALL MATADM('DELETE',IREF(I),1,ISIZ,2,IFAIL3) ELSEIF((I.EQ.3.OR.I.EQ.4).AND.( - IFORM.EQ.1.OR. - (MODARG(I).EQ.2.AND.IFORM.GT.1)))THEN CALL MATADM('DELETE',IREF(I),1,ISIZ,2,IFAIL3) ELSEIF((I.EQ.5.OR.I.EQ.6).AND. - (MODARG(I).EQ.2.AND.IFORM.GT.2))THEN CALL MATADM('DELETE',IREF(I),1,ISIZ,2,IFAIL3) ENDIF 304 CONTINUE *** Plotting oblique error bars. ELSEIF(IPROC.EQ.-831)THEN * Identify provisionally the chosen format. IF(NARG.GE.7.OR.(NARG.EQ.6.AND.MODARG(5).NE.1))THEN IFORM=3 ELSEIF(NARG.GE.5.OR.(NARG.EQ.4.AND.MODARG(3).NE.1))THEN IFORM=2 ELSEIF(NARG.GE.2)THEN IFORM=1 ELSE PRINT *,' !!!!!! GRACAL WARNING : Not a recognised'// - ' format of PLOT_ERROR_BARS; no error bars.' RETURN ENDIF * Verify the types for each format. IF((MODARG(1).NE.2.AND.MODARG(1).NE.5).OR. - (MODARG(2).NE.2.AND.MODARG(2).NE.5))THEN PRINT *,' !!!!!! GRACAL WARNING : PLOT_ERROR_BARS'// - ' needs at least an (x,y) pair; no error bars.' RETURN ELSEIF(IFORM.EQ.1.AND.( - NARG.GT.4.OR. - (NARG.GE.3.AND.MODARG(3).NE.1).OR. - (NARG.GE.4.AND.MODARG(4).NE.2)))THEN PRINT *,' !!!!!! GRACAL WARNING : Incorrect option'// - ' list for PLOT_ERROR_BARS; no error bars.' RETURN ELSEIF(IFORM.GT.1.AND.( - (MODARG(3).NE.2.AND.MODARG(3).NE.5).OR. - (MODARG(4).NE.2.AND.MODARG(4).NE.5)))THEN PRINT *,' !!!!!! GRACAL WARNING : Incorrect set of'// - ' (ex-,ey-) in PLOT_ERROR_BARS; no error bars.' RETURN ELSEIF(IFORM.EQ.2.AND.( - NARG.GT.6.OR. - (NARG.GE.5.AND.MODARG(5).NE.1).OR. - (NARG.GE.6.AND.MODARG(6).NE.2)))THEN PRINT *,' !!!!!! GRACAL WARNING : Incorrect option'// - ' list for PLOT_ERROR_BARS; no error bars.' RETURN ELSEIF(IFORM.GT.2.AND.( - (MODARG(5).NE.2.AND.MODARG(5).NE.5).OR. - (MODARG(6).NE.2.AND.MODARG(6).NE.5)))THEN PRINT *,' !!!!!! GRACAL WARNING : Incorrect set of'// - ' (ex+,ey+) in PLOT_ERROR_BARS; no error bars.' RETURN ELSEIF(IFORM.EQ.3.AND.( - NARG.GT.8.OR. - (NARG.GE.7.AND.MODARG(7).NE.1).OR. - (NARG.GE.8.AND.MODARG(8).NE.2)))THEN PRINT *,' !!!!!! GRACAL WARNING : Incorrect option'// - ' list for PLOT_ERROR_BARS; no error bars.' RETURN ENDIF * Fetch the option string, if present. IF(IFORM.EQ.1.AND.NARG.GE.3.AND.MODARG(3).EQ.1)THEN CALL STRBUF('READ',NINT(ARG(3)),TITLE,NC,IFAIL1) IF(NC.LT.1)THEN TITLE=' ' NC=1 ENDIF CALL CLTOU(TITLE(1:NC)) ELSEIF(IFORM.EQ.2.AND.NARG.GE.5.AND.MODARG(5).EQ.1)THEN CALL STRBUF('READ',NINT(ARG(5)),TITLE,NC,IFAIL1) IF(NC.LT.1)THEN TITLE=' ' NC=1 ENDIF CALL CLTOU(TITLE(1:NC)) ELSEIF(IFORM.EQ.3.AND.NARG.GE.7.AND.MODARG(7).EQ.1)THEN CALL STRBUF('READ',NINT(ARG(7)),TITLE,NC,IFAIL1) IF(NC.LT.1)THEN TITLE=' ' NC=1 ENDIF CALL CLTOU(TITLE(1:NC)) ELSE TITLE='CIRCLE' NC=6 IFAIL1=0 ENDIF * Fetch the character size if present. IF(IFORM.EQ.1.AND.NARG.GE.4.AND.MODARG(4).EQ.2)THEN SIZE=ARG(4) ELSEIF(IFORM.EQ.2.AND.NARG.GE.6.AND.MODARG(6).EQ.2)THEN SIZE=ARG(6) ELSEIF(IFORM.EQ.3.AND.NARG.GE.8.AND.MODARG(8).EQ.2)THEN SIZE=ARG(8) ELSE SIZE=0.01 ENDIF * Locate the arrays, get hold of and check dimensions. ILEN=0 DO 306 I=1,NARG IF(MODARG(I).EQ.5)THEN IREF(I)=NINT(ARG(I)) ISLOT(I)=MATSLT(IREF(I)) IF(ISLOT(I).NE.0)THEN IF(MDIM(ISLOT(I)).NE.1)PRINT *,' ------ GRACAL'// - ' MESSAGE : Non 1-dimensional vector'// - ' found; unraveled.' IF(ILEN.EQ.0)THEN ILEN=MLEN(ISLOT(I)) ELSEIF(ILEN.NE.MLEN(ISLOT(I)))THEN PRINT *,' !!!!!! GRACAL WARNING : Vectors'// - ' have different lengths; no error bars.' RETURN ENDIF ELSE PRINT *,' !!!!!! GRACAL WARNING : Vector'// - ' not found; no error bars.' RETURN ENDIF ENDIF 306 CONTINUE * If none are arrays, then assign a size of 1. IF(ILEN.EQ.0)THEN ISIZ(1)=1 ELSE ISIZ(1)=ILEN ENDIF * Expand those numbers that are not matrices. DO 307 I=1,6 IF((I.EQ.5.OR.I.EQ.6).AND.(IFORM.EQ.1.OR.IFORM.EQ.2))THEN IREF(I)=IREF(I-2) ELSEIF((I.EQ.3.OR.I.EQ.4).AND.IFORM.EQ.1)THEN CALL MATADM('ALLOCATE',IREF(I),1,ISIZ,2,IFAIL2) IF(IFAIL2.NE.0)THEN PRINT *,' !!!!!! GRACAL WARNING : Unable to'// - ' create a null-vector; no error bars.' RETURN ENDIF ISLOT(I)=MATSLT(IREF(I)) IF(ISLOT(I).LE.0)THEN PRINT *,' !!!!!! GRACAL WARNING : Unable to'// - ' locate a null-vector; no error bars.' RETURN ENDIF DO 308 J=1,ISIZ(1) MVEC(MORG(ISLOT(I))+J)=0 308 CONTINUE ELSEIF(MODARG(I).EQ.2)THEN CALL MATADM('ALLOCATE',IREF(I),1,ISIZ,2,IFAIL2) IF(IFAIL2.NE.0)THEN PRINT *,' !!!!!! GRACAL WARNING : Unable to'// - ' expand a number; no error bars.' RETURN ENDIF ISLOT(I)=MATSLT(IREF(I)) IF(ISLOT(I).LE.0)THEN PRINT *,' !!!!!! GRACAL WARNING : Unable to'// - ' locate an expanded number; no error bars.' RETURN ENDIF DO 309 J=1,ISIZ(1) MVEC(MORG(ISLOT(I))+J)=ARG(I) 309 CONTINUE ENDIF 307 CONTINUE * Switch to graphics screen. CALL GRGRAF(.FALSE.) * Plot the error bars. CALL MATOBL(IREF(1),IREF(2),IREF(3), - IREF(4),IREF(5),IREF(6),TITLE(1:NC),SIZE) * Switch to alpha screen. CALL GRALPH * Get rid of temporary arrays. DO 310 I=1,6 IF((I.EQ.1.OR.I.EQ.2).AND.MODARG(I).EQ.2)THEN CALL MATADM('DELETE',IREF(I),1,ISIZ,2,IFAIL3) ELSEIF((I.EQ.3.OR.I.EQ.4).AND.( - IFORM.EQ.1.OR. - (MODARG(I).EQ.2.AND.IFORM.GT.1)))THEN CALL MATADM('DELETE',IREF(I),1,ISIZ,2,IFAIL3) ELSEIF((I.EQ.5.OR.I.EQ.6).AND. - (MODARG(I).EQ.2.AND.IFORM.GT.2))THEN CALL MATADM('DELETE',IREF(I),1,ISIZ,2,IFAIL3) ENDIF 310 CONTINUE *** Project a line. ELSEIF(IPROC.EQ.-810)THEN * Check number of arguments. IF(NARG.LT.1.OR.NARG.GT.4.OR. - MODARG(1).NE.5.OR.MODARG(2).NE.5.OR.MODARG(2).NE.5.OR. - (NARG.GE.4.AND.MODARG(4).NE.1))THEN PRINT *,' !!!!!! GRACAL WARNING : Incorrect set of'// - ' arguments for PROJECT_LINE.' RETURN ENDIF * Switch to graphics screen. CALL GRGRAF(.FALSE.) * If there is a 3rd argument, set the polyline type. IF(NARG.GE.4)THEN CALL STRBUF('READ',NINT(ARG(4)),TITLE,NCTIT,IFAIL1) IF(NCTIT.LT.1)THEN TITLE=' ' NCTIT=1 ENDIF CALL CLTOU(TITLE(1:NCTIT)) ELSE TITLE='SOLID' NCTIT=5 IFAIL1=0 ENDIF CALL GRATTS(TITLE(1:NCTIT),'POLYLINE') * Plot the line segment. CALL MATPLN(NINT(ARG(1)),NINT(ARG(2)),NINT(ARG(3))) * Switch back to alphanumeric screen. CALL GRALPH * Error processing. IF(IFAIL1.NE.0)PRINT *,' !!!!!! GRACAL WARNING : Error'// - ' retrieving a string for PROJECT_LINE.' *** Project a set of markers. ELSEIF(IPROC.EQ.-811)THEN * If there is a 4th argument, set the polymarker type. IF(NARG.GE.4)THEN CALL STRBUF('READ',NINT(ARG(4)),TITLE,NCTIT,IFAIL1) IF(NCTIT.LT.1)THEN TITLE=' ' NCTIT=1 ENDIF CALL CLTOU(TITLE(1:NCTIT)) ELSE TITLE='CROSS' NCTIT=5 IFAIL1=0 ENDIF CALL GRATTS(TITLE(1:NCTIT),'POLYMARKER') IF(IFAIL1.NE.0)PRINT *,' !!!!!! GRACAL WARNING : Error'// - ' retrieving a string for PLOT_MARKERS.' * Vector type arguments. IF((NARG.EQ.3.OR.NARG.EQ.4).AND. - MODARG(1).EQ.5.AND.MODARG(2).EQ.5.AND. - MODARG(2).EQ.5.AND. - (NARG.EQ.3.OR.MODARG(4).EQ.1))THEN * Switch to graphics screen. CALL GRGRAF(.FALSE.) * Plot the markers. CALL MATPMK(NINT(ARG(1)),NINT(ARG(2)),NINT(ARG(3))) * Switch back to alphanumeric screen. CALL GRALPH * Scalar arguments. ELSEIF((NARG.EQ.3.OR.NARG.EQ.4).AND. - MODARG(1).EQ.2.AND.MODARG(2).EQ.2.AND. - MODARG(2).EQ.2.AND. - (NARG.EQ.3.OR.MODARG(4).EQ.1))THEN * Switch to graphics screen. CALL GRGRAF(.FALSE.) * Plot the markers. CALL PLAGPM(1,DBLE(ARG(1)),DBLE(ARG(2)),DBLE(ARG(3))) * Switch back to alphanumeric screen. CALL GRALPH * Other argument types. ELSE PRINT *,' !!!!!! GRACAL WARNING : Incorrect set of'// - ' arguments for PROJECT_MARKERS.' RETURN ENDIF *** Open a plot, doing nothing else. ELSEIF(IPROC.EQ.-812)THEN IF(NARG.NE.0)THEN PRINT *,' !!!!!! GRACAL WARNING : Incorrect number'// - ' of arguments for PLOT_START.' RETURN ENDIF CALL GRGRAF(.TRUE.) * Reset the bar chart and histogram counters. IGBAR=0 IGHIST=0 *** Set a window. ELSEIF(IPROC.EQ.-813)THEN * Check the arguments. IF(NARG.NE.5.OR. - MODARG(1).NE.2.OR.MODARG(2).NE.2.OR.MODARG(3).NE.2.OR. - MODARG(4).NE.2.OR.MODARG(5).NE.2)THEN PRINT *,' !!!!!! GRACAL WARNING : Incorrect argument'// - ' list for GKS_WINDOW; not executed.' RETURN ELSE * Set the window. CALL GSWN(NINT(ARG(1)),ARG(2),ARG(3),ARG(4),ARG(5)) * Make sure lines will not be cut. FRXMIN=ARG(2) FRXMAX=ARG(3) FRYMIN=ARG(4) FRYMAX=ARG(5) ENDIF *** Set a viewport. ELSEIF(IPROC.EQ.-814)THEN IF(NARG.NE.5.OR. - MODARG(1).NE.2.OR.MODARG(2).NE.2.OR.MODARG(3).NE.2.OR. - MODARG(4).NE.2.OR.MODARG(5).NE.2)THEN PRINT *,' !!!!!! GRACAL WARNING : Incorrect argument'// - ' list for GKS_VIEWPORT; not executed.' RETURN ELSE CALL GSVP(NINT(ARG(1)),ARG(2),ARG(3),ARG(4),ARG(5)) ENDIF *** Select a normalisation transformation. ELSEIF(IPROC.EQ.-815)THEN IF(NARG.NE.1.OR.MODARG(1).NE.2)THEN PRINT *,' !!!!!! GRACAL WARNING : Incorrect argument'// - ' list for GKS_SELECT_NT; not executed.' RETURN ELSE CALL GSELNT(NINT(ARG(1))) ENDIF *** Plot a polyline. ELSEIF(IPROC.EQ.-816)THEN * Check number of arguments. IF(NARG.NE.2.OR.MODARG(1).NE.5.OR.MODARG(2).NE.5)THEN PRINT *,' !!!!!! GRACAL WARNING : Incorrect set of'// - ' arguments for GKS_POLYLINE.' RETURN ENDIF * Switch to graphics screen. CALL GRGRAF(.FALSE.) * Plot the line. CALL MATLIN(NINT(ARG(1)),NINT(ARG(2)),'GKS') * Switch back to alphanumeric screen. CALL GRALPH *** Plot polymarkers. ELSEIF(IPROC.EQ.-817)THEN * Check number of arguments. IF(NARG.NE.2.OR.MODARG(1).NE.5.OR.MODARG(2).NE.5)THEN PRINT *,' !!!!!! GRACAL WARNING : Incorrect set of'// - ' arguments for GKS_POLYMARKER.' RETURN ENDIF * Switch to graphics screen. CALL GRGRAF(.FALSE.) * Plot the line. CALL MATMRK(NINT(ARG(1)),NINT(ARG(2)),'GKS') * Switch back to alphanumeric screen. CALL GRALPH *** Set attributes. ELSEIF(IPROC.EQ.-818.OR.IPROC.EQ.-819.OR. - IPROC.EQ.-820.OR.IPROC.EQ.-821)THEN * Check argument types. IF(NARG.NE.1.OR.MODARG(1).NE.1)THEN PRINT *,' !!!!!! GRACAL WARNING : Incorrect argument'// - ' received by SET_x_ATTRIBUTES.' RETURN ENDIF * Pick up the representation. CALL STRBUF('READ',NINT(ARG(1)),TITLE,NCTIT,IFAIL1) IF(IFAIL1.NE.0.OR.NCTIT.LE.0)THEN PRINT *,' !!!!!! GRACAL WARNING : Unable to retrieve'// - ' the representation name.' RETURN ENDIF CALL CLTOU(TITLE(1:NCTIT)) * Set the representation. IF(IPROC.EQ.-818)THEN CALL GRATTS(TITLE(1:NCTIT),'POLYLINE') ELSEIF(IPROC.EQ.-819)THEN CALL GRATTS(TITLE(1:NCTIT),'POLYMARKER') ELSEIF(IPROC.EQ.-820)THEN CALL GRATTS(TITLE(1:NCTIT),'TEXT') ELSEIF(IPROC.EQ.-821)THEN CALL GRATTS(TITLE(1:NCTIT),'AREA') ENDIF *** Plot a text string. ELSEIF(IPROC.EQ.-822)THEN * Check number of arguments. IF(NARG.NE.3.OR.MODARG(1).NE.2.OR.MODARG(2).NE.2.OR. - MODARG(3).NE.1)THEN PRINT *,' !!!!!! GRACAL WARNING : Incorrect set of'// - ' arguments for GKS_TEXT.' RETURN ENDIF * Pick up the representation. CALL STRBUF('READ',NINT(ARG(3)),TITLE,NCTIT,IFAIL1) IF(IFAIL1.NE.0.OR.NCTIT.LE.0)THEN PRINT *,' !!!!!! GRACAL WARNING : Unable to retrieve'// - ' the text string.' RETURN ENDIF * Switch to graphics screen. CALL GRGRAF(.FALSE.) * Plot the text. CALL GTX(ARG(1),ARG(2),TITLE(1:NCTIT)) * Switch back to alphanumeric screen. CALL GRALPH *** Plot an area. ELSEIF(IPROC.EQ.-823)THEN * Check number of arguments. IF(NARG.NE.2.OR.MODARG(1).NE.5.OR.MODARG(2).NE.5)THEN PRINT *,' !!!!!! GRACAL WARNING : Incorrect set of'// - ' arguments for GKS_AREA.' RETURN ENDIF * Switch to graphics screen. CALL GRGRAF(.FALSE.) * Plot the line. CALL MATFAR(NINT(ARG(1)),NINT(ARG(2)),'GKS') * Switch back to alphanumeric screen. CALL GRALPH *** Set the text alignment. ELSEIF(IPROC.EQ.-824)THEN IF(NARG.NE.2.OR.MODARG(1).NE.1.OR.MODARG(2).NE.1)THEN PRINT *,' !!!!!! GRACAL WARNING : Incorrect set of'// - ' arguments for GKS_SET_TEXT_ALIGNMENT.' RETURN ENDIF * Fetch the horizontal alignment. CALL STRBUF('READ',NINT(ARG(1)),TITLE,NCTIT,IFAIL1) IF(IFAIL1.NE.0.OR.NCTIT.LE.0)THEN PRINT *,' !!!!!! GRACAL WARNING : Unable to retrieve'// - ' the horizontal alignment.' RETURN ENDIF CALL CLTOU(TITLE(1:NCTIT)) IF(TITLE(1:NCTIT).EQ.'NORMAL')THEN IHOR=0 ELSEIF(TITLE(1:NCTIT).EQ.'LEFT')THEN IHOR=1 ELSEIF(TITLE(1:NCTIT).EQ.'CENTER'.OR. - TITLE(1:NCTIT).EQ.'CENTRE')THEN IHOR=2 ELSEIF(TITLE(1:NCTIT).EQ.'RIGHT')THEN IHOR=3 ELSE PRINT *,' !!!!!! GRACAL WARNING : Invalid horizontal'// - ' alignment; using NORMAL.' IHOR=0 ENDIF * Fetch the vertical alignment. CALL STRBUF('READ',NINT(ARG(2)),TITLE,NCTIT,IFAIL1) IF(IFAIL1.NE.0.OR.NCTIT.LE.0)THEN PRINT *,' !!!!!! GRACAL WARNING : Unable to retrieve'// - ' the vertical alignment.' RETURN ENDIF CALL CLTOU(TITLE(1:NCTIT)) +SELF,IF=HIGZ. IF(TITLE(1:NCTIT).EQ.'NORMAL')THEN IVERT=0 ELSEIF(TITLE(1:NCTIT).EQ.'TOP')THEN IVERT=1 ELSEIF(TITLE(1:NCTIT).EQ.'CAP')THEN IVERT=2 ELSEIF(TITLE(1:NCTIT).EQ.'HALF')THEN IVERT=3 ELSEIF(TITLE(1:NCTIT).EQ.'BASE')THEN IVERT=0 ELSEIF(TITLE(1:NCTIT).EQ.'BOTTOM')THEN IVERT=0 ELSE PRINT *,' !!!!!! GRACAL WARNING : Invalid vertical'// - ' alignment; using NORMAL.' IVERT=0 ENDIF +SELF,IF=-HIGZ. IF(TITLE(1:NCTIT).EQ.'NORMAL')THEN IVERT=0 ELSEIF(TITLE(1:NCTIT).EQ.'TOP')THEN IVERT=1 ELSEIF(TITLE(1:NCTIT).EQ.'CAP')THEN IVERT=2 ELSEIF(TITLE(1:NCTIT).EQ.'HALF')THEN IVERT=3 ELSEIF(TITLE(1:NCTIT).EQ.'BASE')THEN IVERT=4 ELSEIF(TITLE(1:NCTIT).EQ.'BOTTOM')THEN IVERT=5 ELSE PRINT *,' !!!!!! GRACAL WARNING : Invalid vertical'// - ' alignment; using NORMAL.' IVERT=0 ENDIF +SELF. * Issue the GKS call. CALL GSTXAL(IHOR,IVERT) *** Text colour. ELSEIF(IPROC.EQ.-825)THEN * Check arguments. IF(NARG.NE.1.OR.MODARG(1).NE.1)THEN PRINT *,' !!!!!! GRACAL WARNING : Incorrect argument'// - ' list for GKS_SET_TEXT_COLOUR' RETURN ENDIF * Retrieve the colour name. CALL STRBUF('READ',NINT(ARG(1)),TITLE,NCTIT,IFAIL1) IF(IFAIL1.NE.0.OR.NCTIT.LT.1)THEN PRINT *,' !!!!!! GRACAL WARNING : Unable to retrieve'// - ' the GKS_SET_TEXT_COLOUR colour.' RETURN ENDIF * Locate the colour in the table. CALL GRCOLQ(1,TITLE(1:NCTIT),ICOL) IF(ICOL.LT.0)THEN PRINT *,' !!!!!! GRACAL WARNING : The colour '// - TITLE(1:NCTIT)//' is not known; not set.' RETURN ENDIF * Set the colour. CALL GSTXCI(ICOL) *** Character height. ELSEIF(IPROC.EQ.-826)THEN * Check the argument list. IF(NARG.NE.1.OR.MODARG(1).NE.2)THEN PRINT *,' !!!!!! GRACAL WARNING : Incorrect argument'// - ' list for GKS_SET_CHARACTER_HEIGHT' RETURN ENDIF * Issue the GKS call. CALL GSCHH(ARG(1)) *** Character expansion. ELSEIF(IPROC.EQ.-827)THEN * Check the argument list. IF(NARG.NE.1.OR.MODARG(1).NE.2)THEN PRINT *,' !!!!!! GRACAL WARNING : Incorrect argument'// - ' list for GKS_SET_CHARACTER_EXPANSION' RETURN ENDIF * Issue the GKS call. CALL GSCHXP(ARG(1)) *** Character spacing. ELSEIF(IPROC.EQ.-828)THEN * Check the argument list. IF(NARG.NE.1.OR.MODARG(1).NE.2)THEN PRINT *,' !!!!!! GRACAL WARNING : Incorrect argument'// - ' list for GKS_SET_CHARACTER_SPACING' RETURN ENDIF * Issue the GKS call. CALL GSCHSP(ARG(1)) *** Character up vector. ELSEIF(IPROC.EQ.-829)THEN * Check the argument list. IF(NARG.NE.2.OR.MODARG(1).NE.2.OR.MODARG(2).NE.2)THEN PRINT *,' !!!!!! GRACAL WARNING : Incorrect argument'// - ' list for GKS_SET_CHARACTER_UP_VECTOR' RETURN ENDIF * Issue the GKS call. CALL GSCHUP(ARG(1),ARG(2)) *** Text font and precision. ELSEIF(IPROC.EQ.-830)THEN * Check the argument list. IF(NARG.NE.2.OR.MODARG(1).NE.2.OR.MODARG(2).NE.1)THEN PRINT *,' !!!!!! GRACAL WARNING : Incorrect argument'// - ' list for GKS_SET_CHARACTER_UP_VECTOR' RETURN ENDIF * Extract the precision. CALL STRBUF('READ',NINT(ARG(2)),TITLE,NCTIT,IFAIL1) CALL CLTOU(TITLE(1:MIN(1,NCTIT))) IF(NCTIT.LT.1.OR.IFAIL1.NE.0)THEN PRINT *,' !!!!!! GRACAL WARNING : Invalid character'// - ' precision ; font and precision not set.' RETURN ELSEIF(TITLE(1:NCTIT).EQ.'STROKE')THEN IPREC=2 ELSEIF(TITLE(1:NCTIT).EQ.'CHARACTER')THEN IPREC=1 ELSEIF(TITLE(1:NCTIT).EQ.'STRING')THEN IPREC=0 ELSE PRINT *,' !!!!!! GRACAL WARNING : Character'// - ' precision '//TITLE(1:NCTIT)// - ' is not know; assuming CHARACTER.' IPREC=1 ENDIF * Issue the GKS call. CALL GSTXFP(NINT(ARG(1)),IPREC) *** Plot an arrow. ELSEIF(IPROC.EQ.-850)THEN * Check number of arguments. IF(NARG.LT.4.OR.NARG.GT.5.OR. - MODARG(1).NE.2.OR.MODARG(2).NE.2.OR. - MODARG(3).NE.2.OR.MODARG(4).NE.2.OR. - (NARG.GE.5.AND.MODARG(5).NE.1))THEN PRINT *,' !!!!!! GRACAL WARNING : Incorrect set of'// - ' arguments for PLOT_ARROW.' RETURN ENDIF * Pick up the representation, if present. IF(NARG.GE.5)THEN CALL STRBUF('READ',NINT(ARG(5)),TITLE,NCTIT,IFAIL1) IF(NCTIT.LT.1)THEN TITLE='SOLID' NCTIT=5 ENDIF CALL CLTOU(TITLE(1:NCTIT)) ELSE TITLE='SOLID' NCTIT=5 IFAIL1=0 ENDIF * Switch to graphics screen. CALL GRGRAF(.FALSE.) * Plot the arrow with the requested representation. CALL GRATTS(TITLE(1:NCTIT),'POLYLINE') CALL GRARRO(ARG(1),ARG(2),ARG(3),ARG(4)) * Switch back to alphanumeric screen. CALL GRALPH * Print error message. IF(IFAIL1.NE.0)PRINT *,' !!!!!! GRACAL WARNING : Unable'// - ' to retrieve the arrow representation; set to SOLID.' *** Plot a title. ELSEIF(IPROC.EQ.-851)THEN * Check number of arguments and argument type. IF(NARG.NE.1.OR.MODARG(1).NE.1)THEN PRINT *,' !!!!!! GRACAL WARNING : Incorrect set of'// - ' arguments for PLOT_TITLE.' RETURN ENDIF * Retrieve the title string. CALL STRBUF('READ',NINT(ARG(1)),TITLE,NCTIT,IFAIL1) IF(IFAIL1.NE.0.OR.NCTIT.LE.0)THEN PRINT *,' !!!!!! GRACAL WARNING : Unable to retrieve'// - ' the title.' RETURN ENDIF * Plot the title. CALL GSELNT(0) CALL GSCHUP(0.0,1.0) CALL GSTXAL(1,1) CALL GRATTS('TITLE','TEXT') CALL GRTX(DISPX0+0.1,DISPY1-GPXT,TITLE(1:NCTIT)) * Restore. CALL GSELNT(1) CALL GSTXAL(0,0) CALL GSCHUP(0.0,1.0) *** Plot an x-label. ELSEIF(IPROC.EQ.-852)THEN * Check number of arguments and argument type. IF(NARG.NE.1.OR.MODARG(1).NE.1)THEN PRINT *,' !!!!!! GRACAL WARNING : Incorrect set of'// - ' arguments for PLOT_X_LABEL.' RETURN ENDIF * Retrieve the title string. CALL STRBUF('READ',NINT(ARG(1)),XTXT,NCXTXT,IFAIL1) IF(IFAIL1.NE.0.OR.NCXTXT.LE.0)THEN PRINT *,' !!!!!! GRACAL WARNING : Unable to retrieve'// - ' the x-label.' RETURN ENDIF * Label the x-axis. CALL GSELNT(0) CALL GSTXAL(3,0) CALL GSCHUP(0.0,1.0) CALL GRATTS('LABELS','TEXT') CALL GQTXX(IWK,0.5,0.5,XTXT(1:NCXTXT),IERR,CPX,CPY, - XBOX,YBOX) YSHIFT=0.5-MIN(YBOX(1),YBOX(2),YBOX(3),YBOX(4)) CALL GRTX(DISPX1-0.1,DISPY0+GPXL+YSHIFT,XTXT(1:NCXTXT)) * Restore. CALL GSELNT(1) CALL GSTXAL(0,0) CALL GSCHUP(0.0,1.0) *** Plot a y-label. ELSEIF(IPROC.EQ.-853)THEN * Check number of arguments and argument type. IF(NARG.NE.1.OR.MODARG(1).NE.1)THEN PRINT *,' !!!!!! GRACAL WARNING : Incorrect set of'// - ' arguments for PLOT_Y_LABEL.' RETURN ENDIF * Retrieve the title string. CALL STRBUF('READ',NINT(ARG(1)),YTXT,NCYTXT,IFAIL1) IF(IFAIL1.NE.0.OR.NCYTXT.LE.0)THEN PRINT *,' !!!!!! GRACAL WARNING : Unable to retrieve'// - ' the y-label.' RETURN ENDIF * Label the y-axis. CALL GSELNT(0) CALL GSTXAL(3,1) CALL GSCHUP(-1.0,0.0) CALL GRATTS('LABELS','TEXT') CALL GRTX(DISPX0+GPYL,DISPY1-0.1,YTXT(1:NCYTXT)) * Restore. CALL GSELNT(1) CALL GSTXAL(0,0) CALL GSCHUP(0.0,1.0) *** Rainbow colours ELSEIF(IPROC.EQ.-854)THEN * Check argument list. IF(NARG.NE.4.OR. - MODARG(1).NE.2.OR. - ARGREF(2,1).GE.2.OR.ARGREF(3,1).GE.2.OR. - ARGREF(4,1).GE.2.OR.ARGREF(5,1).GE.2)THEN PRINT *,' !!!!!! GRACAL WARNING : Incorrect'// - ' argument list for RAINBOW; not called.' RETURN ENDIF * Clear up old values. CALL ALGREU(NINT(ARG(2)),MODARG(3),ARGREF(2,1)) CALL ALGREU(NINT(ARG(3)),MODARG(3),ARGREF(3,1)) CALL ALGREU(NINT(ARG(4)),MODARG(4),ARGREF(4,1)) * Call the procedure. CALL RAIN(ARG(1),ARG(2),ARG(3),ARG(4)) MODARG(2)=2 MODARG(3)=2 MODARG(4)=2 *** Unknown graphics operation. ELSE PRINT *,' !!!!!! GRACAL WARNING : Unknown procedure code'// - ' received; nothing done.' IFAIL=1 RETURN ENDIF *** Seems to have worked. IFAIL=0 END +DECK,GRACWK. SUBROUTINE GRACWK(NAME,OPTION) *----------------------------------------------------------------------- * GRACWK - Activates a workstation - GKS version. * (Last changed on 6/ 3/04.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. +SEQ,GRAPHICS. EXTERNAL INPCMX INTEGER INPCMX,IWK,IFAIL,IERR,ISTATE CHARACTER*(*) NAME,OPTION *** Locate workstation. CALL GRQIWK(NAME,IWK,IFAIL) IF(IFAIL.NE.0)RETURN *** Delayed processing. IF(OPTION.EQ.'DELAY'.AND..NOT.WKMULT(IWK))THEN WKSREQ(IWK)=3 RETURN ENDIF *** Check the current state of the workstation. IF(WKSTAT(IWK).LT.2)THEN PRINT *,' ------ GRACWK MESSAGE : Workstation ',NAME, - ' is not yet open; trying to open ...' CALL GROPWK(NAME,'IMMEDIATE') IF(WKSTAT(IWK).EQ.2)THEN PRINT *,' Opening the'// - ' workstation was successful.' ELSE PRINT *,' !!!!!! GRACWK WARNING : Opening failed'// - ' ; workstation not activated.' RETURN ENDIF ENDIF CALL GQWKS(IWK,IERR,ISTATE) IF(IERR.NE.0)THEN PRINT *,' !!!!!! GRACWK WARNING : Inquiry error for'// - ' state of ',NAME,' ; assumed inactive.' IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GRACWK DEBUG :'', - '' GQWKS Error code '',I3,'' state '',I1,'' for'', - '' workstation '',A,''.'')') IERR,ISTATE,NAME ELSEIF(ISTATE.EQ.1)THEN PRINT *,' !!!!!! GRACWK WARNING : Workstation ', - NAME,' is already active.' WKSTAT(IWK)=3 RETURN ENDIF *** And at last activate the workstation. CALL GACWK(IWK) WKSTAT(IWK)=3 +SELF,IF=HIGZ. CALL SGFLAG IF(WKFREF(IWK).GT.0)CALL IGRNG(19.0,19.0) +SELF. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GRACWK DEBUG :'', - '' Workstation '',A,'' has been activated.'')') NAME *** Check that the workstation is really open. CALL GQWKS(IWK,IERR,ISTATE) IF(IERR.EQ.7.OR.IERR.EQ.25)THEN PRINT *,' !!!!!! GRACWK WARNING : Cannot activate ',NAME, - ' because the workstation is not open.' WKSTAT(IWK)=1 RETURN ELSEIF(IERR.EQ.20)THEN PRINT *,' !!!!!! GRACWK WARNING : Cannot activate ',NAME, - ' because the workstation identifier is not valid.' WKSTAT(IWK)=1 RETURN ELSEIF(ISTATE.NE.1)THEN PRINT *,' !!!!!! GRACWK WARNING : Workstation ',NAME, - ' could not be activated.' WKSTAT(IWK)=1 RETURN ENDIF END +DECK,GRADWK. SUBROUTINE GRADWK *----------------------------------------------------------------------- * GRADWK - Adds a workstation to the workstation table. * (Last changed on 5/ 3/04.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,GRAPHICS. +SEQ,INPUT. +SEQ,PRINTPLOT. CHARACTER*(MXCHAR) STR CHARACTER*(MXNAME) FILE CHARACTER*20 NAME LOGICAL KTYPE,KCONID,KOFF,KFILE,KGKSID INTEGER NC,IKEY,INEXT,NNWORD,NCFILE,IOFF,ICO,ICONID,IWKTYP,ICAT, - I,IFAIL1,INPCMP,NCNAME,IERR,KMULT EXTERNAL INPCMP *** Determine position of keyword. CALL INPSTR(1,1,STR,NC) IF(STR(1:1).EQ.'!'.AND.NC.EQ.1)THEN IKEY=2 ELSE IKEY=1 ENDIF *** Warn if there are no arguments. CALL INPNUM(NNWORD) IF(NNWORD.EQ.IKEY)THEN PRINT *,' !!!!!! GRADWK WARNING : ADD-WORKSTATION needs'// - ' arguments ; nothing done.' RETURN ENDIF *** Initial values. FILE='GARFIELD.METAFILE' NCFILE=17 IOFF=0 ICONID=1 IWKTYP=0 ICAT=-1 KMULT=0 *** First argument is the name of the workstation. CALL INPSTR(IKEY+1,IKEY+1,NAME,NCNAME) * Preset flags. KFILE=.FALSE. KGKSID=.FALSE. KTYPE=.FALSE. KCONID=.FALSE. KOFF=.FALSE. * Match with existing names. DO 10 I=1,NWK IF(NAME(1:NCNAME).EQ.WKNAME(I)(1:NCWKNM(I)))THEN PRINT *,' !!!!!! GRADWK WARNING : '//NAME(1:NCNAME)// - ' is already defined ; not redefined.' RETURN ENDIF 10 CONTINUE *** Loop over the rest of the string. INEXT=1 DO 20 I=IKEY+2,NNWORD IF(I.LT.INEXT)GOTO 20 * Type specification. IF(INPCMP(I,'TY#PE').NE.0)THEN IF(I+1.GT.NNWORD)THEN CALL INPMSG(I,'Argument is missing.') ELSE CALL INPSTR(I+1,I+1,STR,NC) CALL GRWKID(STR(1:NC),IWKTYP,ICO,ICAT,IFAIL1) IF(IFAIL1.EQ.0.AND.ICAT.EQ.2)THEN ICONID=ICO ELSEIF(IFAIL1.EQ.0)THEN IOFF=ICO ELSE CALL INPMSG(I+1,'Not a valid workstation type.') ENDIF INEXT=I+2 KTYPE=.TRUE. ENDIF * GKS identifier. ELSEIF(INPCMP(I,'GKS-ID#ENTIFIER').NE.0)THEN IF(I+1.GT.NNWORD)THEN CALL INPMSG(I,'Argument is missing.') ELSE CALL INPCHK(I+1,1,IFAIL1) CALL INPRDI(I+1,IWKTYP,0) CALL GQWKCA(IWKTYP,IERR,ICAT) IF(IERR.NE.0)CALL INPMSG(I+1,'GKS inquiry error.') INEXT=I+2 KGKSID=.TRUE. ENDIF * Connection identifier. ELSEIF(INPCMP(I,'CON#NECTION-ID#ENTIFIER').NE.0)THEN IF(I+1.GT.NNWORD)THEN CALL INPMSG(I,'Argument is missing.') ELSE CALL INPCHK(I+1,1,IFAIL1) CALL INPRDI(I+1,ICONID,0) INEXT=I+2 KCONID=.TRUE. ENDIF * Logical unit offset. ELSEIF(INPCMP(I,'OFF#SET').NE.0)THEN IF(I+1.GT.NNWORD)THEN CALL INPMSG(I,'Argument is missing.') ELSE CALL INPCHK(I+1,1,IFAIL1) CALL INPRDI(I+1,IOFF,0) INEXT=I+2 KOFF=.TRUE. ENDIF * File name. ELSEIF(INPCMP(I,'F#ILE-NAME')+INPCMP(I,'NAME').NE.0)THEN IF(I+1.GT.NNWORD)THEN CALL INPMSG(I,'Argument is missing.') ELSE CALL INPSTR(I+1,I+1,FILE,NCFILE) INEXT=I+2 KFILE=.TRUE. ENDIF * Multiple of single frame. ELSEIF(INPCMP(I,'M#ULTIPLE-FR#AME-#FILE').NE.0)THEN KMULT=+1 ELSEIF(INPCMP(I,'S#INGLE-FR#AME-#FILE').NE.0)THEN KMULT=-1 * Anything else is not valid. ELSE CALL INPMSG(I,'Not a valid keyword.') ENDIF 20 CONTINUE *** Print error messages CALL INPERR *** Check for invalid combinations. IF((ICAT.EQ.2.AND.KFILE).OR. - ((ICAT.EQ.0.OR.ICAT.EQ.4).AND..NOT.KFILE).OR. - (KFILE.AND.KCONID).OR. - (.NOT.KFILE.AND.KOFF).OR. - (.NOT.KTYPE.AND..NOT.KGKSID))THEN PRINT *,' !!!!!! GRADWK WARNING : Incomplete'// - ' specification or, illegal combination of keywords' PRINT *,' or keywords used that'// - ' are not appropriate for the workstation; ignored.' RETURN ELSEIF(ICAT.EQ.-1)THEN PRINT *,' !!!!!! GRADWK WARNING : No valid workstation'// - ' type found; ignored.' RETURN ENDIF IF((.NOT.KFILE).AND.KMULT.NE.0) - PRINT *,' !!!!!! GRADWK WARNING : Only workstations with'// - ' output to a file can be single/multiple frame;'// - ' option ignored.' +SELF,IF=CMS. *** Verify the file name. IF(KFILE)THEN CALL VMNAME(FILE,NCFILE,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! GRADWK WARNING : Metafile file name'// - ' not valid ; ! ADD ignored.' RETURN ENDIF ENDIF +SELF. *** Store the information, increment workstation counter. IF(NWK.GE.MXWKLS)THEN PRINT *,' !!!!!! GRADWK WARNING : No storage left for'// - ' workstations; ignored.' RETURN ENDIF NWK=NWK+1 * Store the name. WKNAME(NWK)=NAME(1:NCNAME) NCWKNM(NWK)=NCNAME * GKS identifier. WKID(NWK)=IWKTYP * File attributes. IF(KFILE)THEN CALL STRBUF('STORE',WKFREF(NWK),FILE,NCFILE,IFAIL1) WKCON(NWK)=IOFF IF(KMULT.EQ.-1)THEN WKMULT(NWK)=.FALSE. ELSEIF(KMULT.EQ.+1)THEN WKMULT(NWK)=.TRUE. ELSEIF(INDEX(FILE(1:NCFILE),'{').NE.0.AND. - INDEX(FILE(1:NCFILE),'}').NE.0)THEN WKMULT(NWK)=.FALSE. ELSE WKMULT(NWK)=.TRUE. ENDIF ELSE WKFREF(NWK)=-1 WKCON(NWK)=ICONID ENDIF * Status. WKSTAT(NWK)=1 WKSREQ(NWK)=1 END +DECK,GRAINP. SUBROUTINE GRAINP *----------------------------------------------------------------------- * GRAINP - Serves as a subsection reading graphics command lines. * (Last changed on 2/ 8/09.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PARAMETERS. +SEQ,GRAPHICS. +SEQ,CONTDATA. +SEQ,PRINTPLOT. +SEQ,CONSTANTS. LOGICAL LOOP,LREL INTEGER INPCMP,INPTYP,NWORD,INEXT,I,NC,MXOPWK,MXACWK,MXWKAS,INIT, - IERR,IKEY,IFAIL,IFAIL1,IFAIL2,IFAIL3,IFAIL4, - NITERR,NSTEPR,IDEFM,IREGM,IEMPTY,IFRAME, - LEVEL,ISTA,IDEFD,IUPDD,IDEF,IUPD,IWK,IDUM1,IDUM2,IDUM,NACT, - NC1,NC2,NC3,NC4,NCOUT REAL EPSR,DNR,AUX,BARFRR,ARRLER,DISX0R,DISX1R,DISY0R,DISY1R CHARACTER*(MXCHAR) STRING,OUT CHARACTER*20 AUX1,AUX2,AUX3,AUX4 EXTERNAL INPCMP,INPTYP +SELF,IF=AST. EXTERNAL ASTCCH +SELF,IF=SAVE. SAVE INIT,MXOPWK,MXACWK,MXWKAS +SELF. *** Identify the subroutine if requested. IF(LIDENT)PRINT *,' /// ROUTINE GRAINP ///' *** First call, figure out how many workstations there are. DATA INIT/0/ IF(INIT.EQ.0)THEN CALL GQWKM(IERR,MXOPWK,MXACWK,MXWKAS) IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GRAINP DEBUG : '', - '' MXOPWK='',I3,'', MXACWK='',I3,'', MXWKAS='',I3)') - MXOPWK,MXACWK,MXWKAS INIT=1 ENDIF *** First pick up the number of words and the first word. CALL INPNUM(NWORD) CALL INPSTR(1,1,STRING,NC) *** Check it is a graphics command. IF(STRING(1:1).NE.'!')RETURN *** Determine whether it is a single command or not. IF(NWORD.EQ.1.AND.NC.EQ.1)THEN LOOP=.TRUE. PRINT *,' ' PRINT *,' ------------------------------------------------' PRINT *,' ---------- Graphics subsection ----------' PRINT *,' ------------------------------------------------' PRINT *,' ' CALL INPPRM('Graphics','ADD-PRINT') ELSE LOOP=.FALSE. ENDIF *** Return here if LOOP is .TRUE. 10 CONTINUE IF(LOOP)THEN CALL INPGET CALL INPNUM(NWORD) +SELF,IF=AST. *** Set up ASTCCH as the condition handler. CALL LIB$ESTABLISH(ASTCCH) +SELF. ENDIF CALL INPSTR(1,1,STRING,NC) *** Skip blank lines and warn for section headers. IF(STRING(1:1).EQ.'&')THEN PRINT *,' !!!!!! GRAINP WARNING : The section cannot be'// - ' left at this point; first type EXIT.' GOTO 1010 ELSEIF(INDEX('$%?><@',STRING(1:1)).NE.0)THEN PRINT *,' !!!!!! GRAINP WARNING : This command cannot be'// - ' executed at the present level; first type EXIT.' GOTO 1010 ELSEIF(STRING(1:1).EQ.'*')THEN GOTO 1010 ENDIF IF(LOOP.AND.(NWORD.EQ.0.OR.(NWORD.EQ.1.AND.NC.EQ.1.AND. - STRING(1:1).EQ.'!')))GOTO 1010 IF(.NOT.LOOP.AND.NC.EQ.1.AND.NWORD.EQ.1)RETURN *** Set the position of the command. IF(NC.EQ.1.AND.STRING(1:1).EQ.'!')THEN IKEY=2 ELSE IKEY=1 ENDIF *** The ACTIVATE-WORKSTATION command. IF(INPCMP(IKEY,'!ACT#IVATE-#WORKSTATION')+ - INPCMP(IKEY,'ACT#IVATE-#WORKSTATION').NE.0)THEN IF(NWORD.LE.IKEY)THEN PRINT *,' !!!!!! GRAINP WARNING : You must specify'// - ' a workstation name with this command.' * Arguments present ? ELSE * Have the workstation(s) activated. DO 30 I=IKEY+1,NWORD CALL INPSTR(I,I,STRING,NC) CALL GRACWK(STRING(1:NC),'DELAY') 30 CONTINUE ENDIF *** Add a workstation. ELSEIF(INPCMP(IKEY,'ADD-#WORKSTATION')+ - INPCMP(IKEY,'!ADD-#WORKSTATION').NE.0)THEN CALL GRADWK *** Arrow tip angle. ELSEIF(INPCMP(IKEY,'ARR#OW-TOP-ANG#LE')+ - INPCMP(IKEY,'!ARR#OW-TOP-ANG#LE')+ - INPCMP(IKEY,'ARR#OW-TIP-ANG#LE')+ - INPCMP(IKEY,'!ARR#OW-TIP-ANG#LE')+ - INPCMP(IKEY,'ARR#OW-ANG#LE')+ - INPCMP(IKEY,'!ARR#OW-ANG#LE').NE.0)THEN IF(NWORD.EQ.IKEY)THEN WRITE(LUNOUT,'('' Current tip angle: '',F10.3, - '' degrees.'')') ARRANG*180/PI ELSE CALL INPCHK(IKEY+1,2,IFAIL1) CALL INPRDR(IKEY+1,ARRANG,ARRANG*180/PI) ARRANG=ARRANG*PI/180 CALL INPERR ENDIF *** Arrow tip length. ELSEIF(INPCMP(IKEY,'ARR#OW-TIP-LEN#GTH')+ - INPCMP(IKEY,'!ARR#OW-TIP-LEN#GTH')+ - INPCMP(IKEY,'ARR#OW-LEN#GTH')+ - INPCMP(IKEY,'!ARR#OW-LEN#GTH').NE.0)THEN IF(NWORD.EQ.IKEY)THEN IF(ARRLEN.LT.0)THEN WRITE(LUNOUT,'('' Current tip length: '',F10.3, - '' in NDC coordinates.'')') ABS(ARRLEN) ELSE WRITE(LUNOUT,'('' Current tip length: '',F10.3, - '' times total length.'')') ARRLEN ENDIF ELSE LREL=.TRUE. IF(IKEY+1.EQ.NWORD)THEN LREL=.TRUE. ELSEIF(INPCMP(IKEY+2,'REL#ATIVE').NE.0)THEN LREL=.TRUE. ELSEIF(INPCMP(IKEY+2,'ABS#OLUTE').NE.0)THEN LREL=.FALSE. ELSE CALL INPMSG(IKEY+3,'Unknown option') LREL=.TRUE. ENDIF IF(IKEY+2.LT.NWORD) - CALL INPMSG(IKEY+3,'Spurious keywords') CALL INPCHK(IKEY+1,2,IFAIL1) CALL INPRDR(IKEY+1,ARRLER,ARRLEN) IF(ARRLER.LE.0.OR.ARRLER.GT.1)THEN CALL INPMSG(IKEY+1,'Not in range <0,1].') ELSE ARRLEN=ARRLER ENDIF IF(.NOT.LREL)ARRLEN=-ABS(ARRLEN) CALL INPERR ENDIF *** Bar chart width. ELSEIF(INPCMP(IKEY,'BAR#CHART-W#IDTH')+ - INPCMP(IKEY,'!BAR#CHART-W#IDTH')+ - INPCMP(IKEY,'BAR-CH#ART-W#IDTH')+ - INPCMP(IKEY,'!BAR-CH#ART-W#IDTH').NE.0)THEN IF(NWORD.EQ.IKEY)THEN WRITE(LUNOUT,'('' Current bar chart width: '',F10.3, - '' times maximum width.'')') BARFRC ELSE CALL INPCHK(IKEY+1,2,IFAIL1) CALL INPRDR(IKEY+1,BARFRR,BARFRC) IF(BARFRR.LE.0.OR.BARFRR.GT.1)THEN CALL INPMSG(IKEY+1,'Not in range <0,1].') ELSE BARFRC=BARFRR ENDIF CALL INPERR ENDIF *** Clear screen. ELSEIF(INPCMP(IKEY,'!CLE#AR-#SCREEN')+ - INPCMP(IKEY,'CLE#AR-#SCREEN').NE.0)THEN CALL GQACWK(0,IERR,NACT,IWK) IF(IERR.NE.0)THEN PRINT *,' !!!!!! GRAINP WARNING : Unable to'// - ' determine number of active workstations.' NACT=0 ENDIF DO 20 I=1,NACT CALL GQACWK(I,IERR,IDUM,IWK) CALL GCLRWK(IWK,1) IF(LDEBUG)WRITE(10,'('' ++++++ GRAINP DEBUG :'', - '' Clear sent to WS '',I3,''.'')') IWK 20 CONTINUE *** Close a workstation. ELSEIF(INPCMP(IKEY,'CLO#SE-#WORKSTATION')+ - INPCMP(IKEY,'!CLO#SE-#WORKSTATION').NE.0)THEN * Argument(s) present ? IF(NWORD.NE.IKEY+1)THEN PRINT *,' !!!!!! GRAINP WARNING : You must specify'// - ' a workstation name with this command.' ELSE * Have the workstation closed. DO 80 I=IKEY+1,NWORD CALL INPSTR(I,I,STRING,NC) CALL GRCLWK(STRING(1:NC),'DELAY') 80 CONTINUE ENDIF *** Colour definition. ELSEIF(INPCMP(IKEY,'!COL#OUR')+INPCMP(IKEY,'COL#OUR').NE.0)THEN CALL GRCOLR(IKEY,IFAIL) IF(IFAIL.NE.0)PRINT *,' !!!!!! GRAINP WARNING : Colour'// - ' inquiry or update failed.' *** Contour parameters. ELSEIF(INPCMP(IKEY,'!CONT#OUR-#PARAMETERS')+ - INPCMP(IKEY,'CONT#OUR-#PARAMETERS').NE.0)THEN * Print settings of arguments are missing. IF(NWORD.EQ.IKEY)THEN WRITE(LUNOUT,'('' Current contour parameters:''// - '' Bisection iterations: '',I10/ - '' Newton iterations: '',I10/ - '' Epsilon for tracing: '',E10.3/ - '' Epsilon for gradients: '',E10.3/ - '' Initial step size: '',E10.3/ - '' Relative grid tolerance: '',E10.3/ - '' Maximum number of steps: '',I10)') - NBITER,NNITER,EPSTRA,EPSGRA,STINIT,DNTHR,NGCMAX * Otherwise decode argument list. ELSE INEXT=IKEY+1 DO 120 I=IKEY+1,NWORD IF(I.LT.INEXT)GOTO 120 IF(INPCMP(I,'BIS#ECTION-#ITER#ATIONS').NE.0)THEN CALL INPCHK(I+1,1,IFAIL1) CALL INPRDI(I+1,NITERR,NBITER) IF(NITERR.GT.0)THEN NBITER=NITERR ELSE CALL INPMSG(I+1,'Should be > 0.') ENDIF INEXT=I+2 ELSEIF(INPCMP(I,'NEWT#ON-ITER#ATIONS').NE.0)THEN CALL INPCHK(I+1,1,IFAIL1) CALL INPRDI(I+1,NITERR,NNITER) IF(NITERR.GT.0)THEN NNITER=NITERR ELSE CALL INPMSG(I+1,'Should be > 0.') ENDIF INEXT=I+2 ELSEIF(INPCMP(I,'ST#EP-MAX#IMUM').NE.0)THEN CALL INPCHK(I+1,1,IFAIL1) CALL INPRDI(I+1,NSTEPR,NGCMAX) IF(NSTEPR.GT.0)THEN NGCMAX=NSTEPR ELSE CALL INPMSG(I+1,'Should be > 0.') ENDIF INEXT=I+2 ELSEIF(INPCMP(I,'EPS#ILON-GRA#DIENT').NE.0)THEN CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,EPSR,EPSGRA) IF(EPSR.GT.0)THEN EPSGRA=EPSR ELSE CALL INPMSG(I+1,'Should be > 0.') ENDIF INEXT=I+2 ELSEIF(INPCMP(I,'EPS#ILON-TRA#CING').NE.0)THEN CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,EPSR,EPSTRA) IF(EPSR.GT.0)THEN EPSTRA=EPSR ELSE CALL INPMSG(I+1,'Should be > 0.') ENDIF INEXT=I+2 ELSEIF(INPCMP(I,'GR#ID-TOL#ERANCE').NE.0)THEN CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,DNR,DNTHR) IF(DNR.GT.0)THEN DNTHR=DNR ELSE CALL INPMSG(I+1,'Should be > 0.') ENDIF INEXT=I+2 ELSE CALL INPMSG(I,'Not a known keyword.') ENDIF 120 CONTINUE * Show error messages. CALL INPERR ENDIF *** The DEACTIVATE-WORKSTATION command. ELSEIF(INPCMP(IKEY,'!DEACT#IVATE-#WORKSTATION')+ - INPCMP(IKEY,'DEACT#IVATE-#WORKSTATION').NE.0)THEN * Arguments present ? IF(NWORD.LE.IKEY)THEN PRINT *,' !!!!!! GRAINP WARNING : You must specify'// - ' a workstation name with this command.' * Have the workstation deactivated. ELSE DO 40 I=IKEY+1,NWORD CALL INPSTR(I,I,STRING,NC) CALL GRDAWK(STRING(1:NC),'DELAY') 40 CONTINUE ENDIF *** Delete a workstation. ELSEIF(INPCMP(IKEY,'DEL#ETE-#WORKSTATION')+ - INPCMP(IKEY,'!DEL#ETE-#WORKSTATION').NE.0)THEN CALL GRDLWK *** Check for the EXIT command. ELSEIF(INPCMP(IKEY,'EX#IT')+INPCMP(IKEY,'!EX#IT').NE.0)THEN PRINT *,' ' PRINT *,' ------------------------------------------------' PRINT *,' ---------- Graphics subsection end ----------' PRINT *,' ------------------------------------------------' PRINT *,' ' CALL INPPRM(' ','BACK-PRINT') RETURN *** Representation reading from dataset. ELSEIF(INPCMP(IKEY,'GET-COL#OURS')+ - INPCMP(IKEY,'!GET-COL#OURS').NE.0)THEN CALL GRCOLG(IKEY,IFAIL) IF(IFAIL.NE.0)PRINT *,' !!!!!! GRAINP WARNING : Reading'// - ' a colour table failed.' *** Representation reading from dataset. ELSEIF(INPCMP(IKEY,'GET-REP#RESENTATIONS')+ - INPCMP(IKEY,'!GET-REP#RESENTATIONS').NE.0)THEN CALL GRATTG(IKEY,IFAIL) IF(IFAIL.NE.0)PRINT *,' !!!!!! GRAINP WARNING : Reading'// - ' a graphics representation member failed.' *** Various inquire functions. ELSEIF(INPCMP(IKEY,'!INQ#UIRE-DEF#ERRAL-#UPDATE-#STATE')+ - INPCMP(IKEY,'INQ#UIRE-DEF#ERRAL-#UPDATE-#STATE').NE.0)THEN CALL INPSTR(IKEY+1,IKEY+1,STRING,NC) IF(NWK.LE.0)WRITE(LUNOUT,'(/'' There are currently no'', - '' workstations defined.''/)') DO 90 I=1,NWK IF(WKNAME(I)(1:NCWKNM(I)).EQ.STRING(1:NC).OR. - STRING.EQ.'*'.OR.IKEY.EQ.NWORD)THEN CALL GQWKDU(I,IERR,IDEFM,IREGM,IEMPTY,IFRAME) WRITE(LUNOUT,'('' Workstation '',A,'':'')') - WKNAME(I)(1:NCWKNM(I)) IF(IDEFM.EQ.0)WRITE(LUNOUT,'(7X,''Deferral state: '', - '' As soon as possible;'')') IF(IDEFM.EQ.1)WRITE(LUNOUT,'(7X,''Deferral state: '', - '' Before next global interaction;'')') IF(IDEFM.EQ.2)WRITE(LUNOUT,'(7X,''Deferral state: '', - '' Before next local interaction;'')') IF(IDEFM.EQ.3)WRITE(LUNOUT,'(7X,''Deferral state: '', - '' At some time;'')') IF(IDEFM.LT.0.OR.IDEFM.GT.3)WRITE(LUNOUT,'(7X, - ''Deferral state: *** NOT KNOWN ***'')') IF(IREGM.EQ.0)WRITE(LUNOUT,'(7X,''Regeneration: '', - '' Suppressed;'')') IF(IREGM.EQ.1)WRITE(LUNOUT,'(7X,''Regeneration: '', - '' Allowed;'')') IF(IREGM.LT.0.OR.IREGM.GT.1)WRITE(LUNOUT,'(7X, - ''Regeneration: *** NOT KNOWN ***'')') IF(IEMPTY.EQ.0)WRITE(LUNOUT,'(7X,''Display surface: '', - '' Not empty anymore;'')') IF(IEMPTY.EQ.1)WRITE(LUNOUT,'(7X,''Display surface: '', - '' Currently empty;'')') IF(IEMPTY.LT.0.OR.IEMPTY.GT.1)WRITE(LUNOUT,'(7X, - ''Display surface: *** NOT KNOWN ***'')') IF(IFRAME.EQ.0)WRITE(LUNOUT,'(7X,''For an update: '', - '' No new frame needed;'')') IF(IFRAME.EQ.1)WRITE(LUNOUT,'(7X,''For an update: '', - '' New frame needed;'')') IF(IFRAME.LT.0.OR.IFRAME.GT.1)WRITE(LUNOUT,'(7X, - ''For an update: *** NOT KNOWN ***'')') IF(IERR.NE.0)WRITE(LUNOUT,'(7X,''GKS inquiry error '', - I4,'' occurred.'')') IERR WRITE(LUNOUT,'('' '')') ENDIF 90 CONTINUE *** GKS level inquiry. ELSEIF(INPCMP(IKEY,'!INQ#UIRE-LEV#EL-#GKS')+ - INPCMP(IKEY,'INQ#UIRE-LEV#EL-#GKS').NE.0)THEN CALL GQLVKS(IERR,LEVEL) IF(IERR.NE.0)GOTO 3000 IF(LEVEL.EQ.-3)THEN WRITE(LUNOUT,'(/'' Running with a level mA GKS.''/)') ELSEIF(LEVEL.EQ.-2)THEN WRITE(LUNOUT,'(/'' Running with a level mB GKS.''/)') ELSEIF(LEVEL.EQ.-1)THEN WRITE(LUNOUT,'(/'' Running with a level mC GKS.''/)') ELSEIF(LEVEL.EQ. 0)THEN WRITE(LUNOUT,'(/'' Running with a level 0A GKS.''/)') ELSEIF(LEVEL.EQ.+1)THEN WRITE(LUNOUT,'(/'' Running with a level 0B GKS.''/)') ELSEIF(LEVEL.EQ.+2)THEN WRITE(LUNOUT,'(/'' Running with a level 0C GKS.''/)') ELSEIF(LEVEL.EQ.+3)THEN WRITE(LUNOUT,'(/'' Running with a level 1A GKS.''/)') ELSEIF(LEVEL.EQ.+4)THEN WRITE(LUNOUT,'(/'' Running with a level 1B GKS.''/)') ELSEIF(LEVEL.EQ.+5)THEN WRITE(LUNOUT,'(/'' Running with a level 1C GKS.''/)') ELSEIF(LEVEL.EQ.+6)THEN WRITE(LUNOUT,'(/'' Running with a level 2A GKS.''/)') ELSEIF(LEVEL.EQ.+7)THEN WRITE(LUNOUT,'(/'' Running with a level 2B GKS.''/)') ELSEIF(LEVEL.EQ.+8)THEN WRITE(LUNOUT,'(/'' Running with a level 2C GKS.''/)') ELSE WRITE(LUNOUT,'(/'' GKS level code is '',I2,'' which'', - '' is not a standard code.'')') LEVEL ENDIF *** Operating state. ELSEIF(INPCMP(IKEY,'!INQ#UIRE-OP#ERATING-#STATE')+ - INPCMP(IKEY,'INQ#UIRE-OP#ERATING-#STATE').NE.0)THEN CALL GQOPS(ISTA) IF(ISTA.EQ.0)THEN WRITE(LUNOUT,'(/'' GKS is closed at the moment.''/)') ELSEIF(ISTA.EQ.1)THEN WRITE(LUNOUT,'(/'' GKS is open at the moment.''/)') ELSEIF(ISTA.EQ.2)THEN WRITE(LUNOUT,'(/'' A workstation is open.''/)') ELSEIF(ISTA.EQ.3)THEN WRITE(LUNOUT,'(/'' A workstation is active.''/)') ELSEIF(ISTA.EQ.4)THEN WRITE(LUNOUT,'(/'' A segment is open.''/)') ELSE WRITE(LUNOUT,'(/'' GKS state code is'',I3,'', which'', - '' is not standard.''/)') ISTA ENDIF *** List workstations. ELSEIF(INPCMP(IKEY,'!INQ#UIRE-W#ORKSTATIONS')+ - INPCMP(IKEY,'INQ#UIRE-W#ORKSTATIONS').NE.0)THEN IF(NWK.EQ.0)THEN WRITE(LUNOUT,'(/'' Not a single workstation'', - '' known at present.'')') ELSE * Header. WRITE(LUNOUT,'(/'' LIST OF CURRENTLY KNOWN'', - '' WORKSTATIONS: ''/)') DO 70 I=1,NWK * Name of the workstation. OUT(1:NCWKNM(I)+2)=WKNAME(I)(1:NCWKNM(I))//': ' NCOUT=NCWKNM(I)+2 * Current state. IF(WKSTAT(I).LT.2)THEN OUT(NCOUT+1:NCOUT+7)='defined' NCOUT=NCOUT+7 ELSEIF(WKSTAT(I).EQ.2)THEN OUT(NCOUT+1:NCOUT+4)='open' NCOUT=NCOUT+4 ELSEIF(WKSTAT(I).EQ.3)THEN OUT(NCOUT+1:NCOUT+6)='active' NCOUT=NCOUT+6 ENDIF * Requested state. IF(WKSREQ(I).GT.WKSTAT(I))THEN IF(WKSREQ(I).LT.2)THEN OUT(NCOUT+1:NCOUT+16)=' (to be defined)' NCOUT=NCOUT+16 ELSEIF(WKSREQ(I).EQ.2)THEN OUT(NCOUT+1:NCOUT+15)=' (to be opened)' NCOUT=NCOUT+15 ELSEIF(WKSREQ(I).EQ.3)THEN OUT(NCOUT+1:NCOUT+18)=' (to be activated)' NCOUT=NCOUT+18 ENDIF ENDIF * GKS identifier CALL OUTFMT(REAL(WKID(I)),2,AUX1,NC1,'LEFT') OUT(NCOUT+1:NCOUT+7+NC1)=', type '//AUX1(1:NC1) NCOUT=NCOUT+7+NC1 * File information. IF(WKFREF(I).GT.0)THEN CALL STRBUF('READ',WKFREF(I),STRING,NC,IFAIL1) IF(WKSTAT(I).GE.2)THEN CALL OUTFMT(REAL(WKLUN(I)),2,AUX2,NC2,'LEFT') ELSE AUX2='not yet defined' NC2=15 ENDIF CALL OUTFMT(REAL(WKCON(I)),2,AUX3,NC3,'LEFT') OUT(NCOUT+1:NCOUT+8+NC+8+NC2+9+NC3)= - ', file "'//STRING(1:NC)// - '", unit '//AUX2(1:NC2)// - ', offset '//AUX3(1:NC3) NCOUT=NCOUT+8+NC+8+NC2+9+NC3 IF(WKMULT(I))THEN OUT(NCOUT+1:NCOUT+16)=', multiple frame' NCOUT=NCOUT+16 ELSE OUT(NCOUT+1:NCOUT+14)=', single frame' NCOUT=NCOUT+14 ENDIF * Connection identifier. ELSE CALL OUTFMT(REAL(WKCON(I)),2,AUX3,NC3,'LEFT') OUT(NCOUT+1:NCOUT+24+NC3)= - ', connection identifier '//AUX3(1:NC3) NCOUT=NCOUT+24+NC3 ENDIF * Print the string. WRITE(LUNOUT,'(2X,A)') OUT(1:NCOUT) 70 CONTINUE WRITE(LUNOUT,'('' '')') ENDIF *** Layout of Cartesian plots. ELSEIF(INPCMP(IKEY,'LAY#OUT')+INPCMP(IKEY,'!LAY#OUT').NE.0)THEN IF(NWORD.EQ.IKEY)THEN WRITE(LUNOUT,'('' Current Cartesian layout:''// - '' Decades to x-axis: '',F10.3/ - '' Decades to y-axis: '',F10.3/ - '' Numbers to x-axis: '',F10.3/ - '' Numbers to y-axis: '',F10.3/ - '' x-Label to border: '',F10.3/ - '' y-Label to border: '',F10.3/ - '' Title to border: '',F10.3)') - GPXN10,GPYN10,GPXN,GPYN,GPXL,GPYL,GPXT ELSE INEXT=IKEY+1 DO 130 I=IKEY+1,NWORD IF(I.LT.INEXT)GOTO 130 IF(INPCMP(I,'DEC#ADE-X-#DISTANCE')+ - INPCMP(I,'X-DEC#ADE-#DISTANCE').NE.0)THEN CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,AUX,GPXN10) IF(IFAIL1.EQ.0.AND.AUX.GE.0.AND.AUX.LE.0.1)THEN GPXN10=AUX ELSEIF(IFAIL1.EQ.0)THEN CALL INPMSG(I+1,'Not in range [0 , 0.1]') ENDIF INEXT=I+2 ELSEIF(INPCMP(I,'DEC#ADE-Y-#DISTANCE')+ - INPCMP(I,'Y-DEC#ADE-#DISTANCE').NE.0)THEN CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,AUX,GPYN10) IF(IFAIL1.EQ.0.AND.AUX.GE.0.AND.AUX.LE.0.1)THEN GPYN10=AUX ELSEIF(IFAIL1.EQ.0)THEN CALL INPMSG(I+1,'Not in range [0 , 0.1]') ENDIF INEXT=I+2 ELSEIF(INPCMP(I,'N#UMBER-X-#DISTANCE')+ - INPCMP(I,'X-N#UMBER-#DISTANCE').NE.0)THEN CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,AUX,GPXN) IF(IFAIL1.EQ.0.AND.AUX.GE.0.AND.AUX.LE.0.1)THEN GPXN=AUX ELSEIF(IFAIL1.EQ.0)THEN CALL INPMSG(I+1,'Not in range [0 , 0.1]') ENDIF INEXT=I+2 ELSEIF(INPCMP(I,'N#UMBER-Y-#DISTANCE')+ - INPCMP(I,'Y-N#UMBER-#DISTANCE').NE.0)THEN CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,AUX,GPYN) IF(IFAIL1.EQ.0.AND.AUX.GE.0.AND.AUX.LE.0.1)THEN GPYN=AUX ELSEIF(IFAIL1.EQ.0)THEN CALL INPMSG(I+1,'Not in range [0 , 0.1]') ENDIF INEXT=I+2 ELSEIF(INPCMP(I,'LAB#EL-X-#DISTANCE')+ - INPCMP(I,'X-LAB#EL-#DISTANCE').NE.0)THEN CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,AUX,GPXL) IF(IFAIL1.EQ.0.AND.AUX.GE.0.AND.AUX.LE.0.1)THEN GPXL=AUX ELSEIF(IFAIL1.EQ.0)THEN CALL INPMSG(I+1,'Not in range [0 , 0.1]') ENDIF INEXT=I+2 ELSEIF(INPCMP(I,'LAB#EL-Y-#DISTANCE')+ - INPCMP(I,'Y-LAB#EL-#DISTANCE').NE.0)THEN CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,AUX,GPYL) IF(IFAIL1.EQ.0.AND.AUX.GE.0.AND.AUX.LE.0.1)THEN GPYL=AUX ELSEIF(IFAIL1.EQ.0)THEN CALL INPMSG(I+1,'Not in range [0 , 0.1]') ENDIF INEXT=I+2 ELSEIF(INPCMP(I,'TIT#LE-#X-#DISTANCE')+ - INPCMP(I,'X-TIT#LE-#DISTANCE').NE.0)THEN CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,AUX,GPXT) IF(IFAIL1.EQ.0.AND.AUX.GE.0.AND.AUX.LE.0.1)THEN GPXT=AUX ELSEIF(IFAIL1.EQ.0)THEN CALL INPMSG(I+1,'Not in range [0 , 0.1]') ENDIF INEXT=I+2 ELSE CALL INPMSG(I,'Not a known keyword.') ENDIF 130 CONTINUE CALL INPERR ENDIF *** Produce a colour map. ELSEIF(INPCMP(IKEY,'MAP-#COLOURS')+ - INPCMP(IKEY,'!MAP-#COLOURS').NE.0)THEN CALL GRCOLM *** Open a workstation. ELSEIF(INPCMP(IKEY,'OPEN-#WORKSTATION')+ - INPCMP(IKEY,'!OPEN-#WORKSTATION').NE.0)THEN * Argument(s) present ? IF(NWORD.NE.IKEY+1)THEN PRINT *,' !!!!!! GRAINP WARNING : You must specify'// - ' a workstation name with this command.' ELSE * Have the workstation opened. DO 50 I=IKEY+1,NWORD CALL INPSTR(I,I,STRING,NC) CALL GROPWK(STRING(1:NC),'DELAY') 50 CONTINUE ENDIF *** Graphics options. ELSEIF(INPCMP(IKEY,'OPT#IONS')+ - INPCMP(IKEY,'!OPT#IONS').NE.0)THEN IF(NWORD.GT.IKEY)THEN DO 60 I=IKEY+1,NWORD IF(INPCMP(I,'LIN#EAR-X').NE.0)THEN LOGX=.FALSE. ELSEIF(INPCMP(I,'LOG#ARITHMIC-X').NE.0)THEN LOGX=.TRUE. ELSEIF(INPCMP(I,'LIN#EAR-Y').NE.0)THEN LOGY=.FALSE. ELSEIF(INPCMP(I,'LOG#ARITHMIC-Y').NE.0)THEN LOGY=.TRUE. ELSEIF(INPCMP(I,'LOG#ARITHMIC-Y').NE.0)THEN LOGY=.FALSE. ELSEIF(INPCMP(I,'GR#ID-DEC#ADES-#ONLY')+ - INPCMP(I,'DEC#ADES-#ONLY-#GRID').NE.0)THEN LGRALL=.FALSE. ELSEIF(INPCMP(I,'COMP#LETE-GR#ID')+ - INPCMP(I,'GR#ID-COMP#LETE').NE.0)THEN LGRALL=.TRUE. ELSEIF(INPCMP(I,'GR#ID-#PLOT').NE.0)THEN LGRID=.TRUE. ELSEIF(INPCMP(I,'NOGR#ID-#PLOT').NE.0)THEN LGRID=.FALSE. ELSEIF(INPCMP(I,'T#IME-S#TAMP').NE.0)THEN LSTAMP=.TRUE. ELSEIF(INPCMP(I,'NOT#IME-S#TAMP').NE.0)THEN LSTAMP=.FALSE. ELSEIF(INPCMP(I,'CL#EAR-BEF#ORE-#PLOT').NE.0)THEN LGCLRB=.TRUE. ELSEIF(INPCMP(I,'NOCL#EAR-BEF#ORE-#PLOT').NE.0)THEN LGCLRB=.FALSE. ELSEIF(INPCMP(I,'CL#EAR-AFT#ER-#PLOT').NE.0)THEN LGCLRA=.TRUE. ELSEIF(INPCMP(I,'NOCL#EAR-AFT#ER-#PLOT').NE.0)THEN LGCLRA=.FALSE. ELSEIF(INPCMP(I,'WAIT-AFT#ER-#PLOT').NE.0)THEN LWAITA=.TRUE. ELSEIF(INPCMP(I,'NOWAIT-AFT#ER-#PLOT').NE.0)THEN LWAITA=.FALSE. ELSEIF(INPCMP(I,'WAIT-BEF#ORE-#PLOT').NE.0)THEN LWAITB=.TRUE. ELSEIF(INPCMP(I,'NOWAIT-BEF#ORE-#PLOT').NE.0)THEN LWAITB=.FALSE. ELSEIF(INPCMP(I,'CLIP-L#INES').NE.0)THEN LGLCLP=.TRUE. ELSEIF(INPCMP(I,'NOCLIP-L#INES').NE.0)THEN LGLCLP=.FALSE. ELSEIF(INPCMP(I,'CLIP-M#ARKERS').NE.0)THEN LGMCLP=.TRUE. ELSEIF(INPCMP(I,'NOCLIP-M#ARKERS').NE.0)THEN LGMCLP=.FALSE. ELSEIF(INPCMP(I,'CLIP-A#REAS').NE.0)THEN LGACLP=.TRUE. ELSEIF(INPCMP(I,'NOCLIP-A#REAS').NE.0)THEN LGACLP=.FALSE. ELSEIF(INPCMP(I,'CLIP-T#EXT').NE.0)THEN LGTCLP=.TRUE. ELSEIF(INPCMP(I,'NOCLIP-T#EXT').NE.0)THEN LGTCLP=.FALSE. ELSEIF(INPCMP(I,'EX#ECUTE-CONTR#OL-#CHARACTERS').NE. - 0)THEN LXCCH=.TRUE. ELSEIF(INPCMP(I,'DISP#LAY-CONTR#OL-#CHARACTERS').NE. - 0)THEN LXCCH=.FALSE. ELSE CALL INPMSG(I,'Not a valid option.') ENDIF 60 CONTINUE CALL INPERR ELSE WRITE(LUNOUT, - '(/'' CURRENT GRAPHICS OPTION SETTINGS:''// - '' Plot a coordinate grid: '',L1/ - '' Complete or decades-only: '',L1/ - '' Time stamp on metafile: '',L1/ - '' Logarithmic scale x-axis: '',L1/ - '' Logarithmic scale y-axis: '',L1/ - '' Clear screen before plot: '',L1/ - '' Clear screen after plot: '',L1/ - '' Wait before plot: '',L1/ - '' Wait after plot: '',L1/ - '' Execute control characters: '',L1/ - '' Clip lines outside plot: '',L1/ - '' Clip markers outside plot: '',L1/ - '' Clip areas outside plot: '',L1/ - '' Clip text outside plot: '',L1/)') - LGRID,LGRALL,LSTAMP,LOGX,LOGY,LGCLRB,LGCLRA, - LWAITB,LWAITA,LXCCH,LGLCLP,LGMCLP,LGACLP,LGTCLP ENDIF *** Set deferral state. ELSEIF(INPCMP(IKEY,'SET-DEF#ERRAL-#STATE')+ - INPCMP(IKEY,'!SET-DEF#ERRAL-#STATE').NE.0)THEN IF(NWORD.NE.IKEY+3)THEN PRINT *,' !!!!!! GRAINP WARNING : Incorrect number'// - ' arguments; ignored.' ELSE * Locate the workstation. CALL INPSTR(IKEY+1,IKEY+1,STRING,NC) DO 100 I=1,NWK IF(WKNAME(I)(1:NCWKNM(I)).EQ.STRING(1:NC))THEN IWK=I GOTO 110 ENDIF 100 CONTINUE CALL INPMSG(IKEY+1,'Not a known workstation.') IWK=-1 110 CONTINUE * Find old values. IF(IWK.GE.1)THEN CALL GQWKDU(IWK,IERR,IDEFD,IUPDD,IDUM1,IDUM2) IF(IERR.NE.0)IDEFD=-1 IF(IERR.NE.0)IUPDD=-1 ELSE IDEFD=-1 IUPDD=-1 ENDIF * Find the deferral and update states. IDEF=-1 IUPD=-1 IF(INPCMP(IKEY+2,'AS-#SOON-#AS-#POSSIBLE')+ - INPCMP(IKEY+2,'ASAP').NE.0)THEN IDEF=0 ELSEIF(INPCMP(IKEY+2,'BEF#ORE-N#EXT-I#NTERACTION-'// - 'GL#OBALLY')+INPCMP(IKEY+2,'BNIG').NE.0)THEN IDEF=1 ELSEIF(INPCMP(IKEY+2,'BEF#ORE-N#EXT-I#NTERACTION-'// - 'LOC#ALLY')+INPCMP(IKEY+2,'BNIL').NE.0)THEN IDEF=2 ELSEIF(INPCMP(IKEY+2,'AT-#SOME-#TIME')+ - INPCMP(IKEY+2,'AST').NE.0)THEN IDEF=3 ELSEIF(INPCMP(IKEY+2,'*').NE.0.AND.IDEFD.GE.0)THEN IDEF=IDEFD ELSE CALL INPMSG(IKEY+2,'Not a valid deferral mode.') ENDIF IF(INPCMP(IKEY+3,'SUP#PRESSED').NE.0)THEN IUPD=0 ELSEIF(INPCMP(IKEY+3,'ALL#OWED').NE.0)THEN IUPD=1 ELSEIF(INPCMP(IKEY+3,'*').NE.0.AND.IUPDD.GE.0)THEN IUPD=IUPDD ELSE CALL INPMSG(IKEY+3,'Not a valid update mode.') ENDIF * Set the new state. IF(IDEF.GE.0.AND.IUPD.GE.0.AND.IWK.GE.0) - CALL GSDS(IWK,IDEF,IUPD) * Show error messages. CALL INPERR ENDIF *** Show a shading map. ELSEIF(INPCMP(IKEY,'SH#ADING-#MAP')+ - INPCMP(IKEY,'SH#ADES-#MAP')+ - INPCMP(IKEY,'!SH#ADING-#MAP')+ - INPCMP(IKEY,'!SH#ADES-#MAP').NE.0)THEN CALL COLSHM *** Stamp string. ELSEIF(INPCMP(IKEY,'STAMP')+ - INPCMP(IKEY,'!STAMP').NE.0)THEN IF(NWORD.EQ.IKEY)THEN WRITE(LUNOUT,'('' Current stamp string: "'',A, - ''".'')') STAMP(1:NCSTMP) ELSE CALL INPSTR(IKEY+1,IKEY+1,STAMP,NCSTMP) ENDIF *** Representation setting and inquiry. ELSEIF(INPCMP(IKEY,'REP#RESENTATION')+ - INPCMP(IKEY,'!REP#RESENTATION').NE.0)THEN CALL GRATTR(IKEY,IFAIL) IF(IFAIL.NE.0)PRINT *,' !!!!!! GRAINP WARNING : Change or'// - ' inquiry of the representation failed.' *** Reset the colour table. ELSEIF(INPCMP(IKEY,'RESET-#COLOURS')+ - INPCMP(IKEY,'!RESET-#COLOURS').NE.0)THEN CALL GRCOLS *** Set the viewport. ELSEIF(INPCMP(IKEY,'VIEW#PORT')+ - INPCMP(IKEY,'!VIEW#PORT').NE.0)THEN * Display if there are no arguments. IF(IKEY.EQ.NWORD)THEN CALL OUTFMT(DISPX0,2,AUX1,NC1,'LEFT') CALL OUTFMT(DISPX1,2,AUX2,NC2,'LEFT') CALL OUTFMT(DISPY0,2,AUX3,NC3,'LEFT') CALL OUTFMT(DISPY1,2,AUX4,NC4,'LEFT') WRITE(LUNOUT,'('' Current viewport:''/ - 5X,A,'' < x < '',A/5X,A,'' < y < '',A)') - AUX1(1:NC1),AUX2(1:NC2),AUX3(1:NC3),AUX4(1:NC4) * Otherwise check there are 4 numbers as arguments. ELSEIF((INPTYP(IKEY+1).NE.1.AND.INPTYP(IKEY+1).NE.2).OR. - (INPTYP(IKEY+2).NE.1.AND.INPTYP(IKEY+2).NE.2).OR. - (INPTYP(IKEY+3).NE.1.AND.INPTYP(IKEY+3).NE.2).OR. - (INPTYP(IKEY+4).NE.1.AND.INPTYP(IKEY+4).NE.2).OR. - NWORD.NE.IKEY+4)THEN PRINT *,' !!!!!! GRAINP WARNING : VIEWPORT has 4'// - ' numeric arguments; viewport not changed.' * Try to interpret the viewport. ELSE CALL INPCHK(IKEY+1,2,IFAIL1) CALL INPCHK(IKEY+2,2,IFAIL2) CALL INPCHK(IKEY+3,2,IFAIL3) CALL INPCHK(IKEY+4,2,IFAIL4) IF(IFAIL1+IFAIL2+IFAIL3+IFAIL4.EQ.0)THEN CALL INPRDR(IKEY+1,DISX0R,DISPX0) CALL INPRDR(IKEY+2,DISY0R,DISPY0) CALL INPRDR(IKEY+3,DISX1R,DISPX1) CALL INPRDR(IKEY+4,DISY1R,DISPY1) IF(DISX0R.GE.0.AND.DISX0R.LE.1.AND. - DISX1R.GE.0.AND.DISX1R.LE.1.AND. - DISY0R.GE.0.AND.DISY0R.LE.1.AND. - DISY1R.GE.0.AND.DISY1R.LE.1.AND. - ABS(DISX0R-DISX1R).GT.0.2.AND. - ABS(DISY0R-DISY1R).GT.0.2)THEN DISPX0=MIN(DISX0R,DISX1R) DISPX1=MAX(DISX0R,DISX1R) DISPY0=MIN(DISY0R,DISY1R) DISPY1=MAX(DISY0R,DISY1R) ELSE PRINT *,' !!!!!! GRAINP WARNING : Viewport'// - ' not entirely within (0,0) - (1,1)'// - ' or too small; viewport not changed.' ENDIF ELSE CALL INPERR PRINT *,' !!!!!! GRAINP WARNING : Viewport not'// - ' changed because of the above errors.' ENDIF ENDIF *** Colour writing to dataset. ELSEIF(INPCMP(IKEY,'WR#ITE-COL#OURS')+ - INPCMP(IKEY,'!WR#ITE-COL#OURS').NE.0)THEN CALL GRCOLW(IKEY,IFAIL) IF(IFAIL.NE.0)PRINT *,' !!!!!! GRAINP WARNING : Writing'// - ' a list of colours to a dataset failed.' *** Representation writing to dataset. ELSEIF(INPCMP(IKEY,'WR#ITE-REP#RESENTATIONS')+ - INPCMP(IKEY,'!WR#ITE-REP#RESENTATIONS').NE.0)THEN CALL GRATTW(IKEY,IFAIL) IF(IFAIL.NE.0)PRINT *,' !!!!!! GRAINP WARNING : Writing'// - ' a graphics representation member failed.' *** Invalid option. ELSE CALL INPSTR(IKEY,IKEY,STRING,NC) PRINT *,' !!!!!! GRAINP WARNING : '//STRING(1:NC)//' is'// - ' not a valid command; it is ignored.' ENDIF *** Either read a new input line or return to the calling section. 1010 CONTINUE *** Next command, if in a sub-section. IF(LOOP)GOTO 10 RETURN *** Inquiry failed. 3000 CONTINUE PRINT *,' !!!!!! GRAINP WARNING : GKS inquiry function failed;'// - ' no output returned.' END +DECK,GRALOG. SUBROUTINE GRALOG(NAME) *----------------------------------------------------------------------- * GRALOG - Routine accumulating data on the plots being produced. * GRAPRT and printing its data when called with an empty name. * VARIABLES : NAME : Description of the plot just completed * LIST : List of the above descriptions * ICOUNT : Counts the number of names entered * (Last changed on 26/ 9/08.) *----------------------------------------------------------------------- implicit none CHARACTER*40 LIST(100) CHARACTER*(*) NAME INTEGER ICOUNT,J +SELF,IF=SAVE. SAVE LIST,ICOUNT +SELF. *** Initialise ICOUNT to 0. DATA ICOUNT/0/ *** Store the information in LIST. IF(ICOUNT.LT.100)THEN ICOUNT=ICOUNT+1 LIST(ICOUNT)=NAME RETURN ENDIF * Issue a warning if 100 plots have been made. IF(ICOUNT.EQ.100)THEN ICOUNT=101 PRINT *,' ------ GRALOG MESSAGE : 100 Plots have been'// - ' made ; information on other plots will not be stored' ENDIF RETURN *** Print the data stored during the run. ENTRY GRAPRT WRITE(*,'(''1'')') IF(ICOUNT.EQ.0)THEN PRINT *,' No plots have been made.' RETURN ENDIF PRINT *,' List of the plots and their frame numbers:' PRINT *,' ==========================================' PRINT *,' ' PRINT *,' Description of the plot Frame number' PRINT *,' ' DO 10 J=1,MIN(100,ICOUNT) PRINT '(2X,A40,I12)',LIST(J),J-1 10 CONTINUE PRINT *,' ' PRINT *,' ' END +DECK,GRALPH. SUBROUTINE GRALPH *----------------------------------------------------------------------- * GRALPH - Switches the screen from graphics to alpha mode. Largely * copied from GKSPACK (J551) written by Ian McLaren. * (Last changed on 13/12/07.) *----------------------------------------------------------------------- +SEQ,PRINTPLOT. *** Check there is at least one workstation active. CALL GQOPS(IOPSTA) IF(IOPSTA.LT.3)THEN IF(LDEBUG)WRITE(10,'('' ++++++ GRALPH DEBUG :'', - '' No active workstations.'')') RETURN ENDIF *** Check that there is at least one workstation with input. CALL GQACWK(0,IERR,NACT,IWK) IWKREQ=-1 DO 20 I=1,NACT CALL GQACWK(I,IERR,IDUM,IWK) * Locate one that has input facilities. CALL GQWKC(IWK,IERR1,ICONID,IWKTYP) CALL GQWKCA(IWKTYP,IERR2,IWKCAT) IF(IWKCAT.EQ.1.OR.IWKCAT.EQ.2)IWKREQ=IWK 20 CONTINUE * Return if not found. IF(IWKREQ.EQ.-1)THEN IF(LDEBUG)WRITE(10,'('' ++++++ GRALPH DEBUG :'', - '' No active workstation with input.'')') RETURN ENDIF +SELF,IF=HIGZ. *** Switch back to alpha mode (HIGZ version). CALL IGSA(IWKREQ) +SELF,IF=CMS,VAX,LINUX,MACOSX,BOINC,IF=GTSGRAL,IF=-HIGZ. *** Switch back to alpha mode (CMS version with GTS-GRAL/GKS). CALL GCGTOA(IWKREQ) +SELF,IF=CMS,IF=-GTSGRAL,IF=-HIGZ. *** Switch back to alpha mode (CMS version with PLOT-10/GKS). DATA PGSW/Z18/ CALL HTIMEO(1000) CALL HWRAS(1,PGSW) CALL HTIMEO(100) +SELF,IF=VAX,IF=ATCGKS,IF=-HIGZ. *** Switch back to alpha mode (Vax version with ATC GKS). CALL GUESC001(IWKREQ,0) +SELF,IF=VAX,IF=-GTSGRAL,IF=-ATCGKS,IF=-HIGZ. *** Switch back to alpha mode (Vax version, for PG terminals). DATA PGSW/'18'X/ RECODE=LIB$WAIT(0.5) WRITE(*,'(1X,A1)') PGSW RECODE=LIB$WAIT(0.1) +SELF. END +DECK,GRAPOL. SUBROUTINE GRAPOL(RMIN1,PMIN1,RMAX1,PMAX1,RTXT,PTXT,TITLE) *---------------------------------------------------------------------- * GRAPOL - Subroutine plotting axis, annotating them and adding * tickmarks along them. * This routine is used for polar coordinate systems. * VARIABLES : RMIN,RMAX : User minimum and maximum for plots in r * PMIN,PMAX : User minimum and maximum for plots in phi * XTXT,YTXT : Title along the x and y axis. * TITLE : Global title. * (Last changed on 27/10/11.) *---------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,PARAMETERS. +SEQ,GRAPHICS. +SEQ,CONSTANTS. +SEQ,PRINTPLOT. REAL XPL(101),YPL(101) CHARACTER*(*) TITLE CHARACTER*40 RTXT,PTXT CHARACTER*66 TEXT CHARACTER*13 TICK *** Define some formats 1010 FORMAT(A40,' Scaling factor= 10^',I2,' ') 1020 FORMAT(A40,' ') *** Define 2 statement function to convert from user to disp frame. XUTOD(X)=DISPX0+(DISPX1-DISPX0)*(X-USERX0)/(USERX1-USERX0) YUTOD(Y)=DISPY0+(DISPY1-DISPY0)*(Y-USERY0)/(USERY1-USERY0) *** Switch to graphics mode. CALL GRGRAF(.TRUE.) *** Define display area of screen. CALL GSVP(1,DISPX0,DISPX1,DISPY0,DISPY1) *** Transform input parameters to polar coordinates. RMIN=EXP(MIN(RMIN1,RMAX1)) RMAX=EXP(MAX(RMIN1,RMAX1)) PMIN=MOD(MIN(PMIN1,PMAX1),2.0*PI) PMAX=MOD(MAX(PMIN1,PMAX1),2.0*PI) *** Check input data, could cause overflows. IF(PMIN.EQ.PMAX)THEN WRITE(10,*) ' !!!!!! GRAPOL WARNING : Phi bounds are'// - ' equal ; set to -pi, pi.' PMIN=-PI PMAX=+PI ENDIF IF(RMIN.EQ.RMAX)THEN WRITE(10,*) ' !!!!!! GRAPOL WARNING : R bounds are'// - ' equal ; set to 1, 10.' RMIN=1.0 RMAX=10.0 ENDIF *** Produce some debugging output IF(LDEBUG)WRITE(10,'('' ++++++ GRAPOL DEBUG : Polar'', - '' bounds are ('',E12.5,'','',E12.5,''), ('',E12.5, - '','',E12.5,'').'')') RMIN,PMIN,RMAX,PMAX *** Prepare a box around the user area and find the area, XMIN=RMIN*COS(PMIN) XMAX=XMIN YMIN=RMIN*SIN(PMIN) YMAX=YMIN DO 10 I=0,49 IF(PMIN.GT.PMAX)THEN ANGLE=PMIN+I*(PMAX-PMIN+2.0*PI)/49.0 ELSE ANGLE=PMIN+I*(PMAX-PMIN)/49.0 ENDIF XPL(I+1)=RMIN*COS(ANGLE) YPL(I+1)=RMIN*SIN(ANGLE) XPL(100-I)=RMAX*COS(ANGLE) YPL(100-I)=RMAX*SIN(ANGLE) XMIN=MIN(XMIN,XPL(I+1),XPL(100-I)) XMAX=MAX(XMAX,XPL(I+1),XPL(100-I)) YMIN=MIN(YMIN,YPL(I+1),YPL(100-I)) YMAX=MAX(YMAX,YPL(I+1),YPL(100-I)) 10 CONTINUE XPL(101)=XPL(1) YPL(101)=YPL(1) * make the box squared. DIFF=YMAX-YMIN-XMAX+XMIN IF(DIFF.GT.0.0)THEN XMAX=XMAX+DIFF/2.0 XMIN=XMIN-DIFF/2.0 ELSE YMAX=YMAX-DIFF/2.0 YMIN=YMIN+DIFF/2.0 ENDIF *** Store frame size. FRXMIN=XMIN FRXMAX=XMAX FRYMIN=YMIN FRYMAX=YMAX *** Define user area in the plot frame. USERX0=XMIN-0.1*(XMAX-XMIN)/(DISPX1-DISPX0-0.2) USERX1=XMAX+0.1*(XMAX-XMIN)/(DISPX1-DISPX0-0.2) USERY0=YMIN-0.1*(YMAX-YMIN)/(DISPY1-DISPY0-0.2) USERY1=YMAX+0.1*(YMAX-YMIN)/(DISPY1-DISPY0-0.2) CALL GSWN(1,USERX0,USERX1,USERY0,USERY1) CALL GSELNT(1) *** Plot the box. CALL GRATTS('BOX-TICKMARKS','POLYLINE') CALL GPL(101,XPL,YPL) *** Find reasonable scale order-of-magnitude, first in r. KR=INT(LOG10(RMAX-RMIN)) KKR=3*INT(LOG10(RMAX-RMIN)/3.0) IF(LOG10(RMAX-RMIN).LT.0.0)KR=KR-1 IF(RMAX-RMIN.LT.1.0)KKR=KKR-3 DR=(RMAX-RMIN)/10.0**KR * And also in phi. IF(PMIN.LT.PMAX)THEN KP=INT(LOG10(180.0*(PMAX-PMIN)/PI)) KKP=3*INT(LOG10(180.0*(PMAX-PMIN)/PI)/3.0) IF(LOG10(180.0*(PMAX-PMIN)/PI).LT.0.0)KP=KP-1 IF(180.0*(PMAX-PMIN)/PI.LT.1.0)KKP=KKP-1 DP=ABS(180.0*(PMAX-PMIN)/PI)/10.0**KP ELSE KP=INT(LOG10(ABS(180.0*(PMAX-PMIN+2.0*PI)/PI))) KKP=3*INT(LOG10(ABS(180.0*(PMAX-PMIN+2.0*PI)/PI))/3.0) IF(LOG10(ABS(180.0*(PMAX-PMIN+2.0*PI)/PI)).LT.0.0)KP=KP-1 IF(ABS(180.0*(PMAX-PMIN+2.0*PI)/PI).LT.1.0)KKP=KKP-1 DP=ABS(180.0*(PMAX-PMIN+2.0*PI)/PI)/10.0**KP ENDIF * Find the distance between 2 tickmarks. IF(DR.LT.2.0)DR=0.1 IF(DR.GE.2.0.AND.DR.LT.5.0)DR=0.2 IF(DR.GE.5.0)DR=0.5 IF(DP.LT.2.0)DP=0.1 IF(DP.GE.2.0.AND.DP.LT.5.0)DP=0.2 IF(DP.GE.5.0)DP=0.5 DR=DR*10.0**KR DP=(PI/180.0)*DP*10.0**KP *** Plot tickmarks and scale on the arcs, compute number of tick marks. IF(PMAX.GT.PMIN)THEN NTICK=(PMAX-PMIN)/DP ELSE NTICK=(PMAX-PMIN+2.0*PI)/DP ENDIF * Set graphics attributes for the labels. CALL GRATTS('NUMBERS','TEXT') * Loop over the tickmarks. DO 20 I=0,NTICK+1 ANGLE=DP*(I+INT(PMIN/DP)) IF(PMIN.GT.PMAX.AND.ANGLE.GT.PMAX+2.0*PI)GOTO 20 IF(PMIN.LE.PMAX.AND.(ANGLE.GT.PMAX.OR.ANGLE.LT.PMIN))GOTO 20 * Plot the grid if requested. IF(LGRID)THEN XPL(1)=RMIN*COS(ANGLE) YPL(1)=RMIN*SIN(ANGLE) XPL(2)=RMAX*COS(ANGLE) YPL(2)=RMAX*SIN(ANGLE) CALL GRATTS('GRID','POLYLINE') CALL GPL(2,XPL,YPL) CALL GRATTS('BOX-TICKMARKS','POLYLINE') ENDIF * Plot tickmarks. XPL(1)=RMIN*COS(ANGLE) YPL(1)=RMIN*SIN(ANGLE) IF(XPL(1)**2+YPL(1)**2.GT.0.0)THEN XPL(2)=XPL(1)*(1.0+0.01*(XMAX-XMIN)/ - SQRT(XPL(1)**2+YPL(1)**2)) YPL(2)=YPL(1)*(1.0+0.01*(XMAX-XMIN)/ - SQRT(XPL(1)**2+YPL(1)**2)) CALL GPL(2,XPL,YPL) ENDIF XPL(1)=RMAX*COS(ANGLE) YPL(1)=RMAX*SIN(ANGLE) IF(XPL(1)**2+YPL(1)**2.GT.0.0)THEN XPL(2)=XPL(1)*(1.0-0.01*(XMAX-XMIN)/ - SQRT(XPL(1)**2+YPL(1)**2)) YPL(2)=YPL(1)*(1.0-0.01*(XMAX-XMIN)/ - SQRT(XPL(1)**2+YPL(1)**2)) CALL GPL(2,XPL,YPL) ENDIF * Bring the angle in the normal range. ANGSCL=MOD(180.0*ANGLE/PI,360.0) IF(ANGSCL.GT.+180.0)ANGSCL=ANGSCL-360.0 IF(ANGSCL.LE.-180.0)ANGSCL=ANGSCL+360.0 * Format the number. CALL OUTFMT(ANGSCL/10.0**KKP,2,TICK,NC,'LEFT') * And plot the number. IF(XPL(1)**2+YPL(1)**2.GT.0.0)THEN XSC=XUTOD((RMAX+0.015*(RMAX-RMIN))*COS(ANGLE)) YSC=YUTOD((RMAX+0.015*(RMAX-RMIN))*SIN(ANGLE)) CALL GSELNT(0) CALL GSCHUP(YPL(2)-YPL(1),XPL(1)-XPL(2)) CALL GSTXAL(1,3) CALL GRTX(XSC,YSC,TICK(1:NC)) CALL GSELNT(1) ENDIF 20 CONTINUE *** Tickmarks and scale on one of the straight segments. NTICK=ABS(RMAX-RMIN)/DR * Loop over the tickmarks. DO 30 I=0,NTICK+1 RVAL=DR*(I+INT(RMIN/DR)) IF(RVAL.GT.RMAX.OR.RVAL.LT.RMIN)GOTO 30 * Optional grid. IF(LGRID)THEN DO 40 J=1,100 XPL(J)=RVAL*COS(PMIN+REAL(J-1)*(PMAX-PMIN)/99.0) YPL(J)=RVAL*SIN(PMIN+REAL(J-1)*(PMAX-PMIN)/99.0) 40 CONTINUE CALL GRATTS('GRID','POLYLINE') CALL GPL(100,XPL,YPL) CALL GRATTS('BOX-TICKMARKS','POLYLINE') ENDIF * Plot the tickmarks, plot scale at the same time. XPL(1)=RVAL*COS(PMIN) YPL(1)=RVAL*SIN(PMIN) IF(XPL(1)**2+YPL(1)**2.GT.0.0)THEN XPL(2)=XPL(1)-YPL(1)*0.01*(XMAX-XMIN)/ - SQRT(XPL(1)**2+YPL(1)**2) YPL(2)=YPL(1)+XPL(1)*0.01*(XMAX-XMIN)/ - SQRT(XPL(1)**2+YPL(1)**2) CALL GPL(2,XPL,YPL) IF(SIN(PMIN).LT.SIN(PMAX))THEN CALL OUTFMT(RVAL/10.0**KKR,2,TICK,NC,'LEFT') XSC=XUTOD(XPL(1)+YPL(1)*0.015*(XMAX-XMIN)/ - SQRT(XPL(1)**2+YPL(1)**2)) YSC=YUTOD(YPL(1)-XPL(1)*0.015*(XMAX-XMIN)/ - SQRT(XPL(1)**2+YPL(1)**2)) CALL GSELNT(0) CALL GSCHUP(YPL(2)-YPL(1),XPL(1)-XPL(2)) CALL GSTXAL(1,3) CALL GRTX(XSC,YSC,TICK(1:NC)) CALL GSELNT(1) ENDIF ENDIF * And tickmarks and perhaps a scale on the other axis. XPL(1)=RVAL*COS(PMAX) YPL(1)=RVAL*SIN(PMAX) IF(XPL(1)**2+YPL(1)**2.GT.0.0)THEN XPL(2)=XPL(1)+YPL(1)*0.01*(XMAX-XMIN)/ - SQRT(XPL(1)**2+YPL(1)**2) YPL(2)=YPL(1)-XPL(1)*0.01*(XMAX-XMIN)/ - SQRT(XPL(1)**2+YPL(1)**2) CALL GPL(2,XPL,YPL) IF(SIN(PMIN).GE.SIN(PMAX))THEN CALL OUTFMT(RVAL/10.0**KKR,2,TICK,NC,'LEFT') XSC=XUTOD(XPL(1)-YPL(1)*0.015*(XMAX-XMIN)/ - SQRT(XPL(1)**2+YPL(1)**2)) YSC=YUTOD(YPL(1)+XPL(1)*0.015*(XMAX-XMIN)/ - SQRT(XPL(1)**2+YPL(1)**2)) CALL GSELNT(0) CALL GSCHUP(YPL(1)-YPL(2),XPL(2)-XPL(1)) CALL GSTXAL(1,3) CALL GRTX(XSC,YSC,TICK(1:NC)) CALL GSELNT(1) ENDIF ENDIF 30 CONTINUE *** Write the titles and the orders of magnitudes at the bottom, CALL GSELNT(0) CALL GSCHUP(0.0,1.0) IF(KKP.NE.0)THEN WRITE(TEXT,1010) PTXT,KKP ELSE WRITE(TEXT,1020) PTXT ENDIF CALL GSTXAL(1,0) CALL GRATTS('LABELS','TEXT') CALL GRTX(0.1,0.01,TEXT) IF(KKR.NE.0)THEN WRITE(TEXT,1010) RTXT,KKR ELSE WRITE(TEXT,1020) RTXT ENDIF CALL GRTX(0.1,0.04,TEXT) CALL GRATTS('TITLE','TEXT') CALL GRTX(0.1,0.97,TITLE) * reset GKS parameters. CALL GSELNT(1) CALL GSTXAL(0,0) *** Reset the bar chart and histogram counters. IGBAR=0 IGHIST=0 END +DECK,GRAREA. SUBROUTINE GRAREA(NIN,XIN,YIN) *----------------------------------------------------------------------- * GRAREA - Draws an area in either log or linear coordinates. * VARIABLES: NU : Number of points * (XU,YU) : Vertices of the area * (Last changed on 22/ 9/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,GRAPHICS. +SEQ,PRINTPLOT. +SEQ,CONSTANTS. +SEQ,PARAMETERS. REAL XIN(*),YIN(*),XU(MXLIST),YU(MXLIST),XPL(MXLIST),YPL(MXLIST), - XOUT(MXLIST),YOUT(MXLIST),XCUR,YCUR,XLAST,YLAST,X0,Y0,X1,Y1, - QOUT,QIN,QFIRST,XFIRST,YFIRST,EPSX,EPSY INTEGER NIN,NU,NPL,NOUT,I,J,II,IFAIL,IMAX,NTOTP,NINP,NTOTM,NINM, - IOUT,IIN,IFIRST,ISTART LOGICAL CROSS,ONLINE,CURIN,LASTIN,ALLIN,ADD(4),IN1,IN2,IN3,IN4, - EDGE1,EDGE2,EDGE3,EDGE4,RESET EXTERNAL CROSS,ONLINE *** Verify array length. IF(NIN.GT.MXLIST)THEN PRINT *,' !!!!!! GRAREA WARNING : Input array too long;'// - ' not plotted.' RETURN ELSEIF(NIN.LE.2)THEN RETURN ENDIF *** Set precisions. IF(LEPSG)THEN EPSX=REAL(EPSGX) EPSY=REAL(EPSGY) RESET=.FALSE. ELSE EPSX=1E-5*(FRXMAX-FRXMIN) EPSY=1E-5*(FRYMAX-FRYMIN) IF(EPSX.LE.0)EPSX=1.0E-5 IF(EPSY.LE.0)EPSY=1.0E-5 CALL EPSSET('SET',DBLE(EPSX),DBLE(EPSY),0.0D0) RESET=.TRUE. ENDIF *** Convert input array to log scales if desired, find starting point. ISTART=0 ALLIN=.TRUE. DO 10 I=1,NIN * Transform x-coordinate if requested. IF(LOGX)THEN IF(XIN(I).LE.0.0)THEN XCUR=FRXMIN-2*ABS(FRXMAX-FRXMIN) ELSE XCUR=LOG10(XIN(I)) ENDIF ELSE XCUR=XIN(I) ENDIF * Transform y-coordinate if requested. IF(LOGY)THEN IF(YIN(I).LE.0.0)THEN YCUR=FRYMIN-2*ABS(FRYMAX-FRYMIN) ELSE YCUR=LOG10(YIN(I)) ENDIF ELSE YCUR=YIN(I) ENDIF * See whether all points are in the box. IF(XCUR.LT.FRXMIN.OR.XCUR.GT.FRXMAX.OR. - YCUR.LT.FRYMIN.OR.YCUR.GT.FRYMAX)ALLIN=.FALSE. * Internal points are good starting points. IF(ISTART.EQ.0.AND. - XCUR.GE.FRXMIN+EPSX.AND.XCUR.LE.FRXMAX-EPSX.AND. - YCUR.GE.FRYMIN+EPSY.AND.YCUR.LE.FRYMAX-EPSY)ISTART=I * Crossings can also be used. IF(I.GT.1)THEN X0=XLAST Y0=YLAST X1=XCUR Y1=YCUR CALL CLIP(X0,Y0,X1,Y1,FRXMIN,FRYMIN,FRXMAX,FRYMAX,IFAIL) IF(ISTART.EQ.0.AND.IFAIL.EQ.0.AND. - 0.5*(X0+X1).GT.FRXMIN+EPSX.AND. - 0.5*(X0+X1).LT.FRXMAX-EPSX.AND. - 0.5*(Y0+Y1).GT.FRYMIN+EPSY.AND. - 0.5*(Y0+Y1).LT.FRYMAX-EPSY)ISTART=I ENDIF * Store the data. XU(I)=XCUR YU(I)=YCUR * Shift "current" to "last". XLAST=XCUR YLAST=YCUR 10 CONTINUE * Store number of points again for convenience. NU=NIN *** If all points are within the area, simply plot. IF(ALLIN)THEN CALL GFA(NU,XU,YU) IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GRAREA DEBUG : All'', - '' points in the area ; plotted without clipping.'')') GOTO 3030 *** No starting point found, check whether box is entirely enclosed. ELSEIF(ISTART.EQ.0)THEN CALL INTERN(NU,XU,YU,FRXMIN,FRYMIN,IN1,EDGE1) CALL INTERN(NU,XU,YU,FRXMAX,FRYMIN,IN2,EDGE2) CALL INTERN(NU,XU,YU,FRXMAX,FRYMAX,IN3,EDGE3) CALL INTERN(NU,XU,YU,FRXMIN,FRYMAX,IN4,EDGE4) IF(IN1.OR.IN2.OR.IN3.OR.IN4.OR. - (EDGE1.AND.EDGE2.AND.EDGE3.AND.EDGE4))THEN XPL(1)=FRXMIN YPL(1)=FRYMIN XPL(2)=FRXMAX YPL(2)=FRYMIN XPL(3)=FRXMAX YPL(3)=FRYMAX XPL(4)=FRXMIN YPL(4)=FRYMAX XPL(5)=FRXMIN YPL(5)=FRYMIN CALL GFA(5,XPL,YPL) IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GRAREA DEBUG :'', - '' Plot frame entirely within area.'')') ENDIF GOTO 3030 ENDIF *** Non-trivial cases: loop over the points. NOUT=0 NPL=0 IFIRST=0 DO 100 II=ISTART-1,ISTART+NU-1 * Reduce II. I=1+MOD(II+NU-1,NU) * Store point. XCUR=XU(I) YCUR=YU(I) * See whether this point is in the area. IF(XCUR.GE.FRXMIN.AND.XCUR.LE.FRXMAX.AND. - YCUR.GE.FRYMIN.AND.YCUR.LE.FRYMAX)THEN CURIN=.TRUE. ELSE CURIN=.FALSE. ENDIF IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GRAREA DEBUG : At point '', - I3,'' ('',I3,''), (x,y)= '',2E12.5,'', in='',L1)') - I,II,XCUR,YCUR,CURIN * For the first point, skip all the rest. IF(II.LT.ISTART)GOTO 110 ** Clip this section to the size of the box. X0=XLAST Y0=YLAST X1=XCUR Y1=YCUR CALL CLIP(X0,Y0,X1,Y1,FRXMIN,FRYMIN,FRXMAX,FRYMAX,IFAIL) * If this is the first point, at least part should be inside. IF(II.EQ.ISTART.AND.IFAIL.NE.0)THEN PRINT *,' !!!!!! GRAREA WARNING : No crossing found'// - ' while expecting one; polygon not drawn.' IF(LGSTOP)THEN OPEN(UNIT=12,FILE='grarea.dat',STATUS='UNKNOWN') WRITE(12,*) EPSGX,EPSGY,EPSGZ,LEPSG WRITE(12,*) FRXMIN,FRYMIN,FRXMAX,FRYMAX WRITE(12,*) NIN DO 200 J=1,NIN WRITE(12,*) XIN(J),YIN(J) 200 CONTINUE CLOSE(12) CALL QUIT ENDIF GOTO 3030 * Store the first point. ELSEIF(II.EQ.ISTART)THEN NPL=1 XPL(NPL)=X0 YPL(NPL)=Y0 IF(LDEBUG)WRITE(LUNOUT,'(26X, - ''Started "plot" buffer with (x,y)='',2E12.5)') - X0,Y0 ENDIF ** Skip processing if the points coincide. IF(ABS(XCUR-XLAST).LE.EPSX.AND.ABS(YCUR-YLAST).LE.EPSY.AND. - II.GT.ISTART)THEN IF(LDEBUG)WRITE(LUNOUT,'(26X,''Coincides with previous'', - '' point, skipped.'')') GOTO 110 ENDIF ** If fully outside the box, add to "out" buffer. IF(IFAIL.NE.0)THEN * Buffer not yet started if the previous point was on the edge. IF(NOUT.LE.0)THEN IF(ONLINE(FRXMIN,FRYMIN,FRXMAX,FRYMIN, - XLAST,YLAST))THEN IOUT=1 QOUT=XLAST-FRXMIN ELSEIF(ONLINE(FRXMAX,FRYMIN,FRXMAX,FRYMAX, - XLAST,YLAST))THEN IOUT=2 QOUT=YLAST-FRYMIN ELSEIF(ONLINE(FRXMAX,FRYMAX,FRXMIN,FRYMAX, - XLAST,YLAST))THEN IOUT=3 QOUT=FRXMAX-XLAST ELSEIF(ONLINE(FRXMIN,FRYMAX,FRXMIN,FRYMIN, - XLAST,YLAST))THEN IOUT=4 QOUT=FRYMAX-YLAST ELSE PRINT *,' !!!!!! GRAREA WARNING : No leaving'// - ' edge found ; polygon not drawn.' GOTO 3030 ENDIF NOUT=1 XOUT(NOUT)=XLAST YOUT(NOUT)=YLAST IF(LDEBUG)WRITE(LUNOUT,'(26X, - ''Box is left via edge '',I1,'', Q='',E12.5, - '', "out" list started.'')') IOUT,QOUT ENDIF * Add the 2nd point to the "out" buffer. IF(NOUT.GE.MXLIST)GOTO 3010 NOUT=NOUT+1 XOUT(NOUT)=XCUR YOUT(NOUT)=YCUR IF(LDEBUG)WRITE(LUNOUT,'(26X, - ''Segment fully outside, added as '',I3, - '' to "out".'')') NOUT GOTO 110 ** If fully inside the box, add to "plot" buffer. ELSEIF(LASTIN.AND.CURIN)THEN IF(NPL.GE.MXLIST)GOTO 3020 NPL=NPL+1 XPL(NPL)=X1 YPL(NPL)=Y1 IF(LDEBUG)WRITE(LUNOUT,'(26X, - ''Segment fully inside, added as '',I3, - '' to "plot".'')') NPL GOTO 110 ENDIF ** We re-enter the box. IF(.NOT.LASTIN)THEN * Determine the re-entrance side and coordinate. IF(ONLINE(FRXMIN,FRYMIN,FRXMAX,FRYMIN,X0,Y0))THEN IIN=1 QIN=X0-FRXMIN ELSEIF(ONLINE(FRXMAX,FRYMIN,FRXMAX,FRYMAX,X0,Y0))THEN IIN=2 QIN=Y0-FRYMIN ELSEIF(ONLINE(FRXMAX,FRYMAX,FRXMIN,FRYMAX,X0,Y0))THEN IIN=3 QIN=FRXMAX-X0 ELSEIF(ONLINE(FRXMIN,FRYMAX,FRXMIN,FRYMIN,X0,Y0))THEN IIN=4 QIN=FRYMAX-Y0 ELSE PRINT *,' !!!!!! GRAREA WARNING : No re-entrance'// - ' edge found ; polygon not drawn.' GOTO 3030 ENDIF * Debugging output. IF(LDEBUG)WRITE(LUNOUT,'(26X, - ''Box entered via edge '',I1,'', Q='',E12.5)') - IIN,QIN * If this is the first segment, simply record it. IF(II.EQ.ISTART)THEN IFIRST=IIN QFIRST=QIN XFIRST=X0 YFIRST=Y0 * Skip in case we re-enter at the point where we left. ELSEIF(IIN.NE.IOUT.OR. - ((IIN.EQ.1.OR.IIN.EQ.3).AND.ABS(QIN-QOUT).GT.EPSX).OR. - ((IIN.EQ.2.OR.IIN.EQ.4).AND.ABS(QIN-QOUT).GT.EPSY))THEN * Add the re-entry point and complete the loop with the leaving point. IF(NOUT.GE.MXLIST)GOTO 3010 NOUT=NOUT+1 XOUT(NOUT)=X0 YOUT(NOUT)=Y0 IF(NOUT.GE.MXLIST)GOTO 3010 NOUT=NOUT+1 XOUT(NOUT)=XOUT(1) YOUT(NOUT)=YOUT(1) * Reduce the list of "out" points. CALL GRARED(NOUT,XOUT,YOUT) IF(NOUT.LE.2)THEN IF(LDEBUG)WRITE(LUNOUT,'(26X,''Number of "out"'', - '' points reduced to '',I3,'' - not adding'', - '' corners.'')') NOUT IF(NOUT.GE.1)THEN IF(NPL.GE.MXLIST)GOTO 3020 NPL=NPL+1 XPL(NPL)=XOUT(1) YPL(NPL)=YOUT(1) ENDIF IF(NOUT.GE.2)THEN IF(NPL.GE.MXLIST)GOTO 3020 NPL=NPL+1 XPL(NPL)=XOUT(2) YPL(NPL)=YOUT(2) ENDIF GOTO 310 ENDIF * Find the corners that are located inside the curve. CALL INTERN(NOUT,XOUT,YOUT,FRXMIN,FRYMIN,IN1,EDGE1) CALL INTERN(NOUT,XOUT,YOUT,FRXMAX,FRYMIN,IN2,EDGE2) CALL INTERN(NOUT,XOUT,YOUT,FRXMAX,FRYMAX,IN3,EDGE3) CALL INTERN(NOUT,XOUT,YOUT,FRXMIN,FRYMAX,IN4,EDGE4) ADD(1)=IN1.OR.EDGE1 ADD(2)=IN2.OR.EDGE2 ADD(3)=IN3.OR.EDGE3 ADD(4)=IN4.OR.EDGE4 * Count corners in the positive direction. IF(IOUT.LT.IIN.OR.(IOUT.EQ.IIN.AND.QOUT.LE.QIN))THEN IMAX=IIN ELSE IMAX=IIN+4 ENDIF NTOTP=0 NINP=0 DO 120 J=IOUT+1,IMAX NTOTP=NTOTP+1 IF(ADD(1+MOD(J-1,4)))NINP=NINP+1 120 CONTINUE * Count corners in the negative direction. IF(IOUT.GT.IIN.OR.(IOUT.EQ.IIN.AND.QOUT.GT.QIN))THEN IMAX=IOUT ELSE IMAX=IOUT+4 ENDIF NTOTM=0 NINM=0 DO 130 J=IMAX,IIN+1,-1 NTOTM=NTOTM+1 IF(ADD(1+MOD(J-1,4)))NINM=NINM+1 130 CONTINUE IF(LDEBUG)WRITE(LUNOUT,'(26X, - ''"out" Buffer contains '',I3,'' points''/ - 26X,''In/Edge flags: 1: '',2L1,'', 2: '',2L1, - '', 3: '',2L1,'', 4: '',2L1/ - 26X,''Corner counts: +: '',I3,''/'',I3, - '', -: '',I3,''/'',I3)') - NOUT,IN1,EDGE1,IN2,EDGE2,IN3,EDGE3,IN4,EDGE4, - NINP,NTOTP,NINM,NTOTM * Add the corners that are located inside the curve. IF(NTOTP+NTOTM.NE.4)THEN PRINT *,' !!!!!! GRAREA WARNING : Error'// - ' counting corners ; polygon not drawn.' IF(LGSTOP)THEN OPEN(UNIT=12,FILE='grarea.dat', - STATUS='UNKNOWN') WRITE(12,*) EPSGX,EPSGY,EPSGZ,LEPSG WRITE(12,*) FRXMIN,FRYMIN,FRXMAX,FRYMAX WRITE(12,*) NIN DO 210 J=1,NIN WRITE(12,*) XIN(J),YIN(J) 210 CONTINUE CLOSE(12) CALL QUIT ENDIF GOTO 3030 ELSEIF(NINP.GT.0.AND.NINP.EQ.NTOTP.AND.NINM.EQ.0)THEN IF(IOUT.LT.IIN.OR.(IOUT.EQ.IIN.AND. - QOUT.LE.QIN))THEN IMAX=IIN ELSE IMAX=IIN+4 ENDIF DO 140 J=IOUT+1,IMAX IF(1+MOD(J-1,4).EQ.1)THEN IF(NPL.GE.MXLIST)GOTO 3020 NPL=NPL+1 XPL(NPL)=FRXMIN YPL(NPL)=FRYMIN IF(LDEBUG)WRITE(LUNOUT,'(26X, - ''Added corner 1 in + sense.'')') ELSEIF(1+MOD(J-1,4).EQ.2)THEN IF(NPL.GE.MXLIST)GOTO 3020 NPL=NPL+1 XPL(NPL)=FRXMAX YPL(NPL)=FRYMIN IF(LDEBUG)WRITE(LUNOUT,'(26X, - ''Added corner 2 in + sense.'')') ELSEIF(1+MOD(J-1,4).EQ.3)THEN IF(NPL.GE.MXLIST)GOTO 3020 NPL=NPL+1 XPL(NPL)=FRXMAX YPL(NPL)=FRYMAX IF(LDEBUG)WRITE(LUNOUT,'(26X, - ''Added corner 3 in + sense.'')') ELSE IF(NPL.GE.MXLIST)GOTO 3020 NPL=NPL+1 XPL(NPL)=FRXMIN YPL(NPL)=FRYMAX IF(LDEBUG)WRITE(LUNOUT,'(26X, - ''Added corner 4 in + sense.'')') ENDIF 140 CONTINUE ELSEIF(NINM.GT.0.AND.NINM.EQ.NTOTM.AND.NINP.EQ.0)THEN IF(IOUT.GT.IIN.OR.(IOUT.EQ.IIN.AND. - QOUT.GT.QIN))THEN IMAX=IOUT ELSE IMAX=IOUT+4 ENDIF DO 150 J=IMAX,IIN+1,-1 IF(1+MOD(J-1,4).EQ.1)THEN IF(NPL.GE.MXLIST)GOTO 3020 NPL=NPL+1 XPL(NPL)=FRXMIN YPL(NPL)=FRYMIN IF(LDEBUG)WRITE(LUNOUT,'(26X, - ''Added corner 1 in - sense.'')') ELSEIF(1+MOD(J-1,4).EQ.2)THEN IF(NPL.GE.MXLIST)GOTO 3020 NPL=NPL+1 XPL(NPL)=FRXMAX YPL(NPL)=FRYMIN IF(LDEBUG)WRITE(LUNOUT,'(26X, - ''Added corner 2 in - sense.'')') ELSEIF(1+MOD(J-1,4).EQ.3)THEN IF(NPL.GE.MXLIST)GOTO 3020 NPL=NPL+1 XPL(NPL)=FRXMAX YPL(NPL)=FRYMAX IF(LDEBUG)WRITE(LUNOUT,'(26X, - ''Added corner 3 in - sense.'')') ELSE IF(NPL.GE.MXLIST)GOTO 3020 NPL=NPL+1 XPL(NPL)=FRXMIN YPL(NPL)=FRYMAX IF(LDEBUG)WRITE(LUNOUT,'(26X, - ''Added corner 4 in - sense.'')') ENDIF 150 CONTINUE ELSEIF(NINM.NE.0.OR.NINP.NE.0)THEN PRINT *,' !!!!!! GRAREA WARNING : Error'// - ' deciding direction ; polygon not drawn.' IF(LGSTOP)THEN OPEN(UNIT=12,FILE='grarea.dat', - STATUS='UNKNOWN') WRITE(12,*) EPSGX,EPSGY,EPSGZ,LEPSG WRITE(12,*) FRXMIN,FRYMIN,FRXMAX,FRYMAX WRITE(12,*) NIN DO 220 J=1,NIN WRITE(12,*) XIN(J),YIN(J) 220 CONTINUE CLOSE(12) CALL QUIT ENDIF GOTO 3030 ENDIF * Resume here if there was no real loop outside. 310 CONTINUE * Reset the out buffer. NOUT=0 * In other cases, still reset the buffer. ELSE IF(LDEBUG)WRITE(LUNOUT,'(26X,''Corner search skipped'', - '', "in" and "out" coincide.'')') NOUT=0 ENDIF * Add the re-entrance point to the "plot" buffer. IF(NPL.GE.MXLIST)GOTO 3020 NPL=NPL+1 XPL(NPL)=X0 YPL(NPL)=Y0 IF(LDEBUG)WRITE(LUNOUT,'(26X, - ''Added first point to "plot" buffer as '',I3)') NPL ENDIF ** Add the end point of the segment to the plot buffer. IF(NPL.GE.MXLIST)GOTO 3020 NPL=NPL+1 XPL(NPL)=X1 YPL(NPL)=Y1 IF(LDEBUG)WRITE(LUNOUT,'(26X, - ''Added last point to "plot" buffer as '',I3)') NPL ** We leave the box. IF(.NOT.CURIN)THEN * Determine the leaving side and coordinate. IF(ONLINE(FRXMIN,FRYMIN,FRXMAX,FRYMIN,X1,Y1))THEN IOUT=1 QOUT=X1-FRXMIN ELSEIF(ONLINE(FRXMAX,FRYMIN,FRXMAX,FRYMAX,X1,Y1))THEN IOUT=2 QOUT=Y1-FRYMIN ELSEIF(ONLINE(FRXMAX,FRYMAX,FRXMIN,FRYMAX,X1,Y1))THEN IOUT=3 QOUT=FRXMAX-X1 ELSEIF(ONLINE(FRXMIN,FRYMAX,FRXMIN,FRYMIN,X1,Y1))THEN IOUT=4 QOUT=FRYMAX-Y1 ELSE PRINT *,' !!!!!! GRAREA WARNING : No leaving'// - ' edge found ; polygon not drawn.' GOTO 3030 ENDIF * Start a list of "out" points. NOUT=1 XOUT(NOUT)=X1 YOUT(NOUT)=Y1 * Also add the point located outside. IF(NOUT.GE.MXLIST)GOTO 3010 NOUT=NOUT+1 XOUT(NOUT)=XCUR YOUT(NOUT)=YCUR * Debugging output. IF(LDEBUG)WRITE(LUNOUT,'(26X, - ''Box is left via edge '',I1,'', Q='',E12.5, - '', "out" list started, point added as 2.'')') - IOUT,QOUT ENDIF ** Shift "current" to "last". 110 CONTINUE XLAST=XCUR YLAST=YCUR LASTIN=CURIN 100 CONTINUE *** End of the list of points, check whether the first point was "out". IF(IFIRST.NE.0.AND. - (IFIRST.NE.IOUT.OR. - ((IFIRST.EQ.1.OR.IFIRST.EQ.3).AND. - ABS(QFIRST-QOUT).GT.EPSX).OR. - ((IFIRST.EQ.2.OR.IFIRST.EQ.4).AND. - ABS(QFIRST-QOUT).GT.EPSY)))THEN IF(LDEBUG)WRITE(LUNOUT,'(26X,''Finishing loop, first'', - '' segment entered over edge '',I2,'' at Q='',E12.5)') - IFIRST,QFIRST * Make sure there is an "out" buffer already. IF(NOUT.EQ.0)THEN PRINT *,' !!!!!! GRAREA WARNING : "out" Buffer'// - ' unexpectedly found empty ; not plotted.' GOTO 3030 ENDIF * Add the first point to the "out" buffer. IF(NOUT.GE.MXLIST)GOTO 3010 NOUT=NOUT+1 XOUT(NOUT)=XFIRST YOUT(NOUT)=YFIRST * Restore the entrance edge and offset. IIN=IFIRST QIN=QFIRST * Close the loop with the first point. IF(NOUT.GE.MXLIST)GOTO 3010 NOUT=NOUT+1 XOUT(NOUT)=XOUT(1) YOUT(NOUT)=YOUT(1) * Reduce the list of "out" points. CALL GRARED(NOUT,XOUT,YOUT) IF(NOUT.LE.2)THEN IF(LDEBUG)WRITE(LUNOUT,'(26X,''Number of "out"'', - '' points reduced to '',I3,'' - not adding'', - '' corners.'')') NOUT IF(NOUT.GE.1)THEN IF(NPL.GE.MXLIST)GOTO 3020 NPL=NPL+1 XPL(NPL)=XOUT(1) YPL(NPL)=YOUT(1) ENDIF IF(NOUT.GE.2)THEN IF(NPL.GE.MXLIST)GOTO 3020 NPL=NPL+1 XPL(NPL)=XOUT(2) YPL(NPL)=YOUT(2) ENDIF GOTO 300 ENDIF * Find the corners that are located inside the curve. CALL INTERN(NOUT,XOUT,YOUT,FRXMIN,FRYMIN,IN1,EDGE1) CALL INTERN(NOUT,XOUT,YOUT,FRXMAX,FRYMIN,IN2,EDGE2) CALL INTERN(NOUT,XOUT,YOUT,FRXMAX,FRYMAX,IN3,EDGE3) CALL INTERN(NOUT,XOUT,YOUT,FRXMIN,FRYMAX,IN4,EDGE4) ADD(1)=IN1.OR.EDGE1 ADD(2)=IN2.OR.EDGE2 ADD(3)=IN3.OR.EDGE3 ADD(4)=IN4.OR.EDGE4 * Count corners in the positive direction. IF(IOUT.LT.IIN.OR.(IOUT.EQ.IIN.AND.QOUT.LE.QIN))THEN IMAX=IIN ELSE IMAX=IIN+4 ENDIF NTOTP=0 NINP=0 DO 160 J=IOUT+1,IMAX NTOTP=NTOTP+1 IF(ADD(1+MOD(J-1,4)))NINP=NINP+1 160 CONTINUE * Count corners in the negative direction. IF(IOUT.GT.IIN.OR.(IOUT.EQ.IIN.AND.QOUT.GT.QIN))THEN IMAX=IOUT ELSE IMAX=IOUT+4 ENDIF NTOTM=0 NINM=0 DO 170 J=IMAX,IIN+1,-1 NTOTM=NTOTM+1 IF(ADD(1+MOD(J-1,4)))NINM=NINM+1 170 CONTINUE IF(LDEBUG)WRITE(LUNOUT,'(26X, - ''"out" Buffer contains '',I3,'' points''/ - 26X,''In/Edge flags: 1: '',2L1,'', 2: '',2L1, - '', 3: '',2L1,'', 4: '',2L1/ - 26X,''Corner counts: +: '',I3,''/'',I3, - '', -: '',I3,''/'',I3)') - NOUT,IN1,EDGE1,IN2,EDGE2,IN3,EDGE3,IN4,EDGE4, - NINP,NTOTP,NINM,NTOTM * Add the corners that are located inside the curve. IF(NTOTP+NTOTM.NE.4)THEN PRINT *,' !!!!!! GRAREA WARNING : Error'// - ' counting corners ; polygon not drawn.' GOTO 3030 ELSEIF(NINP.GT.0.AND.NINP.EQ.NTOTP.AND.NINM.EQ.0)THEN IF(IOUT.LT.IIN.OR.(IOUT.EQ.IIN.AND. - QOUT.LE.QIN))THEN IMAX=IIN ELSE IMAX=IIN+4 ENDIF DO 180 J=IOUT+1,IMAX IF(1+MOD(J-1,4).EQ.1)THEN IF(NPL.GE.MXLIST)GOTO 3020 NPL=NPL+1 XPL(NPL)=FRXMIN YPL(NPL)=FRYMIN IF(LDEBUG)WRITE(LUNOUT,'(26X, - ''Added corner 1 in + sense.'')') ELSEIF(1+MOD(J-1,4).EQ.2)THEN IF(NPL.GE.MXLIST)GOTO 3020 NPL=NPL+1 XPL(NPL)=FRXMAX YPL(NPL)=FRYMIN IF(LDEBUG)WRITE(LUNOUT,'(26X, - ''Added corner 2 in + sense.'')') ELSEIF(1+MOD(J-1,4).EQ.3)THEN IF(NPL.GE.MXLIST)GOTO 3020 NPL=NPL+1 XPL(NPL)=FRXMAX YPL(NPL)=FRYMAX IF(LDEBUG)WRITE(LUNOUT,'(26X, - ''Added corner 3 in + sense.'')') ELSE IF(NPL.GE.MXLIST)GOTO 3020 NPL=NPL+1 XPL(NPL)=FRXMIN YPL(NPL)=FRYMAX IF(LDEBUG)WRITE(LUNOUT,'(26X, - ''Added corner 4 in + sense.'')') ENDIF 180 CONTINUE ELSEIF(NINM.GT.0.AND.NINM.EQ.NTOTM.AND.NINP.EQ.0)THEN IF(IOUT.GT.IIN.OR.(IOUT.EQ.IIN.AND. - QOUT.GT.QIN))THEN IMAX=IOUT ELSE IMAX=IOUT+4 ENDIF DO 190 J=IMAX,IIN+1,-1 IF(1+MOD(J-1,4).EQ.1)THEN IF(NPL.GE.MXLIST)GOTO 3020 NPL=NPL+1 XPL(NPL)=FRXMIN YPL(NPL)=FRYMIN IF(LDEBUG)WRITE(LUNOUT,'(26X, - ''Added corner 1 in - sense.'')') ELSEIF(1+MOD(J-1,4).EQ.2)THEN IF(NPL.GE.MXLIST)GOTO 3020 NPL=NPL+1 XPL(NPL)=FRXMAX YPL(NPL)=FRYMIN IF(LDEBUG)WRITE(LUNOUT,'(26X, - ''Added corner 2 in - sense.'')') ELSEIF(1+MOD(J-1,4).EQ.3)THEN IF(NPL.GE.MXLIST)GOTO 3020 NPL=NPL+1 XPL(NPL)=FRXMAX YPL(NPL)=FRYMAX IF(LDEBUG)WRITE(LUNOUT,'(26X, - ''Added corner 3 in - sense.'')') ELSE IF(NPL.GE.MXLIST)GOTO 3020 NPL=NPL+1 XPL(NPL)=FRXMIN YPL(NPL)=FRYMAX IF(LDEBUG)WRITE(LUNOUT,'(26X, - ''Added corner 4 in - sense.'')') ENDIF 190 CONTINUE ELSEIF(NINM.NE.0.OR.NINP.NE.0)THEN PRINT *,' !!!!!! GRAREA WARNING : Error'// - ' deciding direction ; polygon not drawn.' IF(LGSTOP)THEN OPEN(UNIT=12,FILE='grarea.dat',STATUS='UNKNOWN') WRITE(12,*) EPSGX,EPSGY,EPSGZ,LEPSG WRITE(12,*) FRXMIN,FRYMIN,FRXMAX,FRYMAX WRITE(12,*) NIN DO 230 J=1,NIN WRITE(12,*) XIN(J),YIN(J) 230 CONTINUE CLOSE(12) CALL QUIT ENDIF GOTO 3030 ENDIF ENDIF *** And plot the buffer. 300 CONTINUE IF(NPL.GT.2)CALL GFA(NPL,XPL,YPL) GOTO 3030 *** Buffer overflows. 3010 CONTINUE PRINT *,' !!!!!! GRAREA WARNING : Overflow of "out" buffer;'// - ' polygon not plotted.' GOTO 3030 3020 CONTINUE PRINT *,' !!!!!! GRAREA WARNING : Overflow of "plot" buffer;'// - ' polygon not plotted.' GOTO 3030 *** Termination. 3030 CONTINUE IF(RESET)CALL EPSSET('RESET',0.0D0,0.0D0,0.0D0) END +DECK,GRARED. SUBROUTINE GRARED(NPL,XPL,YPL) *----------------------------------------------------------------------- * GRARED - Removes duplicate branches from a curve. * (Last changed on 2/ 2/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PARAMETERS. INTEGER NPL,I,J,NNEW,JCUT REAL XPL(NPL),YPL(NPL),EPSX,EPSY,XMIN,YMIN,XMAX,YMAX LOGICAL MARK(MXLIST),ONLINE EXTERNAL ONLINE *** Check number of points. IF(NPL.GT.MXLIST)THEN PRINT *,' !!!!!! GRARED WARNING : Too many points.' RETURN ELSEIF(NPL.LT.3)THEN RETURN ENDIF *** Set tolerances. IF(LEPSG)THEN EPSX=EPSGX EPSY=EPSGY ELSE * Compute range. XMIN=XPL(1) XMAX=XPL(1) YMIN=YPL(1) YMAX=YPL(1) DO 90 I=2,NPL XMIN=MIN(XMIN,XPL(I)) XMAX=MAX(XMAX,XPL(I)) YMIN=MIN(YMIN,YPL(I)) YMAX=MAX(YMAX,YPL(I)) 90 CONTINUE * Set epsilons accordingly. EPSX=1.0E-4*ABS(XMAX-XMIN) EPSY=1.0E-4*ABS(YMAX-YMIN) IF(EPSX.LE.0)EPSX=1.0E-4 IF(EPSY.LE.0)EPSY=1.0E-4 ENDIF *** Make a first marker list. 100 CONTINUE DO 10 I=1,NPL MARK(I)=.FALSE. 10 CONTINUE *** Find a point that is surrounded on both side by equal points. DO 20 I=1,NPL JCUT=0 DO 30 J=1,NPL/2 IF( ABS(XPL(1+MOD(I+J-1 ,NPL))- - XPL(1+MOD(I-J-1+NPL,NPL))).GT.EPSX.OR. - ABS(YPL(1+MOD(I+J-1 ,NPL))- - YPL(1+MOD(I-J-1+NPL,NPL))).GT.EPSY)GOTO 40 JCUT=J 30 CONTINUE 40 CONTINUE * See whether we found one. IF(JCUT.GT.0)THEN C print *,' Cutting a tail of ',JCUT,' points.' DO 70 J=I-JCUT+1,I+JCUT MARK(1+MOD(J-1+NPL,NPL))=.TRUE. 70 CONTINUE GOTO 50 ENDIF 20 CONTINUE *** See whether there are partial returns. DO 80 I=1,NPL IF(ONLINE( - XPL(1+MOD(I-1 ,NPL)),YPL(1+MOD(I-1 ,NPL)), - XPL(1+MOD(I ,NPL)),YPL(1+MOD(I ,NPL)), - XPL(1+MOD(I-2+NPL,NPL)),YPL(1+MOD(I-2+NPL,NPL))).OR. - ONLINE( - XPL(1+MOD(I-1 ,NPL)),YPL(1+MOD(I-1 ,NPL)), - XPL(1+MOD(I-2+NPL,NPL)),YPL(1+MOD(I-2+NPL,NPL)), - XPL(1+MOD(I ,NPL)),YPL(1+MOD(I ,NPL))))THEN MARK(1+MOD(I-1 ,NPL))=.TRUE. C print *,' Cutting a partial return.' GOTO 50 ENDIF 80 CONTINUE RETURN *** Eliminate the piece. 50 CONTINUE NNEW=0 DO 60 I=1,NPL IF(MARK(I))GOTO 60 NNEW=NNEW+1 XPL(NNEW)=XPL(I) YPL(NNEW)=YPL(I) 60 CONTINUE NPL=NNEW GOTO 100 END +DECK,GRATTR. SUBROUTINE GRATTR(IKEY,IFAIL) *----------------------------------------------------------------------- * GRATTR - Updates the attribute list for the various sorts of output. * (Last changed on 22/ 3/12.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,GRAPHICS. +SEQ,PRINTPLOT. CHARACTER*(MXINCH) STRING CHARACTER*(MXNAME) FILE CHARACTER*29 REMARK CHARACTER*8 TIME,DATE,MEMBER CHARACTER*80 AUX,AUX1,AUX2 CHARACTER*(*) ITEM,TYPE,COLOUR LOGICAL POLYL,POLYM,TEXT,AREA,EXIS,DSNCMP,EXMEMB INTEGER INPTYP,INPCMP,INPCMX,IKEY,IFAIL,IFAIL1,IFAIL2,I,IWKID, - INEXT,NWORD,NCSTR,NITEM,NSEEN,NUPDAT,NC,NCMEMB,NCFILE,NCREM, - IOS,NC1,NC2,ICOL,FSTY,FONT,PREC REAL WIDTH,FPAS1,FPAS2,FREF1,FREF2,EXPAN,HEIGHT,SPACE,SIZE EXTERNAL INPTYP,INPCMP,INPCMX,DSNCMP *** Buffer declarations, first the sizes. INTEGER MXPLBU,MXPMBU,MXTXBU,MXFABU PARAMETER(MXPLBU=60,MXPMBU=60,MXTXBU=60,MXFABU=60) * PolyLine attributes. REAL LINWID(MXPLBU),LWR INTEGER LINTYP(MXPLBU),LINCOL(MXPLBU),LTR,LCR,NLIN CHARACTER*20 LINNAM(MXPLBU) * PolyMarker attributes. REAL MRKSIZ(MXPMBU),MSR INTEGER MRKTYP(MXPMBU),MRKCOL(MXPMBU),MTR,MCR,NMRK CHARACTER*20 MRKNAM(MXPMBU) * Text attributes. REAL TXTEXP(MXTXBU),TXTSPA(MXTXBU),TXTHGT(MXTXBU),TER,TSR,THR INTEGER TXTFNT(MXTXBU),TXTPRC(MXTXBU),TXTCOL(MXTXBU),TFR,TPR,TCR, - NTXT CHARACTER*20 TXTNAM(MXTXBU) * Fill Area attributes. REAL FARPAS(2,MXFABU),FARREF(2,MXFABU),FPXR,FPYR,FRXR,FRYR INTEGER FARINT(MXFABU),FARSTY(MXFABU),FARCOL(MXFABU),FIR,FSR,FCR, - NFAR CHARACTER*20 FARNAM(MXFABU) +SELF,IF=SAVE. * Ensure the contents is kept across routine calls. SAVE NLIN,LINNAM,LINWID,LINTYP,LINCOL, - NMRK,MRKNAM,MRKSIZ,MRKTYP,MRKCOL, - NTXT,TXTNAM,TXTEXP,TXTSPA,TXTHGT,TXTFNT,TXTPRC,TXTCOL, - NFAR,FARNAM,FARPAS,FARREF,FARINT,FARSTY,FARCOL +SELF. *** Initial values for the attributes, start with polyline. DATA NLIN /42/ DATA (LINNAM(I),LINWID(I),LINTYP(I),LINCOL(I),I=1,42) / - 'AUGER-#ELECTRON ', 1.00, 2, 1, - 'BOX-#TICKMARKS ', 1.00, 1, 1, - 'COM#MENT ', 1.00, 2, 1, - 'CON#TOUR-HIGH#LIGHT ', 1.00, 1, 1, - 'CON#TOUR-NORM#AL ', 1.00, 1, 1, - 'DASH-DOT#TED ', 1.00, 4, 1, - 'DASH#ED ', 1.00, 2, 1, - 'DELTA-#ELECTRON ', 1.00, 2, 1, - 'DOT#TED ', 1.00, 3, 1, - 'DR#IFT-L#INE ', 1.00, 1, 1, - 'E-DR#IFT-L#INE ', 1.00, 1, 1, - 'ERR#OR-BAR ', 1.00, 1, 1, - 'ERR#OR-BAND ', 1.00, 1, 1, - 'FAT2 ', 2.00, 1, 1, - 'FAT3 ', 3.00, 1, 1, - 'FAT4 ', 4.00, 1, 1, - 'FAT5 ', 5.00, 1, 1, - 'FAT6 ', 6.00, 1, 1, - 'F#UNCTION-1 ', 1.00, 1, 1, - 'F#UNCTION-2 ', 1.00, 2, 1, - 'F#UNCTION-3 ', 1.00, 3, 1, - 'F#UNCTION-4 ', 1.00, 4, 1, - 'F#UNCTION-5 ', 1.00, 1, 1, - 'F#UNCTION-6 ', 1.00, 2, 1, - 'F#UNCTION-7 ', 1.00, 3, 1, - 'GR#ID ', 1.00, 3, 1, - 'HIST#OGRAM-1 ', 1.00, 1, 1, - 'HIST#OGRAM-2 ', 1.00, 2, 1, - 'HIST#OGRAM-3 ', 1.00, 3, 1, - 'HIST#OGRAM-4 ', 1.00, 4, 1, - 'HIST#OGRAM-5 ', 1.00, 1, 1, - 'HIST#OGRAM-6 ', 1.00, 2, 1, - 'HIST#OGRAM-7 ', 1.00, 3, 1, - 'ION-DR#IFT-L#INE ', 1.00, 1, 1, - 'ISO#CHRONS ', 1.00, 2, 1, - 'OUT#LINE ', 1.00, 1, 1, - 'PHOTON ', 1.00, 3, 1, - 'PL#ANES ', 1.00, 1, 1, - 'SOLID ', 1.00, 1, 1, - 'STR#IPS ', 3.00, 1, 1, - 'TR#ACK ', 1.00, 2, 1, - 'TUBE ', 1.00, 1, 1/ * Next the polymarkers. DATA NMRK /27/ DATA (MRKNAM(I),MRKSIZ(I),MRKTYP(I),MRKCOL(I),I=1,27) / - 'S-WIRE ', 1.00, 4, 1, - 'P-WIRE ', 1.00, 5, 1, - 'C-WIRE ', 1.00, 2, 1, - 'OTH#ER-WIRE ', 1.00, 3, 1, - 'ISO#CHRONS ', 1.00, 3, 1, - 'F#UNCTION-1 ', 1.00, 3, 1, - 'F#UNCTION-2 ', 1.00, 4, 1, - 'F#UNCTION-3 ', 1.00, 2, 1, - 'F#UNCTION-4 ', 1.00, 1, 1, - 'F#UNCTION-5 ', 1.00, 3, 1, - 'F#UNCTION-6 ', 1.00, 4, 1, - 'F#UNCTION-7 ', 1.00, 2, 1, - 'TR#ACK ', 1.00, 3, 1, - 'PHOTON ', 1.00, 3, 1, - 'DELTA-#ELECTRON ', 0.25, 4, 1, - 'AUGER-#ELECTRON ', 0.25, 2, 1, - 'DOT ', 1.00, 1, 1, - 'PLUS ', 1.00, 2, 1, - 'AST#ERISK ', 1.00, 3, 1, - 'CIRC#LE ', 1.00, 4, 1, - 'CR#OSS ', 1.00, 5, 1, - 'EL#ASTIC ', 1.00, 1, 1, - 'SUP#ER-#ELASTIC ', 1.00, 2, 1, - 'INEL#ASTIC ', 1.00, 5, 1, - 'EXC#ITATION ', 1.00, 6, 1, - 'ION#ISATION ', 1.00, 4, 1, - 'ATT#ACHMENT ', 1.00, 3, 1/ * Next the text. +SELF,IF=GTSGRAL. DATA NTXT /22/ DATA (TXTNAM(I),TXTEXP(I),TXTSPA(I),TXTHGT(I),TXTFNT(I), - TXTPRC(I),TXTCOL(I),I=1,22) / - 'COM#MENT ', 1.00, 0.00, 0.013, 1, 1, 1, - 'CONT#OUR-#LABELS ', 1.00, 0.00, 0.010, 1, 1, 1, - 'LAB#ELS ', 1.00, 0.00, 0.025, 1, 1, 1, - 'F#UNCTION-1 ', 1.00, 0.00, 0.025, 1, 1, 1, - 'F#UNCTION-2 ', 1.00, 0.00, 0.025, 1, 1, 1, - 'F#UNCTION-3 ', 1.00, 0.00, 0.025, 1, 1, 1, - 'F#UNCTION-4 ', 1.00, 0.00, 0.025, 1, 1, 1, - 'F#UNCTION-5 ', 1.00, 0.00, 0.025, 1, 1, 1, - 'F#UNCTION-6 ', 1.00, 0.00, 0.025, 1, 1, 1, - 'F#UNCTION-7 ', 1.00, 0.00, 0.025, 1, 1, 1, - 'MES#SAGE ', 1.00, 0.00, 0.010, 1, 1, 1, - 'NUM#BERS ', 1.00, 0.00, 0.015, 1, 1, 1, - 'TIT#LE ', 1.00, 0.00, 0.025, 1, 1, 1, - 'PR#ESTIGE ', 1.00, 0.00, 0.020, -2, 2, 1, - 'BIG ', 1.00, 0.00, 0.020, -3, 2, 1, - 'SM#ALL ', 1.00, 0.00, 0.020, -3, 2, 1, - 'TIMES-ROM#AN ', 1.00, 0.00, 0.020, -3, 2, 1, - 'TIMES-IT#ALIC ', 1.00, 0.00, 0.020, -104, 2, 1, - 'GR#EEK ', 1.00, 0.00, 0.020, -13, 2, 1, - 'GR#EEK-IT#ALIC ', 1.00, 0.00, 0.020, -113, 2, 1, - 'GOTH#IC ', 1.00, 0.00, 0.020, -9, 2, 1, - 'GOTH#IC-IT#ALIC ', 1.00, 0.00, 0.020, -109, 2, 1/ +SELF,IF=HIGZ. DATA NTXT /28/ DATA (TXTNAM(I),TXTEXP(I),TXTSPA(I),TXTHGT(I),TXTFNT(I), - TXTPRC(I),TXTCOL(I),I=1,28) / - 'COM#MENT ', 1.00, 0.00, 0.013, 0, 2, 1, - 'CONT#OUR-#LABELS ', 1.00, 0.00, 0.010, 0, 2, 1, - 'LAB#ELS ', 1.00, 0.00, 0.025, 0, 2, 1, - 'F#UNCTION-1 ', 1.00, 0.00, 0.025, 0, 2, 1, - 'F#UNCTION-2 ', 1.00, 0.00, 0.025, 0, 2, 1, - 'F#UNCTION-3 ', 1.00, 0.00, 0.025, 0, 2, 1, - 'F#UNCTION-4 ', 1.00, 0.00, 0.025, 0, 2, 1, - 'F#UNCTION-5 ', 1.00, 0.00, 0.025, 0, 2, 1, - 'F#UNCTION-6 ', 1.00, 0.00, 0.025, 0, 2, 1, - 'F#UNCTION-7 ', 1.00, 0.00, 0.025, 0, 2, 1, - 'MES#SAGE ', 1.00, 0.00, 0.010, 0, 2, 1, - 'NUM#BERS ', 1.00, 0.00, 0.015, 0, 2, 1, - 'TIT#LE ', 1.00, 0.00, 0.025, 0, 2, 1, - 'HIGZ-#SOFTWARE ', 1.00, 0.00, 0.020, 0, 2, 1, - 'TIM#ES-RO#MAN ', 1.00, 0.00, 0.020, -13, 2, 1, - 'TIM#ES-IT#ALIC ', 1.00, 0.00, 0.020, -1, 2, 1, - 'TIM#ES-BOLD-R#OMAN ', 1.00, 0.00, 0.020, -2, 2, 1, - 'TIM#ES-BOLD-I#TALIC ', 1.00, 0.00, 0.020, -3, 2, 1, - 'HELV#ETICA ', 1.00, 0.00, 0.020, -4, 2, 1, - 'HELV#ETICA-O#BLIQUE ', 1.00, 0.00, 0.020, -5, 2, 1, - 'HELV#ETICA-B#OLD ', 1.00, 0.00, 0.020, -6, 2, 1, - 'HELV#ETICA-B#OLD-O#B', 1.00, 0.00, 0.020, -7, 2, 1, - 'COUR#IER ', 1.00, 0.00, 0.020, -8, 2, 1, - 'COUR#IER-O#BLIQUE ', 1.00, 0.00, 0.020, -9, 2, 1, - 'COUR#IER-B#OLD ', 1.00, 0.00, 0.020, -10, 2, 1, - 'COUR#IER-B#OLD-O#BLI', 1.00, 0.00, 0.020, -11, 2, 1, - 'SYM#BOL ', 1.00, 0.00, 0.020, -12, 2, 1, - 'ZAPF#DINGBATS ', 1.00, 0.00, 0.020, -14, 2, 1/ +SELF,IF=-HIGZ,IF=-GTSGRAL. DATA NTXT /13/ DATA (TXTNAM(I),TXTEXP(I),TXTSPA(I),TXTHGT(I),TXTFNT(I), - TXTPRC(I),TXTCOL(I),I=1,13) / - 'COM#MENT ', 1.00, 0.00, 0.013, 1, 1, 1, - 'CONT#OUR-#LABELS ', 1.00, 0.00, 0.010, 1, 1, 1, - 'LAB#ELS ', 1.00, 0.00, 0.025, 1, 1, 1, - 'F#UNCTION-1 ', 1.00, 0.00, 0.025, 1, 1, 1, - 'F#UNCTION-2 ', 1.00, 0.00, 0.025, 1, 1, 1, - 'F#UNCTION-3 ', 1.00, 0.00, 0.025, 1, 1, 1, - 'F#UNCTION-4 ', 1.00, 0.00, 0.025, 1, 1, 1, - 'F#UNCTION-5 ', 1.00, 0.00, 0.025, 1, 1, 1, - 'F#UNCTION-6 ', 1.00, 0.00, 0.025, 1, 1, 1, - 'F#UNCTION-7 ', 1.00, 0.00, 0.025, 1, 1, 1, - 'MES#SAGE ', 1.00, 0.00, 0.010, 1, 1, 1, - 'NUM#BERS ', 1.00, 0.00, 0.015, 1, 1, 1, - 'TIT#LE ', 1.00, 0.00, 0.025, 1, 1, 1/ +SELF. * And finally the fill area. DATA NFAR /34/ DATA (FARNAM(I),FARPAS(1,I),FARPAS(2,I),FARREF(1,I),FARREF(2,I), - FARINT(I),FARSTY(I),FARCOL(I),I=1,34) / +SELF,IF=GTSGRAL. - 'COND#UCTORS-1 ', 1.00, 1.00, 0.00, 0.00, 3,-111, 1, - 'COND#UCTORS-2 ', 1.00, 1.00, 0.00, 0.00, 3,-111, 1, - 'COND#UCTORS-3 ', 1.00, 1.00, 0.00, 0.00, 3,-111, 1, - 'DIEL#ECTRICA-1 ', 1.00, 1.00, 0.00, 0.00, 3,-111, 1, - 'DIEL#ECTRICA-2 ', 1.00, 1.00, 0.00, 0.00, 3,-111, 1, - 'DIEL#ECTRICA-3 ', 1.00, 1.00, 0.00, 0.00, 3,-111, 1, - 'OUT#SIDE-AREA ', 1.00, 1.00, 0.00, 0.00, 3,-111, 1, - 'PLA#NES ', 1.00, 1.00, 0.00, 0.00, 3,-111, 1, - 'STR#IPS ', 1.00, 1.00, 0.00, 0.00, 3,-111, 1, - 'TUBE ', 1.00, 1.00, 0.00, 0.00, 3,-111, 1, +SELF,IF=HIGZ. - 'COND#UCTORS-1 ', 1.00, 1.00, 0.00, 0.00, 3, 354, 1, - 'COND#UCTORS-2 ', 1.00, 1.00, 0.00, 0.00, 3, 354, 1, - 'COND#UCTORS-3 ', 1.00, 1.00, 0.00, 0.00, 3, 354, 1, - 'DIEL#ECTRICA-1 ', 1.00, 1.00, 0.00, 0.00, 3, 345, 1, - 'DIEL#ECTRICA-2 ', 1.00, 1.00, 0.00, 0.00, 3, 345, 1, - 'DIEL#ECTRICA-3 ', 1.00, 1.00, 0.00, 0.00, 3, 345, 1, - 'OUT#SIDE-AREA ', 1.00, 1.00, 0.00, 0.00, 3, 305, 1, - 'PLA#NES ', 1.00, 1.00, 0.00, 0.00, 3, 354, 1, - 'STR#IPS ', 1.00, 1.00, 0.00, 0.00, 3, 304, 1, - 'TUBE ', 1.00, 1.00, 0.00, 0.00, 3, 357, 1, +SELF,IF=-HIGZ,IF=-GTSGRAL. - 'COND#UCTORS-1 ', 1.00, 1.00, 0.00, 0.00, 3, 0, 1, - 'COND#UCTORS-2 ', 1.00, 1.00, 0.00, 0.00, 3, 0, 1, - 'COND#UCTORS-3 ', 1.00, 1.00, 0.00, 0.00, 3, 0, 1, - 'DIEL#ECTRICA-1 ', 1.00, 1.00, 0.00, 0.00, 3, 0, 1, - 'DIEL#ECTRICA-2 ', 1.00, 1.00, 0.00, 0.00, 3, 0, 1, - 'DIEL#ECTRICA-3 ', 1.00, 1.00, 0.00, 0.00, 3, 0, 1, - 'OUT#SIDE-AREA ', 1.00, 1.00, 0.00, 0.00, 3, 0, 1, - 'PLA#NES ', 1.00, 1.00, 0.00, 0.00, 3, 0, 1, - 'STR#IPS ', 1.00, 1.00, 0.00, 0.00, 3, 0, 1, - 'TUBE ', 1.00, 1.00, 0.00, 0.00, 3, 0, 1, +SELF. - 'BAR#CHART-1 ', 1.00, 1.00, 0.00, 0.00, 0, 0, 1, - 'BAR#CHART-2 ', 1.00, 1.00, 0.00, 0.00, 0, 0, 1, - 'BAR#CHART-3 ', 1.00, 1.00, 0.00, 0.00, 0, 0, 1, - 'BAR#CHART-4 ', 1.00, 1.00, 0.00, 0.00, 0, 0, 1, - 'BAR#CHART-5 ', 1.00, 1.00, 0.00, 0.00, 0, 0, 1, - 'BAR#CHART-6 ', 1.00, 1.00, 0.00, 0.00, 0, 0, 1, - 'BAR#CHART-7 ', 1.00, 1.00, 0.00, 0.00, 0, 0, 1, - 'BOX-#TICKMARKS ', 1.00, 1.00, 0.00, 0.00, 0, 0, 1, - 'WIR#ES ', 1.00, 1.00, 0.00, 0.00, 0, 0, 1, - 'ERR#OR-BAR ', 1.00, 1.00, 0.00, 0.00, 0, 0, 1, - 'ERR#OR-BAND ', 1.00, 1.00, 0.00, 0.00, 0, 0, 1, - 'LABEL ', 1.00, 1.00, 0.00, 0.00, 3, 0, 1, - 'MATERIAL-1 ', 1.00, 1.00, 0.00, 0.00, 0, 0, 1, - 'MATERIAL-2 ', 1.00, 1.00, 0.00, 0.00, 0, 0, 1, - 'MATERIAL-3 ', 1.00, 1.00, 0.00, 0.00, 0, 0, 1, - 'MATERIAL-4 ', 1.00, 1.00, 0.00, 0.00, 0, 0, 1, - 'MATERIAL-5 ', 1.00, 1.00, 0.00, 0.00, 0, 0, 1, - 'F#UNCTION-1 ', 1.00, 1.00, 0.00, 0.00, 0, 0, 1, - 'F#UNCTION-2 ', 1.00, 1.00, 0.00, 0.00, 0, 0, 1, - 'F#UNCTION-3 ', 1.00, 1.00, 0.00, 0.00, 0, 0, 1, - 'F#UNCTION-4 ', 1.00, 1.00, 0.00, 0.00, 0, 0, 1, - 'F#UNCTION-5 ', 1.00, 1.00, 0.00, 0.00, 0, 0, 1, - 'F#UNCTION-6 ', 1.00, 1.00, 0.00, 0.00, 0, 0, 1, - 'F#UNCTION-7 ', 1.00, 1.00, 0.00, 0.00, 0, 0, 1/ *** Assume the routine fails. IFAIL=1 *** Get the number of words. CALL INPNUM(NWORD) *** Workstation id. IWKID=1 *** Starting values. LWR=-1.0 LTR=0 LCR=-1 MSR=-1.0 MTR=0 MCR=-1 TER=-1.0 TSR=-1.0 THR=-1.0 TFR=12345678 TPR=-1 TCR=-1 FPXR=-1.0 FPYR=-1.0 FRXR=0.0 FRYR=0.0 FIR=-1 FSR=0 FCR=-1 POLYL=.FALSE. POLYM=.FALSE. TEXT=.FALSE. AREA=.FALSE. *** Decode the parameter list. INEXT=IKEY+2 DO 10 I=IKEY+2,NWORD IF(I.LT.INEXT)GOTO 10 * Polyline items. IF(INPCMP(I,'LINET#YPE')+ - INPCMP(I,'LINE-T#YPE')+ - INPCMP(I,'POLYLINE-T#YPE')+ - INPCMP(I,'POLYLINET#YPE').NE.0)THEN POLYL=.TRUE. IF(I+1.GT.NWORD)THEN CALL INPMSG(I,'The linetype is not specified.') ELSEIF(INPCMP(I+1,'SOL#ID').NE.0)THEN LTR=1 INEXT=I+2 ELSEIF(INPCMP(I+1,'DASH#ED').NE.0)THEN LTR=2 INEXT=I+2 ELSEIF(INPCMP(I+1,'DOT#TED').NE.0)THEN LTR=3 INEXT=I+2 ELSEIF(INPCMP(I+1,'DASH-DOT#TED').NE.0)THEN LTR=4 INEXT=I+2 ELSEIF(INPTYP(I+1).LE.0)THEN CALL INPMSG(I+1,'Not recognised as a linetype. ') INEXT=I+2 ELSE CALL INPCHK(I+1,1,IFAIL1) CALL INPRDI(I+1,LTR,0) INEXT=I+2 ENDIF ELSEIF(INPCMP(I,'LINEW#IDTH-SC#ALE-#FACTOR').NE.0)THEN POLYL=.TRUE. IF(INPTYP(I+1).LE.0.OR.I+1.GT.NWORD)THEN CALL INPMSG(I,'Value missing or not real. ') ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,LWR,-1.0) INEXT=I+2 ENDIF ELSEIF(INPCMP(I,'POLYL#INE-COL#OUR')+ - INPCMP(I,'L#INE-COL#OUR').NE.0)THEN POLYL=.TRUE. IF(I+1.GT.NWORD)THEN CALL INPMSG(I,'The colour is not specified. ') ELSE CALL INPSTR(I+1,I+1,STRING,NCSTR) CALL GRCOLQ(IWKID,STRING(1:NCSTR),LCR) IF(LCR.LT.0) - CALL INPMSG(I+1,'This colour is not known. ') INEXT=I+2 ENDIF * Polymarker items. ELSEIF(INPCMP(I,'M#ARKER-T#YPE')+ - INPCMP(I,'POLYM#ARKER-T#YPE').NE.0)THEN POLYM=.TRUE. IF(I+1.GT.NWORD)THEN CALL INPMSG(I,'The marker is not specified. ') ELSEIF(INPCMP(I+1,'DOT').NE.0)THEN MTR=1 INEXT=I+2 ELSEIF(INPCMP(I+1,'PL#US').NE.0)THEN MTR=2 INEXT=I+2 ELSEIF(INPCMP(I+1,'AST#ERISK').NE.0)THEN MTR=3 INEXT=I+2 ELSEIF(INPCMP(I+1,'CIRC#LE').NE.0)THEN MTR=4 INEXT=I+2 ELSEIF(INPCMP(I+1,'CR#OSS').NE.0)THEN MTR=5 INEXT=I+2 ELSEIF(INPTYP(I+1).LE.0)THEN CALL INPMSG(I+1,'Not recognised as a marker. ') INEXT=I+2 ELSE CALL INPCHK(I+1,1,IFAIL1) CALL INPRDI(I+1,MTR,0) INEXT=I+2 ENDIF ELSEIF(INPCMP(I,'M#ARKER-SIZ#E-#SCALE-#FACTOR').NE.0)THEN POLYM=.TRUE. IF(INPTYP(I+1).LE.0.OR.I+1.GT.NWORD)THEN CALL INPMSG(I,'Value missing or not real. ') ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,MSR,-1.0) INEXT=I+2 ENDIF ELSEIF(INPCMP(I,'POLYM#ARKER-COL#OUR')+ - INPCMP(I,'M#ARKER-COL#OUR').NE.0)THEN POLYM=.TRUE. IF(I+1.GT.NWORD)THEN CALL INPMSG(I,'The colour is not specified. ') ELSE CALL INPSTR(I+1,I+1,STRING,NCSTR) CALL GRCOLQ(IWKID,STRING(1:NCSTR),MCR) IF(MCR.LT.0) - CALL INPMSG(I+1,'This colour is not known. ') INEXT=I+2 ENDIF * Text items. ELSEIF(INPCMP(I,'CH#ARACTER-EXP#ANSION-#FACTOR').NE.0)THEN TEXT=.TRUE. IF(INPTYP(I+1).LE.0.OR.I+1.GT.NWORD)THEN CALL INPMSG(I,'Value missing or not real. ') ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,TER,-1.0) INEXT=I+2 ENDIF ELSEIF(INPCMP(I,'CH#ARACTER-SP#ACING').NE.0)THEN TEXT=.TRUE. IF(INPTYP(I+1).LE.0.OR.I+1.GT.NWORD)THEN CALL INPMSG(I,'Value missing or not real. ') ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,TSR,-1.0) INEXT=I+2 ENDIF ELSEIF(INPCMP(I,'CH#ARACTER-H#EIGHT').NE.0)THEN TEXT=.TRUE. IF(INPTYP(I+1).LE.0.OR.I+1.GT.NWORD)THEN CALL INPMSG(I,'Value missing or not real. ') ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,THR,-1.0) INEXT=I+2 ENDIF ELSEIF(INPCMP(I,'T#EXT-F#ONT').NE.0)THEN TEXT=.TRUE. +SELF,IF=HIGZ. IF(I+1.GT.NWORD)THEN CALL INPMSG(I,'Value missing.') ELSEIF(INPCMP(I+1,'HIGZ-#SOFTWARE').NE.0)THEN TFR=0 ELSEIF(INPCMP(I+1,'T#IMES-I#TALIC').NE.0)THEN TFR=-1 ELSEIF(INPCMP(I+1,'T#IMES-B#OLD').NE.0)THEN TFR=-2 ELSEIF(INPCMP(I+1,'T#IMES-B#OLD-I#TALIC').NE.0)THEN TFR=-3 ELSEIF(INPCMP(I+1,'HELV#ETICA').NE.0)THEN TFR=-4 ELSEIF(INPCMP(I+1,'HELV#ETICA-O#BLIQUE').NE.0)THEN TFR=-5 ELSEIF(INPCMP(I+1,'HELV#ETICA-B#OLD').NE.0)THEN TFR=-6 ELSEIF(INPCMP(I+1,'HELV#ETICA-B#OLD-O#BLIQUE').NE.0)THEN TFR=-7 ELSEIF(INPCMP(I+1,'C#OURIER').NE.0)THEN TFR=-8 ELSEIF(INPCMP(I+1,'C#OURIER-O#BLIQUE').NE.0)THEN TFR=-9 ELSEIF(INPCMP(I+1,'C#OURIER-B#OLD').NE.0)THEN TFR=-10 ELSEIF(INPCMP(I+1,'C#OURIER-B#OLD-O#BLIQUE').NE.0)THEN TFR=-11 ELSEIF(INPCMP(I+1,'S#YMBOL').NE.0)THEN TFR=-12 ELSEIF(INPCMP(I+1,'T#IMES-R#OMAN').NE.0)THEN TFR=-13 ELSEIF(INPCMP(I+1,'ZAPF-#DINGBAT').NE.0)THEN TFR=-14 ELSEIF(INPCMP(I+1,'HO#LLOW-T#IMES-I#TALIC').NE.0)THEN TFR=-15 ELSEIF(INPCMP(I+1,'HO#LLOW-T#IMES-B#OLD').NE.0)THEN TFR=-16 ELSEIF(INPCMP(I+1,'HO#LLOW-T#IMES-B#OLD-I#TALIC').NE.0)THEN TFR=-17 ELSEIF(INPCMP(I+1,'HO#LLOW-HELV#ETICA').NE.0)THEN TFR=-18 ELSEIF(INPCMP(I+1,'HO#LLOW-HELV#ETICA-O#BLIQUE').NE.0)THEN TFR=-19 ELSEIF(INPCMP(I+1,'HO#LLOW-HELV#ETICA-B#OLD').NE.0)THEN TFR=-20 ELSEIF(INPCMP(I+1,'HO#LLOW-HELV#ETICA-B#OLD-O#BLIQUE').NE. - 0)THEN TFR=-21 ELSEIF(INPCMP(I+1,'HO#LLOW-S#YMBOL').NE.0)THEN TFR=-22 ELSEIF(INPCMP(I+1,'HO#LLOW-T#IMES-R#OMAN').NE.0)THEN TFR=-23 ELSEIF(INPCMP(I+1,'HO#LLOW-ZAPF-#DINGBAT').NE.0)THEN TFR=-24 ELSEIF(INPTYP(I+1).LE.0)THEN CALL INPMSG(I,'Value unknown.') ELSE CALL INPCHK(I+1,1,IFAIL1) CALL INPRDI(I+1,TFR,-1) ENDIF INEXT=I+2 +SELF,IF=GTSGRAL. IF(I+1.GT.NWORD)THEN CALL INPMSG(I,'Value missing.') ELSEIF(INPCMP(I+1,'PR#ESTIGE').NE.0)THEN TFR=-2 ELSEIF(INPCMP(I+1,'T#IMES-R#OMAN').NE.0)THEN TFR=-3 ELSEIF(INPCMP(I+1,'T#IMES-I#TALIC').NE.0)THEN TFR=-104 ELSEIF(INPCMP(I+1,'GR#EEK').NE.0)THEN TFR=-13 ELSEIF(INPCMP(I+1,'GR#EEK-I#TALIC').NE.0)THEN TFR=-113 ELSEIF(INPCMP(I+1,'GO#THIC').NE.0)THEN TFR=-9 ELSEIF(INPCMP(I+1,'GO#THIC-I#TALIC').NE.0)THEN TFR=-109 ELSEIF(INPTYP(I+1).LE.0)THEN CALL INPMSG(I,'Value unknown.') ELSE CALL INPCHK(I+1,1,IFAIL1) CALL INPRDI(I+1,TFR,-1) ENDIF INEXT=I+2 +SELF,IF=-HIGZ,IF=-GTSGRAL. IF(INPTYP(I+1).LE.0.OR.I+1.GT.NWORD)THEN CALL INPMSG(I,'Value missing or not integer. ') ELSE CALL INPCHK(I+1,1,IFAIL1) CALL INPRDI(I+1,TFR,-1) INEXT=I+2 ENDIF +SELF. ELSEIF(INPCMP(I,'T#EXT-PR#ECISION').NE.0)THEN TEXT=.TRUE. IF(I+1.GT.NWORD)THEN CALL INPMSG(I,'Character quality missing. ') ELSEIF(INPCMP(I+1,'STRI#NG')+INPCMP(I+1,'LOW').NE.0)THEN TPR=0 INEXT=I+2 ELSEIF(INPCMP(I+1,'CH#ARACTER')+ - INPCMP(I+1,'MED#IUM').NE.0)THEN TPR=1 INEXT=I+2 ELSEIF(INPCMP(I+1,'STRO#KE')+INPCMP(I+1,'HIGH').NE.0)THEN TPR=2 INEXT=I+2 ELSE CALL INPMSG(I,'Not in STRING/CHARACTER/STROKE') ENDIF ELSEIF(INPCMP(I,'T#EXT-COL#OUR').NE.0)THEN TEXT=.TRUE. IF(I+1.GT.NWORD)THEN CALL INPMSG(I,'The colour is not specified. ') ELSE CALL INPSTR(I+1,I+1,STRING,NCSTR) CALL GRCOLQ(IWKID,STRING(1:NCSTR),TCR) IF(TCR.LT.0) - CALL INPMSG(I+1,'This colour is not known. ') INEXT=I+2 ENDIF * Fill area items. ELSEIF(INPCMP(I,'F#ILL-A#REA-INT#ERIOR-#STYLE').NE.0)THEN AREA=.TRUE. IF(I+1.GT.NWORD)THEN CALL INPMSG(I,'Interior style missing. ') ELSEIF(INPCMP(I+1,'HOLL#OW').NE.0)THEN FIR=0 INEXT=I+2 ELSEIF(INPCMP(I+1,'SOL#ID').NE.0)THEN FIR=1 INEXT=I+2 ELSEIF(INPCMP(I+1,'PATT#ERN').NE.0)THEN FIR=2 INEXT=I+2 ELSEIF(INPCMP(I+1,'HAT#CHED').NE.0)THEN FIR=3 INEXT=I+2 ELSE CALL INPMSG(I+1,'Not HOLLOW/SOLID/PATTERN/HATCH') ENDIF ELSEIF(INPCMP(I,'F#ILL-A#REA-ST#YLE-#INDEX').NE.0)THEN AREA=.TRUE. IF(INPTYP(I+1).LE.0.OR.I+1.GT.NWORD)THEN CALL INPMSG(I,'Value missing or not integer. ') ELSE CALL INPCHK(I+1,1,IFAIL1) CALL INPRDI(I+1,FSR,0) INEXT=I+2 ENDIF ELSEIF(INPCMP(I,'F#ILL-A#REA-COL#OUR').NE.0)THEN AREA=.TRUE. IF(I+1.GT.NWORD)THEN CALL INPMSG(I,'The colour is not specified. ') ELSE CALL INPSTR(I+1,I+1,STRING,NCSTR) CALL GRCOLQ(IWKID,STRING(1:NCSTR),FCR) IF(FCR.LT.0) - CALL INPMSG(I+1,'This colour is not known. ') INEXT=I+2 ENDIF ELSEIF(INPCMP(I,'PA#TTERN-SIZ#E').NE.0)THEN AREA=.TRUE. IF(INPTYP(I+1).LE.0.OR.INPTYP(I+2).LE.0.OR. - I+2.GT.NWORD)THEN CALL INPMSG(I,'Values missing or not real. ') ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,FPXR,-1.0) CALL INPCHK(I+2,2,IFAIL2) CALL INPRDR(I+2,FPYR,-1.0) INEXT=I+3 ENDIF ELSEIF(INPCMP(I,'PA#TTERN-REF#ERENCE-#POINT').NE.0)THEN AREA=.TRUE. IF(INPTYP(I+1).LE.0.OR.INPTYP(I+2).LE.0.OR. - I+2.GT.NWORD)THEN CALL INPMSG(I,'Values missing or not real. ') ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,FRXR,-1.0) CALL INPCHK(I+2,2,IFAIL2) CALL INPRDR(I+2,FRYR,-1.0) INEXT=I+3 ENDIF * Unknown item. ELSE CALL INPMSG(I,'Not a known item. ') ENDIF 10 CONTINUE *** Dump the error messages. CALL INPERR *** Check whether conflicting items were presented. NITEM=0 IF(POLYL)NITEM=NITEM+1 IF(POLYM)NITEM=NITEM+1 IF(TEXT)NITEM=NITEM+1 IF(AREA)NITEM=NITEM+1 IF(NITEM.GT.1)THEN PRINT *,' ###### GRATTR ERROR : Items belonging to more'// - ' than one primitive seen ; command not processed.' RETURN ELSEIF(NITEM.EQ.0.AND.IKEY+1.LT.NWORD)THEN PRINT *,' ###### GRATTR ERROR : Invalid attributes'// - ' seen ; neither inquiry nor update performed.' RETURN ENDIF *** Loop over the items, start with the polylines. NUPDAT=0 NSEEN=0 DO 20 I=1,NLIN IF(IKEY.EQ.NWORD.OR.INPCMP(IKEY+1,LINNAM(I))+ - INPCMP(IKEY+1,'!'//LINNAM(I)).NE.0)THEN NSEEN=NSEEN+1 IF(IKEY+1.GE.NWORD)THEN CALL INPFIX(LINNAM(I),AUX,NC) WRITE(LUNOUT,'(/'' Current representation of the'', - '' polyline item '',A,'':''/)') AUX(1:NC) IF(LINTYP(I).EQ.1)THEN AUX='Solid (--------)' ELSEIF(LINTYP(I).EQ.2)THEN AUX='Dashed (- - - - )' ELSEIF(LINTYP(I).EQ.3)THEN AUX='Dotted (........)' ELSEIF(LINTYP(I).EQ.4)THEN AUX='Dash-dotted (-.-.-.-.)' ELSE WRITE(AUX,'(I10)') LINTYP(I) ENDIF WRITE(LUNOUT,'('' Linetype: '',A)') - AUX(1:25) CALL OUTFMT(LINWID(I),2,AUX,NC,'LEFT') WRITE(LUNOUT,'('' Linewidth scale factor: '',A)') - AUX(1:NC) CALL GRCOLD(IWKID,LINCOL(I),AUX,NC,'FORMATTED') WRITE(LUNOUT,'('' Polyline colour: '',A)') - AUX(1:NC) WRITE(LUNOUT,'('' '')') ELSEIF(POLYL)THEN NUPDAT=NUPDAT+1 IF(LTR.NE.0)LINTYP(I)=LTR IF(LWR.GT.0.0)LINWID(I)=LWR IF(LCR.GE.0)LINCOL(I)=LCR ENDIF ENDIF 20 CONTINUE *** Next the polymarkers. DO 30 I=1,NMRK IF(IKEY.EQ.NWORD.OR.INPCMP(IKEY+1,MRKNAM(I))+ - INPCMP(IKEY+1,'!'//MRKNAM(I)).NE.0)THEN NSEEN=NSEEN+1 IF(IKEY+1.GE.NWORD)THEN CALL INPFIX(MRKNAM(I),AUX,NC) WRITE(LUNOUT,'(/'' Current representation of the'', - '' polymarker item '',A,'':''/)') AUX(1:NC) IF(MRKTYP(I).EQ.1)THEN AUX='Dot (.)' ELSEIF(MRKTYP(I).EQ.2)THEN AUX='Plus (+)' ELSEIF(MRKTYP(I).EQ.3)THEN AUX='Asterisk (*)' ELSEIF(MRKTYP(I).EQ.4)THEN AUX='Circle (o)' ELSEIF(MRKTYP(I).EQ.5)THEN AUX='Cross (x)' ELSE WRITE(AUX,'(I10)') MRKTYP(I) ENDIF WRITE(LUNOUT,'('' Marker type: '',A)') - AUX(1:20) CALL OUTFMT(MRKSIZ(I),2,AUX,NC,'LEFT') WRITE(LUNOUT,'('' Marker size scale factor: '',A)') - AUX(1:NC) CALL GRCOLD(IWKID,MRKCOL(I),AUX,NC,'FORMATTED') WRITE(LUNOUT,'('' Polymarker colour: '',A/)') - AUX(1:NC) ELSEIF(POLYM)THEN NUPDAT=NUPDAT+1 IF(MTR.NE.0)MRKTYP(I)=MTR IF(MSR.GT.0.0)MRKSIZ(I)=MSR IF(MCR.GE.0)MRKCOL(I)=MCR ENDIF ENDIF 30 CONTINUE *** Next the text. DO 40 I=1,NTXT IF(IKEY.EQ.NWORD.OR.INPCMP(IKEY+1,TXTNAM(I))+ - INPCMP(IKEY+1,'!'//TXTNAM(I)).NE.0)THEN NSEEN=NSEEN+1 IF(IKEY+1.GE.NWORD)THEN CALL INPFIX(TXTNAM(I),AUX,NC) WRITE(LUNOUT,'(/'' Current representation of the'', - '' text item '',A,'':''/)') AUX(1:NC) CALL OUTFMT(REAL(TXTFNT(I)),2,AUX,NC,'LEFT') WRITE(LUNOUT,'('' Text font: '',A)') - AUX(1:NC) IF(TXTPRC(I).EQ.0)THEN AUX='String (low quality)' ELSEIF(TXTPRC(I).EQ.1)THEN AUX='Character (medium quality)' ELSEIF(TXTPRC(I).EQ.2)THEN AUX='Stroke (high quality)' ELSE WRITE(AUX,'(''# Invalid: '',I10)') TXTPRC(I) ENDIF WRITE(LUNOUT,'('' Text precision: '',A)') - AUX(1:30) CALL OUTFMT(TXTEXP(I),2,AUX,NC,'LEFT') WRITE(LUNOUT,'('' Character expansion: '',A)') - AUX(1:NC) CALL OUTFMT(TXTHGT(I),2,AUX,NC,'LEFT') WRITE(LUNOUT,'('' Character height: '',A)') - AUX(1:NC) CALL OUTFMT(TXTSPA(I),2,AUX,NC,'LEFT') WRITE(LUNOUT,'('' Character spacing: '',A)') - AUX(1:NC) CALL GRCOLD(IWKID,TXTCOL(I),AUX,NC,'FORMATTED') WRITE(LUNOUT,'('' Text colour: '',A/)') - AUX(1:NC) ELSEIF(TEXT)THEN NUPDAT=NUPDAT+1 IF(TER.GT.0.0)TXTEXP(I)=TER IF(TSR.GE.0.0)TXTSPA(I)=TSR IF(THR.GT.0.0)TXTHGT(I)=THR IF(TPR.GE.0)TXTPRC(I)=TPR IF(TFR.NE.12345678)TXTFNT(I)=TFR IF(TCR.GE.0)TXTCOL(I)=TCR ENDIF ENDIF 40 CONTINUE *** Next the fill area. DO 50 I=1,NFAR IF(IKEY.EQ.NWORD.OR.INPCMP(IKEY+1,FARNAM(I))+ - INPCMP(IKEY+1,'!'//FARNAM(I)).NE.0)THEN NSEEN=NSEEN+1 IF(IKEY+1.GE.NWORD)THEN CALL INPFIX(FARNAM(I),AUX,NC) WRITE(LUNOUT,'(/'' Current representation of the'', - '' fill area item '',A,'':''/)') AUX(1:NC) IF(FARINT(I).EQ.0)THEN AUX='Hollow (boundaries only)' ELSEIF(FARINT(I).EQ.1)THEN AUX='Solid (area filled with colour)' ELSEIF(FARINT(I).EQ.2)THEN AUX='Pattern (area filled with pattern)' ELSEIF(FARINT(I).EQ.3)THEN AUX='Hatch (area hatched)' ELSE CALL OUTFMT(REAL(FARINT(I)),2,AUX1,NC1,'LEFT') AUX='# Invalid: '//AUX1(1:NC1) ENDIF WRITE(LUNOUT,'('' Fill area interior style: '',A)') - AUX(1:40) IF(FARINT(I).EQ.2.OR.FARINT(I).EQ.3)THEN CALL OUTFMT(REAL(FARSTY(I)),2,AUX,NC,'LEFT') WRITE(LUNOUT,'('' Fill area style index: '', - A)') AUX(1:NC) ENDIF IF(FARINT(I).EQ.2)THEN CALL OUTFMT(FARPAS(1,I),2,AUX1,NC1,'LEFT') CALL OUTFMT(FARPAS(2,I),2,AUX2,NC2,'LEFT') WRITE(LUNOUT,'('' Fill area pattern sizes: ('', - A,'','',A,'')'')') AUX1(1:NC1),AUX2(1:NC2) CALL OUTFMT(FARREF(1,I),2,AUX1,NC1,'LEFT') CALL OUTFMT(FARREF(2,I),2,AUX2,NC2,'LEFT') WRITE(LUNOUT,'('' Fill area reference: ('', - A,'','',A,'')'')') AUX1(1:NC1),AUX2(1:NC2) ENDIF CALL GRCOLD(IWKID,FARCOL(I),AUX,NC,'FORMATTED') WRITE(LUNOUT,'('' Fill area colour: '',A/)') - AUX(1:NC) ELSEIF(AREA)THEN NUPDAT=NUPDAT+1 IF(FPXR.GT.0.0)FARPAS(1,I)=FPXR IF(FPYR.GT.0.0)FARPAS(2,I)=FPYR FARREF(1,I)=FRXR FARREF(2,I)=FRYR IF(FIR.GE.0)FARINT(I)=FIR IF(FSR.NE.0)FARSTY(I)=FSR IF(FCR.GE.0)FARCOL(I)=FCR ENDIF ENDIF 50 CONTINUE *** Check that an item was found. CALL INPSTR(IKEY+1,IKEY+1,STRING,NC) IF(NC.LE.0)THEN STRING='# Unable to read #' NC=18 ENDIF IF(NSEEN.EQ.0)THEN PRINT *,' !!!!!! GRATTR WARNING : '//STRING(1:NC)//' is'// - ' not a known item.' ELSEIF(NITEM.GT.0.AND.NUPDAT.EQ.0)THEN PRINT *,' !!!!!! GRATTR WARNING : The representation of '// - STRING(1:NC)//' is left unaltered since' PRINT *,' the attributes you'// - ' specified are not of the proper type.' ELSE IFAIL=0 ENDIF RETURN *** Secondary entry to set the proper attributes. ENTRY GRATTS(ITEM,TYPE) NSEEN=0 * Scan the list of polyline items if appropriate. IF(TYPE.EQ.'POLYLINE')THEN DO 110 I=1,NLIN IF(INPCMX(ITEM,LINNAM(I)).EQ.0)GOTO 110 NSEEN=NSEEN+1 CALL GSLN(LINTYP(I)) CALL GSLWSC(LINWID(I)) CALL GSPLCI(LINCOL(I)) 110 CONTINUE * The list of polymarker items. ELSEIF(TYPE.EQ.'POLYMARKER')THEN DO 120 I=1,NMRK IF(INPCMX(ITEM,MRKNAM(I)).EQ.0)GOTO 120 NSEEN=NSEEN+1 CALL GSMK(MRKTYP(I)) CALL GSMKSC(MRKSIZ(I)) CALL GSPMCI(MRKCOL(I)) 120 CONTINUE * The list of text items. ELSEIF(TYPE.EQ.'TEXT')THEN DO 130 I=1,NTXT IF(INPCMX(ITEM,TXTNAM(I)).EQ.0)GOTO 130 NSEEN=NSEEN+1 CALL GSTXFP(TXTFNT(I),TXTPRC(I)) CALL GSCHXP(TXTEXP(I)) CALL GSCHSP(TXTSPA(I)) CALL GSCHH(TXTHGT(I)) CALL GSTXCI(TXTCOL(I)) 130 CONTINUE * The list of fill area items. ELSEIF(TYPE.EQ.'AREA')THEN DO 140 I=1,NFAR IF(INPCMX(ITEM,FARNAM(I)).EQ.0)GOTO 140 NSEEN=NSEEN+1 CALL GSFAIS(FARINT(I)) IF(FARINT(I).EQ.2.OR.FARINT(I).EQ.3) - CALL GSFASI(FARSTY(I)) CALL GSPA(FARPAS(1,I),FARPAS(2,I)) CALL GSPARF(FARREF(1,I),FARREF(2,I)) CALL GSFACI(FARCOL(I)) 140 CONTINUE * Anything else: invalid. ELSE WRITE (10,'('' ###### GRATTS ERROR : Invalid primitive'', - '' type '',A,'' received; program bug.'')') TYPE RETURN ENDIF *** Make sure the item has been found. IF(NSEEN.EQ.0)THEN WRITE (10,'('' !!!!!! GRATTS ERROR : Unknown item '',A, - '' received; no update.'')') ITEM RETURN ENDIF RETURN *** Write the settings to a file. ENTRY GRATTW(IKEY,IFAIL) * Initial settings. FILE=' ' NCFILE=1 MEMBER='< none >' NCMEMB=8 REMARK='none' NCREM=4 IFAIL=1 IWKID=1 * First decode the argument string. CALL INPNUM(NWORD) * Make sure there is at least one argument. IF(NWORD.EQ.IKEY)THEN PRINT *,' !!!!!! GRATTW WARNING : WRITE takes at least one', - ' argument (a dataset name); data will not be written.' RETURN * Check whether keywords have been used. ELSEIF(INPCMP(IKEY+1,'D#ATASET')+ - INPCMP(IKEY+1,'R#EMARK').NE.0)THEN INEXT=2 DO 210 I=IKEY+1,NWORD IF(I.LT.INEXT)GOTO 210 IF(INPCMP(I,'D#ATASET').NE.0)THEN IF(INPCMP(I+1,'R#EMARK').NE.0.OR.I+1.GT.NWORD)THEN CALL INPMSG(I,'The dataset name is missing. ') INEXT=I+1 ELSE CALL INPSTR(I+1,I+1,STRING,NCFILE) FILE=STRING INEXT=I+2 IF(INPCMP(I+2,'R#EMARK').EQ.0.AND. - I+2.LE.NWORD)THEN CALL INPSTR(I+2,I+2,STRING,NCMEMB) MEMBER=STRING INEXT=I+3 ENDIF ENDIF ELSEIF(INPCMP(I,'R#EMARK').NE.0)THEN IF(INPCMP(I+1,'D#ATASET').NE.0.OR.I+1.GT.NWORD)THEN CALL INPMSG(I,'The remark is missing. ') INEXT=I+1 ELSE CALL INPSTR(I+1,I+1,STRING,NCREM) REMARK=STRING INEXT=I+2 ENDIF ELSE CALL INPMSG(I,'The parameter is not known. ') ENDIF 210 CONTINUE * Otherwise the string is interpreted as a file name (+ member name). ELSE CALL INPSTR(IKEY+1,IKEY+1,STRING,NCFILE) FILE=STRING IF(NWORD.GE.IKEY+2)THEN CALL INPSTR(IKEY+2,IKEY+2,STRING,NCMEMB) MEMBER=STRING ENDIF IF(NWORD.GE.IKEY+3)THEN CALL INPSTR(IKEY+3,NWORD,STRING,NCREM) REMARK=STRING ENDIF ENDIF * Print error messages. CALL INPERR IF(NCFILE.GT.MXNAME)PRINT *,' !!!!!! GRATTW WARNING : The file', - ' name is truncated to MXNAME (=',MXNAME,') characters.' IF(NCMEMB.GT.8)PRINT *,' !!!!!! GRATTW WARNING : The member', - ' name is shortened to ',MEMBER,', first 8 characters.' IF(NCREM.GT.29)PRINT *,' !!!!!! GRATTW WARNING : The remark', - ' shortened to ',REMARK,', first 29 characters.' NCFILE=MIN(NCFILE,MXNAME) NCMEMB=MIN(NCMEMB,8) NCREM=MIN(NCREM,29) * Check whether the member already exists. CALL DSNREM(FILE(1:NCFILE),MEMBER(1:NCMEMB),'GRAPHREP',EXMEMB) IF(JEXMEM.EQ.2.AND.EXMEMB)THEN PRINT *,' ------ GRATTW MESSAGE : A copy of the member'// - ' exists; new member will be appended.' ELSEIF(JEXMEM.EQ.3.AND.EXMEMB)THEN PRINT *,' !!!!!! GRATTW WARNING : A copy of the member'// - ' exists already; member will not be written.' RETURN ENDIF * Print some debugging output if requested. IF(LDEBUG)THEN PRINT *,' ++++++ GRATTW DEBUG : File= ',FILE(1:NCFILE), - ', member= ',MEMBER(1:NCMEMB) PRINT *,' Remark= ',REMARK(1:NCREM) ENDIF ** Open the dataset for sequential write and inform DSNLOG. CALL DSNOPN(FILE,NCFILE,12,'WRITE-LIBRARY',IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! GRATTW WARNING : Opening ',FILE(1:NCFILE), - ' failed ; the data will not be written.' RETURN ENDIF CALL DSNLOG(FILE,'Graphics ','Sequential','Write ') IF(LDEBUG)PRINT *,' ++++++ GRATTW DEBUG : Dataset ', - FILE(1:NCFILE),' opened on unit 12 for seq write.' * Now write a heading record to the file. CALL DATTIM(DATE,TIME) WRITE(STRING,'(''% Created '',A8,'' At '',A8,1X,A8,'' GRAPHREP'', - 1X,''"'',A29,''"'')') DATE,TIME,MEMBER,REMARK WRITE(12,'(A80)',IOSTAT=IOS,ERR=2010) STRING IF(LDEBUG)THEN PRINT *,' ++++++ GRATTW DEBUG : Dataset heading record:' PRINT *,STRING ENDIF * Information line about the graphics system beging used. +SELF,IF=GTSGRAL. WRITE(12,'('' GKS flavour: GTSGRAL'')',ERR=2010,IOSTAT=IOS) +SELF,IF=DECGKS. WRITE(12,'('' GKS flavour: DECGKS'')',ERR=2010,IOSTAT=IOS) +SELF,IF=PLOT10GKS. WRITE(12,'('' GKS flavour: PLOT10GKS'')',ERR=2010,IOSTAT=IOS) +SELF,IF=-GTSGRAL,IF=-DECGKS,IF=-PLOT10GKS. WRITE(12,'('' GKS flavour: MGKS'')',ERR=2010,IOSTAT=IOS) +SELF. * Write the actual data, start with the number of items of each type. WRITE(12,'('' NLIN='',I3,'', NMRK='',I3,'', NTXT='',I3, - '', NFAR='',I3)',ERR=2010,IOSTAT=IOS) NLIN,NMRK,NTXT,NFAR * Next a list of Polyline attributes. DO 230 I=1,NLIN CALL GRCOLD(IWKID,LINCOL(I),AUX,NC,'RAW') WRITE(12,'(A20,I10,E15.8,A20)',ERR=2010,IOSTAT=IOS) - LINNAM(I),LINTYP(I),LINWID(I),AUX(1:20) 230 CONTINUE * Next a list of Polymarker attributes. DO 240 I=1,NMRK CALL GRCOLD(IWKID,MRKCOL(I),AUX,NC,'RAW') WRITE(12,'(A20,I10,E15.8,A20)',ERR=2010,IOSTAT=IOS) - MRKNAM(I),MRKTYP(I),MRKSIZ(I),AUX(1:20) 240 CONTINUE * Next a list of Text attributes. DO 250 I=1,NTXT CALL GRCOLD(IWKID,TXTCOL(I),AUX,NC,'RAW') WRITE(12,'(A20,2I10,3E15.8,A20)',ERR=2010,IOSTAT=IOS) - TXTNAM(I),TXTFNT(I),TXTPRC(I),TXTEXP(I),TXTSPA(I), - TXTHGT(I),AUX(1:20) 250 CONTINUE * Next a list of Fill Area attributes. DO 260 I=1,NFAR CALL GRCOLD(IWKID,FARCOL(I),AUX,NC,'RAW') WRITE(12,'(A20,2I10,4E15.8,A20)',ERR=2010,IOSTAT=IOS) - FARNAM(I),FARINT(I),FARSTY(I),FARPAS(1,I),FARPAS(2,I), - FARREF(1,I),FARREF(2,I),AUX(1:20) 260 CONTINUE ** Close the file after the operation. CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) CALL TIMLOG('Writing out graphics representations: ') IFAIL=0 RETURN *** Read the presentation from dataset. ENTRY GRATTG(IKEY,IFAIL) * Initial values. FILE=' ' MEMBER='*' NCFILE=8 NCMEMB=1 IFAIL=1 IWKID=1 ** First decode the argument string, setting file name + member name. CALL INPNUM(NWORD) * If there's only one argument, it's the dataset name. IF(NWORD.GE.IKEY+1)THEN CALL INPSTR(IKEY+1,IKEY+1,STRING,NCFILE) FILE=STRING ENDIF * If there's a second argument, it is the member name. IF(NWORD.GE.IKEY+2)THEN CALL INPSTR(IKEY+2,IKEY+2,STRING,NCMEMB) MEMBER=STRING ENDIF * Check the various lengths. IF(NCFILE.GT.MXNAME)THEN PRINT *,' !!!!!! GRATTG WARNING : The file name is'// - ' truncated to MXNAME (=',MXNAME,') characters.' NCFILE=MIN(NCFILE,MXNAME) ENDIF IF(NCMEMB.GT.8)THEN PRINT *,' !!!!!! GRATTG WARNING : The member name is'// - ' shortened to ',MEMBER,', first 8 characters.' NCMEMB=MIN(NCMEMB,8) ELSEIF(NCMEMB.LE.0)THEN PRINT *,' !!!!!! GRATTG WARNING : The member'// - ' name has zero length, replaced by "*".' MEMBER='*' NCMEMB=1 ENDIF * Reject the empty file name case. IF(FILE.EQ.' '.OR.NWORD.EQ.1)THEN PRINT *,' !!!!!! GRATTG WARNING : GET must be at least'// - ' followed by a dataset name ; no data are read.' RETURN ENDIF * If there are even more args, warn they are ignored. IF(NWORD.GT.IKEY+2)PRINT *,' !!!!!! GRATTG WARNING : GET takes'// - ' at most two arguments (dataset and member); rest ignored.' ** Open the dataset and inform DSNLOG. CALL DSNOPN(FILE,NCFILE,12,'READ-LIBRARY',IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! GRATTG WARNING : Opening ',FILE(1:NCFILE), - ' failed ; graphics representation data are not read.' RETURN ENDIF CALL DSNLOG(FILE,'Graphics ','Sequential','Read only ') IF(LDEBUG)PRINT *,' ++++++ GRATTG DEBUG : Dataset', - FILE(1:NCFILE),' opened on unit 12 for seq read.' * Locate the pointer on the header of the requested member. CALL DSNLOC(MEMBER,NCMEMB,'GRAPHREP',12,EXIS,'RESPECT') IF(.NOT.EXIS)THEN CALL DSNLOC(MEMBER,NCMEMB,'GRAPHREP',12,EXIS,'IGNORE') IF(EXIS)THEN PRINT *,' ###### GRATTG ERROR : Graphics data ', - MEMBER(1:NCMEMB),' has been deleted from ', - FILE(1:NCFILE),'; not read.' ELSE PRINT *,' ###### GRATTG ERROR : Graphics data ', - MEMBER(1:NCMEMB),' not found on ',FILE(1:NCFILE) ENDIF CLOSE(UNIT=12,IOSTAT=IOS,ERR=2030) RETURN ENDIF ** Check that the member is acceptable date wise. READ(12,'(A80)',END=2000,IOSTAT=IOS,ERR=2010) STRING IF(LDEBUG)THEN PRINT *,' ++++++ GRATTG DEBUG : Dataset header', - ' record follows:' PRINT *,STRING ENDIF IF(DSNCMP('14-07-89',STRING(11:18)))THEN PRINT *,' !!!!!! GRATTG WARNING : Member ',STRING(32:39), - ' can not be read because of a change in format.' CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) RETURN ENDIF WRITE(LUNOUT,'('' Member '',A8,'' was created on '',A8, - '' at '',A8/'' Remarks: '',A29)') - STRING(32:39),STRING(11:18),STRING(23:30),STRING(51:79) ** Carry out the actual reading, check the GKS flavour. READ(12,'(A80)',END=2000,ERR=2010,IOSTAT=IOS) AUX +SELF,IF=GTSGRAL. IF(AUX(15:30).NE.'GTSGRAL ')PRINT *,' !!!!!! GRATTG'// - ' WARNING : This member was created with another GKS than'// - ' the one you are running with now.' +SELF,IF=DECGKS. IF(AUX(15:30).NE.'DECGKS ')PRINT *,' !!!!!! GRATTG'// - ' WARNING : This member was created with another GKS than'// - ' the one you are running with now.' +SELF,IF=PLOT10GKS. IF(AUX(15:30).NE.'PLOT10GKS ')PRINT *,' !!!!!! GRATTG'// - ' WARNING : This member was created with another GKS than'// - ' the one you are running with now.' +SELF,IF=-GTSGRAL,IF=-DECGKS,IF=-PLOT10GKS. IF(AUX(15:30).NE.'MGKS ')PRINT *,' !!!!!! GRATTG'// - ' WARNING : This member was created with another GKS than'// - ' the one you are running with now.' +SELF. * Read the actual data, start with the number of items of each type. READ(12,'(6X,I3,7X,I3,7X,I3,7X,I3)',END=2000,ERR=2010, - IOSTAT=IOS) NLIN,NMRK,NTXT,NFAR * Make sure none of these exceeds the maximum numbers. IF(NLIN.GT.MXPLBU.OR.NMRK.GT.MXPMBU.OR.NTXT.GT.MXTXBU.OR. - NFAR.GT.MXFABU)THEN PRINT *,' !!!!!! GRATTG WARNING : The number of items'// - ' for one or more atributes, exceeds' PRINT *,' the compilation maxima;'// - ' increase these and recompile.' CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) RETURN ENDIF * Next a list of Polyline attributes. DO 330 I=1,NLIN READ(12,'(A20,I10,E15.8,A20)',END=2000,ERR=2010,IOSTAT=IOS) - LINNAM(I),LINTYP(I),LINWID(I),AUX(1:20) CALL GRCOLQ(IWKID,AUX(1:20),LCR) IF(LCR.GE.0)THEN LINCOL(I)=LCR ELSE PRINT *,' !!!!!! GRATTG WARNING : The member contains a'// - ' colour absent in the colour tables: '//AUX(1:20) CALL INPFIX(LINNAM(I),AUX,NC) PRINT *,' The FOREGROUND colour'// - ' will be used to represent item '//AUX(1:NC)//'.' LINCOL(I)=1 ENDIF 330 CONTINUE * Next a list of Polymarker attributes. DO 340 I=1,NMRK READ(12,'(A20,I10,E15.8,A20)',END=2000,ERR=2010,IOSTAT=IOS) - MRKNAM(I),MRKTYP(I),MRKSIZ(I),AUX(1:20) CALL GRCOLQ(IWKID,AUX(1:20),MCR) IF(MCR.GE.0)THEN MRKCOL(I)=MCR ELSE PRINT *,' !!!!!! GRATTG WARNING : The member contains a'// - ' colour absent in the colour tables: '//AUX(1:20) CALL INPFIX(MRKNAM(I),AUX,NC) PRINT *,' The FOREGROUND colour'// - ' will be used to represent item '//AUX(1:NC)//'.' MRKCOL(I)=1 ENDIF 340 CONTINUE * Next a list of Text attributes. DO 350 I=1,NTXT READ(12,'(A20,2I10,3E15.8,A20)',END=2000,ERR=2010,IOSTAT=IOS) - TXTNAM(I),TXTFNT(I),TXTPRC(I),TXTEXP(I),TXTSPA(I), - TXTHGT(I),AUX(1:20) CALL GRCOLQ(IWKID,AUX(1:20),TCR) IF(TCR.GE.0)THEN TXTCOL(I)=TCR ELSE PRINT *,' !!!!!! GRATTG WARNING : The member contains a'// - ' colour absent in the colour tables: '//AUX(1:20) CALL INPFIX(TXTNAM(I),AUX,NC) PRINT *,' The FOREGROUND colour'// - ' will be used to represent item '//AUX(1:NC)//'.' TXTCOL(I)=1 ENDIF 350 CONTINUE * Next a list of Fill Area attributes. DO 360 I=1,NFAR READ(12,'(A20,2I10,4E15.8,A20)',END=2000,ERR=2010,IOSTAT=IOS) - FARNAM(I),FARINT(I),FARSTY(I),FARPAS(1,I),FARPAS(2,I), - FARREF(1,I),FARREF(2,I),AUX(1:20) CALL GRCOLQ(IWKID,AUX(1:20),FCR) IF(FCR.GE.0)THEN FARCOL(I)=FCR ELSE PRINT *,' !!!!!! GRATTG WARNING : The member contains a'// - ' colour absent in the colour tables: '//AUX(1:20) CALL INPFIX(FARNAM(I),AUX,NC) PRINT *,' The FOREGROUND colour'// - ' will be used to represent item '//AUX(1:NC)//'.' FARCOL(I)=1 ENDIF 360 CONTINUE ** Close the file after the operation. CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) CALL TIMLOG('Reading in graphics representations: ') IFAIL=0 RETURN *** Polyline update. ENTRY GRATTL(ITEM,TYPE,WIDTH,COLOUR) NSEEN=0 DO 410 I=1,NLIN IF(INPCMX(ITEM,LINNAM(I)).EQ.0)GOTO 410 NSEEN=NSEEN+1 * Line type IF(TYPE.EQ.' ')THEN LTR=0 ELSEIF(INPCMX(TYPE,'SOL#ID').NE.0)THEN LTR=1 ELSEIF(INPCMX(TYPE,'DASH#ED').NE.0)THEN LTR=2 ELSEIF(INPCMX(TYPE,'DOT#TED').NE.0)THEN LTR=3 ELSEIF(INPCMX(TYPE,'DASH-DOT#TED').NE.0)THEN LTR=4 ELSE WRITE (10,'('' !!!!!! GRATTL ERROR : Line type '',A, - '' not known; no update.'')') TYPE LTR=0 ENDIF IF(LTR.GT.0)LINTYP(I)=LTR * Line width scale factor IF(WIDTH.GT.0)LINWID(I)=WIDTH * Line colour IF(COLOUR.NE.' ')THEN CALL GRCOLQ(1,COLOUR,ICOL) IF(ICOL.GT.0)THEN LINCOL(I)=ICOL ELSE WRITE (10,'('' !!!!!! GRATTL ERROR : Colour '',A, - '' not known, attribute not set.'')') COLOUR ENDIF ENDIF 410 CONTINUE * Check the thing has been found. IF(NSEEN.EQ.0)THEN WRITE (10,'('' !!!!!! GRATTL ERROR : Unknown item '',A, - '' received; no update.'')') ITEM RETURN ENDIF RETURN *** Fill area update. ENTRY GRATTA(ITEM,TYPE,FSTY,FPAS1,FPAS2,FREF1,FREF2,COLOUR) NSEEN=0 DO 420 I=1,NFAR IF(INPCMX(ITEM,FARNAM(I)).EQ.0)GOTO 420 NSEEN=NSEEN+1 * Area type IF(TYPE.EQ.' ')THEN FIR=0 ELSEIF(INPCMX(TYPE,'HOLL#OW').NE.0)THEN FIR=0 ELSEIF(INPCMX(TYPE,'SOL#ID').NE.0)THEN FIR=1 ELSEIF(INPCMX(TYPE,'PATT#ERN').NE.0)THEN FIR=2 ELSEIF(INPCMX(TYPE,'HAT#CHED').NE.0)THEN FIR=3 ELSE WRITE (10,'('' !!!!!! GRATTA ERROR : Area type '',A, - '' not known; no update.'')') TYPE FIR=0 ENDIF IF(FIR.GT.0)FARINT(I)=FIR * Area style index IF(FSTY.GT.0)FARSTY(I)=FSTY * Area pattern style IF(FPAS1.GT.0)FARPAS(1,I)=FPAS1 IF(FPAS2.GT.0)FARPAS(2,I)=FPAS2 * Area pattern reference FARREF(1,I)=FREF1 FARREF(2,I)=FREF2 * Area colour IF(COLOUR.NE.' ')THEN CALL GRCOLQ(1,COLOUR,ICOL) IF(ICOL.GT.0)THEN FARCOL(I)=ICOL ELSE WRITE (10,'('' !!!!!! GRATTA ERROR : Colour '',A, - '' not known, attribute not set.'')') COLOUR ENDIF ENDIF 420 CONTINUE * Check the thing has been found. IF(NSEEN.EQ.0)THEN WRITE (10,'('' !!!!!! GRATTA ERROR : Unknown item '',A, - '' received; no update.'')') ITEM RETURN ENDIF RETURN *** Text update. ENTRY GRATTT(ITEM,FONT,PREC,EXPAN,HEIGHT,SPACE,COLOUR) NSEEN=0 DO 430 I=1,NTXT IF(INPCMX(ITEM,TXTNAM(I)).EQ.0)GOTO 430 NSEEN=NSEEN+1 * Text font IF(FONT.GT.-1)TXTFNT(I)=FONT * Text precision IF(PREC.GT.-1)TXTPRC(I)=PREC * Text expansion IF(EXPAN.GT.0.0)TXTEXP(I)=EXPAN * Text height IF(HEIGHT.GT.0.0)TXTHGT(I)=HEIGHT * Text spacing IF(SPACE.GT.0.0)TXTSPA(I)=SPACE * Text colour IF(COLOUR.NE.' ')THEN CALL GRCOLQ(1,COLOUR,ICOL) IF(ICOL.GT.0)THEN TXTCOL(I)=ICOL ELSE WRITE (10,'('' !!!!!! GRATTT ERROR : Colour '',A, - '' not known, attribute not set.'')') COLOUR ENDIF ENDIF 430 CONTINUE * Check the thing has been found. IF(NSEEN.EQ.0)THEN WRITE (10,'('' !!!!!! GRATTT ERROR : Unknown item '',A, - '' received; no update.'')') ITEM RETURN ENDIF RETURN *** Marker update. ENTRY GRATTM(ITEM,TYPE,SIZE,COLOUR) NSEEN=0 DO 440 I=1,NMRK IF(INPCMX(ITEM,MRKNAM(I)).EQ.0)GOTO 440 NSEEN=NSEEN+1 * Marker type IF(TYPE.EQ.' ')THEN MTR=0 ELSEIF(INPCMX(TYPE,'DOT').NE.0)THEN MTR=1 ELSEIF(INPCMX(TYPE,'PL#US').NE.0)THEN MTR=2 ELSEIF(INPCMX(TYPE,'AST#ERISK').NE.0)THEN MTR=3 ELSEIF(INPCMX(TYPE,'CIRC#LE').NE.0)THEN MTR=4 ELSEIF(INPCMX(TYPE,'CR#OSS').NE.0)THEN MTR=5 ELSE WRITE (10,'('' !!!!!! GRATTA ERROR : Marker type '',A, - '' not known; no update.'')') TYPE MTR=0 ENDIF IF(MTR.GT.0)MRKTYP=MTR * Marker size IF(SIZE.GT.0.0)MRKSIZ(I)=SIZE * Marker colour IF(COLOUR.NE.' ')THEN CALL GRCOLQ(1,COLOUR,ICOL) IF(ICOL.GT.0)THEN MRKCOL(I)=ICOL ELSE WRITE (10,'('' !!!!!! GRATTT ERROR : Colour '',A, - '' not known, attribute not set.'')') COLOUR ENDIF ENDIF 440 CONTINUE * Check the thing has been found. IF(NSEEN.EQ.0)THEN WRITE (10,'('' !!!!!! GRATTT ERROR : Unknown item '',A, - '' received; no update.'')') ITEM RETURN ENDIF RETURN *** Handle the error conditions. 2000 CONTINUE PRINT *,' ###### GRATTG ERROR : Premature EOF ecountered on '// - FILE(1:NCFILE)//' read via unit 12 ; no valid data read.' CALL INPIOS(IOS) CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) RETURN 2010 CONTINUE PRINT *,' ###### GRATTW ERROR : I/O error accessing '// - FILE(1:NCFILE)//' via unit 12 ; no data read or written.' CALL INPIOS(IOS) CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) RETURN 2030 CONTINUE PRINT *,' ###### GRATTW ERROR : Dataset '//FILE(1:NCFILE)// - ' unit 12 cannot be closed ; results not predictable' CALL INPIOS(IOS) END +DECK,GRASET. SUBROUTINE GRASET(QXMIN,QYMIN,QZMIN,QXMAX,QYMAX,QZMAX) *----------------------------------------------------------------------- * GRASET - Sets the default area. * (Last changed on 8/10/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PARAMETERS. REAL QXMIN,QYMIN,QZMIN,QXMAX,QYMAX,QZMAX *** Copy the limits in double precision. GXMIN=DBLE(QXMIN) GYMIN=DBLE(QYMIN) GZMIN=DBLE(QZMIN) GXMAX=DBLE(QXMAX) GYMAX=DBLE(QYMAX) GZMAX=DBLE(QZMAX) END +DECK,GRBAR. SUBROUTINE GRBAR(XPL,YPL,NPL,XTXT,YTXT,TITLE,FRAME) *---------------------------------------------------------------------- * GRBAR - Subroutine plotting a bar chart of (XPL,YPL). * (Last changed on 26/10/01.) *---------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PARAMETERS. +SEQ,GRAPHICS. +SEQ,PRINTPLOT. CHARACTER*(*) XTXT,YTXT,TITLE CHARACTER*20 STR INTEGER NPL,I,J,NCSTR REAL XPL(*),YPL(*),XMIN,YMIN,XMAX,YMAX,XBAR(5),YBAR(5),BIN,YREF LOGICAL FRAME *** Routine identification. IF(LIDENT)PRINT *,' /// ROUTINE GRBAR /// ' *** Determine maximum and minimum x and y and determine bin width. IF(NPL.GT.1)THEN BIN=ABS(XPL(1)-XPL(2)) ELSE BIN=0.1*ABS(XPL(1)) ENDIF XMIN=XPL(1) XMAX=XPL(1) YMIN=YPL(1) YMAX=YPL(1) DO 10 I=1,NPL IF(XMIN.GT.XPL(I))XMIN=XPL(I) IF(XMAX.LT.XPL(I))XMAX=XPL(I) IF(YMIN.GT.YPL(I))YMIN=YPL(I) IF(YMAX.LT.YPL(I))YMAX=YPL(I) DO 20 J=1,NPL IF(I.EQ.J)GOTO 20 IF(ABS(XPL(I)-XPL(J)).LT.BIN)BIN=ABS(XPL(I)-XPL(J)) 20 CONTINUE 10 CONTINUE *** Debugging information. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GRBAR DEBUG : Bar chart'', - '' plot request.''/ - 26X,''Points: '',I5/ - 26X,''x-Range: '',E15.8,'' - '',E15.8/ - 26X,''y-Range: '',E15.8,'' - '',E15.8/ - 26X,''Bin width: '',E15.8)') NPL,XMIN,XMAX,YMIN,YMAX,BIN *** Adjust the range to make the bar chart look OK. XMIN=XMIN-BIN XMAX=XMAX+BIN YMAX=1.1*YMAX IF(LOGY)THEN YMIN=YMIN/2 YREF=YMIN ELSEIF(YMIN.LT.0)THEN YMIN=1.1*YMIN YREF=0 ELSE YMIN=0 YREF=0 ENDIF *** Plot a frame using GRCART. IF(FRAME)CALL GRCART(XMIN,YMIN,XMAX,YMAX,XTXT,YTXT,TITLE) *** Set the correct graphics representation for the bar chart. IGBAR=IGBAR+1 IF(IGBAR.GT.7)IGBAR=1 CALL OUTFMT(REAL(IGBAR),2,STR,NCSTR,'LEFT') CALL GRATTS('BARCHART-'//STR(1:NCSTR),'AREA') *** Plot the bar chart. DO 30 I=1,NPL XBAR(1)=XPL(I)-BARFRC*BIN/2 YBAR(1)=YREF XBAR(2)=XPL(I)-BARFRC*BIN/2 YBAR(2)=YPL(I) XBAR(3)=XPL(I)+BARFRC*BIN/2 YBAR(3)=YPL(I) XBAR(4)=XPL(I)+BARFRC*BIN/2 YBAR(4)=YREF XBAR(5)=XPL(I)-BARFRC*BIN/2 YBAR(5)=YREF CALL GRAREA(5,XBAR,YBAR) 30 CONTINUE END +DECK,GRCELL. SUBROUTINE GRCELL(VXMIN,VYMIN,VXMAX,VYMAX,TITLE) *----------------------------------------------------------------------- * GRCELL - Draws the cell within the specified region. * (Last changed on 28/10/09.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,FIELDMAP. +SEQ,PRINTPLOT. +SEQ,PARAMETERS. +SEQ,GRAPHICS. DOUBLE PRECISION VVXMIN,VVYMIN,VVXMAX,VVYMAX REAL VXMIN,VYMIN,VXMAX,VYMAX CHARACTER*(*) TITLE *** R-PHI type view. IF(POLAR.OR.PRVIEW.EQ.'R-PHI')THEN CALL GRAPOL(REAL(GXMIN),REAL(GYMIN),REAL(GXMAX),REAL(GYMAX), - 'Radial distances are in cm ', - 'Angles are in degrees ',TITLE) CALL CELLAY(REAL(GXMIN),REAL(GYMIN),REAL(GXMAX),REAL(GYMAX)) IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) VXMIN=REAL(GXMIN) VYMIN=REAL(GYMIN) VXMAX=REAL(GXMAX) VYMAX=REAL(GYMAX) *** X-Y type view. ELSEIF(PRVIEW.EQ.'X-Y')THEN CALL GRCART(REAL(GXMIN),REAL(GYMIN),REAL(GXMAX),REAL(GYMAX), - 'x-Axis [cm]','y-Axis [cm]',TITLE) CALL CELLAY(REAL(GXMIN),REAL(GYMIN),REAL(GXMAX),REAL(GYMAX)) IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) VXMIN=REAL(GXMIN) VYMIN=REAL(GYMIN) VXMAX=REAL(GXMAX) VYMAX=REAL(GYMAX) *** X-Z type view. ELSEIF(PRVIEW.EQ.'X-Z')THEN CALL GRCART(REAL(GXMIN),REAL(GZMIN),REAL(GXMAX),REAL(GZMAX), - 'x-Axis [cm]','z-Axis [cm]',TITLE) IF(LMAPPL)CALL MAPPLT(REAL(GXMIN),REAL(GYMIN),REAL(GZMIN), - REAL(GXMAX),REAL(GYMAX),REAL(GZMAX)) IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) VXMIN=REAL(GXMIN) VYMIN=REAL(GZMIN) VXMAX=REAL(GXMAX) VYMAX=REAL(GZMAX) *** Y-Z type view. ELSEIF(PRVIEW.EQ.'Y-Z')THEN CALL GRCART(REAL(GYMIN),REAL(GZMIN),REAL(GYMAX),REAL(GZMAX), - 'y-Axis [cm]','z-Axis [cm]',TITLE) IF(LMAPPL)CALL MAPPLT(REAL(GXMIN),REAL(GYMIN),REAL(GZMIN), - REAL(GXMAX),REAL(GYMAX),REAL(GZMAX)) IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) VXMIN=REAL(GYMIN) VYMIN=REAL(GZMIN) VXMAX=REAL(GYMAX) VYMAX=REAL(GZMAX) *** CUT type view. ELSEIF(PRVIEW.EQ.'CUT')THEN CALL GRAXIC(VVXMIN,VVYMIN,VVXMAX,VVYMAX,TITLE,'PLOT') CALL CELLAC(VVXMIN,VVYMIN,VVXMAX,VVYMAX) IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) VXMIN=REAL(VVXMIN) VYMIN=REAL(VVYMIN) VXMAX=REAL(VVXMAX) VYMAX=REAL(VVYMAX) *** 3D type view. ELSEIF(PRVIEW.EQ.'3D'.OR.PRVIEW.EQ.'NEBEM')THEN CALL GRAXI3(VVXMIN,VVYMIN,VVXMAX,VVYMAX, - 'x-Axis','y-Axis','z-Axis',TITLE,'PLOT') IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) VXMIN=REAL(VVXMIN) VYMIN=REAL(VVYMIN) VXMAX=REAL(VVXMAX) VYMAX=REAL(VVYMAX) *** Other projections are not known currently. ELSE PRINT *,' !!!!!! GRCELL WARNING : Projection ',PRVIEW, - ' is not known; using Cartesian projection.' CALL GRCART(REAL(GXMIN),REAL(GYMIN),REAL(GXMAX),REAL(GYMAX), - 'x-Axis [cm]','y-Axis [cm]',TITLE) CALL CELLAY(REAL(GXMIN),REAL(GYMIN),REAL(GXMAX),REAL(GYMAX)) IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) VXMIN=REAL(GXMIN) VYMIN=REAL(GYMIN) VXMAX=REAL(GXMAX) VYMAX=REAL(GYMAX) ENDIF *** Get the viewport input priorities right. CALL GSVPIP(1,0,0) END +DECK,GRVIEW. SUBROUTINE GRVIEW(VXMIN,VYMIN,VXMAX,VYMAX) *----------------------------------------------------------------------- * GRVIEW - Computes the view limits of the current projection. * (Last changed on 28/10/09.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,PRINTPLOT. +SEQ,PARAMETERS. +SEQ,GRAPHICS. DOUBLE PRECISION VVXMIN,VVYMIN,VVXMAX,VVYMAX REAL VXMIN,VYMIN,VXMAX,VYMAX *** R-PHI and X-Y types view. IF(POLAR.OR.PRVIEW.EQ.'R-PHI'.OR.PRVIEW.EQ.'X-Y')THEN VXMIN=REAL(GXMIN) VYMIN=REAL(GYMIN) VXMAX=REAL(GXMAX) VYMAX=REAL(GYMAX) *** X-Z type view. ELSEIF(PRVIEW.EQ.'X-Z')THEN VXMIN=REAL(GXMIN) VYMIN=REAL(GZMIN) VXMAX=REAL(GXMAX) VYMAX=REAL(GZMAX) *** Y-Z type view. ELSEIF(PRVIEW.EQ.'Y-Z')THEN VXMIN=REAL(GYMIN) VYMIN=REAL(GZMIN) VXMAX=REAL(GYMAX) VYMAX=REAL(GZMAX) *** CUT type view. ELSEIF(PRVIEW.EQ.'CUT')THEN CALL GRAXIC(VVXMIN,VVYMIN,VVXMAX,VVYMAX,' ','VIEW') VXMIN=REAL(VVXMIN) VYMIN=REAL(VVYMIN) VXMAX=REAL(VVXMAX) VYMAX=REAL(VVYMAX) *** 3D type view. ELSEIF(PRVIEW.EQ.'3D'.OR.PRVIEW.EQ.'NEBEM')THEN CALL GRAXI3(VVXMIN,VVYMIN,VVXMAX,VVYMAX, - ' ',' ',' ',' ','VIEW') VXMIN=REAL(VVXMIN) VYMIN=REAL(VVYMIN) VXMAX=REAL(VVXMAX) VYMAX=REAL(VVYMAX) *** Other projections are not known currently. ELSE PRINT *,' !!!!!! GRVIEW WARNING : Projection ',PRVIEW, - ' is not known; using Cartesian projection.' VXMIN=REAL(GXMIN) VYMIN=REAL(GYMIN) VXMAX=REAL(GXMAX) VYMAX=REAL(GYMAX) ENDIF END +DECK,GRAXIC. SUBROUTINE GRAXIC(VXMIN,VYMIN,VXMAX,VYMAX,TITLE,OPTION) *----------------------------------------------------------------------- * GRAXIC - Draws axis for the cell, using any kind of axis, * respecting the viewing plane labels. * Variables : VXMIN etc : Viewing area limits. * TITLE : Global title. * OPTION : VIEW (compute view) or PLOT (plot frame) * (Last changed on 26/10/07.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PARAMETERS. +SEQ,CONSTANTS. +SEQ,GRAPHICS. +SEQ,CELLDATA. CHARACTER*(*) TITLE,OPTION DOUBLE PRECISION XX(8),YY(8),ZZ(8), - XPL(40),YPL(40),ZPL(40),XCUT,YCUT,VXMIN,VXMAX,VYMIN,VYMAX, - PHIARR,U4,U1,U2,U3,V4,V1,V2,V3,UUMIN,UUMAX,VVMIN,VVMAX INTEGER I,J,NPL,II,JJ,IADJAC(8,3),IMARK,ITYPE LOGICAL IN(8),CUT,PLOTX,PLOTY +SELF,IF=SAVE. SAVE IADJAC +SELF. *** Adjacency tables. DATA (IADJAC(I,1),I=1,8) /2, 1, 1, 2, 1, 2, 3, 4/ DATA (IADJAC(I,2),I=1,8) /3, 4, 4, 3, 6, 5, 5, 6/ DATA (IADJAC(I,3),I=1,8) /5, 6, 7, 8, 7, 8, 8, 7/ *** Initialise the list of corners. DO 10 I=1,8 IN(I)=.FALSE. IF(2*(I/2).EQ.I)THEN XX(I)=GXMAX ELSE XX(I)=GXMIN ENDIF II=(I+1)/2 IF(2*(II/2).EQ.II)THEN YY(I)=GYMAX ELSE YY(I)=GYMIN ENDIF II=(II+1)/2 IF(2*(II/2).EQ.II)THEN ZZ(I)=GZMAX ELSE ZZ(I)=GZMIN ENDIF 10 CONTINUE *** Add the corners of the box that are in the viewing plane. NPL=0 DO 20 I=1,8 IF(ABS(FPROJA*XX(I)+FPROJB*YY(I)+FPROJC*ZZ(I)-FPROJD).LT. - 1.0D-6*MAX(ABS(XX(I)),ABS(YY(I)),ABS(ZZ(I)), - ABS(FPROJA),ABS(FPROJB),ABS(FPROJC),ABS(FPROJD)))THEN IN(I)=.TRUE. CALL PLACOO(XX(I),YY(I),ZZ(I),XCUT,YCUT) NPL=NPL+1 XPL(NPL)=XCUT YPL(NPL)=YCUT ENDIF 20 CONTINUE *** Cut the 12 edges with the viewing plane. DO 30 I=1,8 DO 40 JJ=1,3 J=IADJAC(I,JJ) IF(J.LT.I)GOTO 40 IF(.NOT.(IN(I).OR.IN(J)))THEN CALL PLACUT(XX(I),YY(I),ZZ(I),XX(J),YY(J),ZZ(J), - XCUT,YCUT,CUT) IF(CUT)THEN NPL=NPL+1 XPL(NPL)=XCUT YPL(NPL)=YCUT ENDIF ENDIF 40 CONTINUE 30 CONTINUE *** Ensure there is no butterfly. DO 70 I=1,NPL ZPL(I)=0 70 CONTINUE CALL BUTFLD(NPL,XPL,YPL,ZPL) *** Determine the minimum Cartesian frame that fits around this. IF(NPL.EQ.0)THEN PRINT *,' !!!!!! GRAXIC WARNING : AREA has no point in'// - ' common with the viewing plane; unit frame.' VXMIN=-1 VXMAX=+1 VYMIN=-1 VYMAX=+1 IMARK=0 ITYPE=0 ELSEIF(NPL.EQ.1)THEN PRINT *,' !!!!!! GRAXIC WARNING : AREA has only a point'// - ' in the viewing plane; unit sized frame.' VXMIN=XPL(1)-1 VXMAX=XPL(1)+1 VYMIN=YPL(1)-1 VYMAX=YPL(1)+1 IMARK=0 ITYPE=0 ELSEIF(NPL.EQ.2)THEN PRINT *,' !!!!!! GRAXIC WARNING : AREA has only a line'// - ' in the viewing plane; frame enlarged.' VXMIN=MIN(XPL(1),XPL(2))-1 VXMAX=MAX(XPL(1),XPL(2))+1 VYMIN=MIN(YPL(1),YPL(2))-1 VYMAX=MAX(YPL(1),YPL(2))+1 IMARK=0 ITYPE=0 ELSE IMARK=0 ITYPE=0 VXMIN=XPL(1)+ABS(XPL(1))+1 VXMAX=XPL(1)-ABS(XPL(1))-1 VYMIN=YPL(1)+ABS(YPL(1))+1 VYMAX=YPL(1)-ABS(YPL(1))-1 DO 50 I=1,NPL IF(VXMIN.GT.XPL(I))THEN VXMIN=XPL(I) IMARK=I ITYPE=2 ENDIF IF(VXMAX.LT.XPL(I))THEN VXMAX=XPL(I) IMARK=I ITYPE=4 ENDIF IF(VYMIN.GT.YPL(I))THEN VYMIN=YPL(I) IMARK=I ITYPE=1 ENDIF IF(VYMAX.LT.YPL(I))THEN VYMAX=YPL(I) IMARK=I ITYPE=3 ENDIF 50 CONTINUE ENDIF *** Return here unless OPTION has been set to PLOT. IF(OPTION.NE.'PLOT')RETURN *** Plot a coordinate frame. CALL GRCART(REAL(VXMIN),REAL(VYMIN),REAL(VXMAX),REAL(VYMAX), - PXLAB(1:NCXLAB),PYLAB(1:NCYLAB),TITLE) IF(PROLAB(1:NCFPRO).NE.'z=0')CALL GRCOMM(5,'Viewing plane: '// - PROLAB(1:NCFPRO)) *** Plot the outline that corresponds to the AREA. IF(NPL.GT.2.AND.NPL+IMARK+5.LT.40.AND.ITYPE.NE.0.AND. - IMARK.NE.0)THEN * Mark the area outsize the AREA. DO 60 I=1,NPL IF(I.GT.NPL-IMARK+1)THEN XPL(I+IMARK-1)=XPL(I+IMARK-1-NPL) YPL(I+IMARK-1)=YPL(I+IMARK-1-NPL) ENDIF 60 CONTINUE XPL(NPL+IMARK)=XPL(IMARK) YPL(NPL+IMARK)=YPL(IMARK) IF(ITYPE.EQ.1)THEN XPL(NPL+IMARK+1)=VXMIN YPL(NPL+IMARK+1)=VYMIN XPL(NPL+IMARK+2)=VXMIN YPL(NPL+IMARK+2)=VYMAX XPL(NPL+IMARK+3)=VXMAX YPL(NPL+IMARK+3)=VYMAX XPL(NPL+IMARK+4)=VXMAX YPL(NPL+IMARK+4)=VYMIN XPL(NPL+IMARK+5)=VXMIN YPL(NPL+IMARK+5)=VYMIN ELSEIF(ITYPE.EQ.2)THEN XPL(NPL+IMARK+1)=VXMIN YPL(NPL+IMARK+1)=VYMAX XPL(NPL+IMARK+2)=VXMAX YPL(NPL+IMARK+2)=VYMAX XPL(NPL+IMARK+3)=VXMAX YPL(NPL+IMARK+3)=VYMIN XPL(NPL+IMARK+4)=VXMIN YPL(NPL+IMARK+4)=VYMIN XPL(NPL+IMARK+5)=VXMIN YPL(NPL+IMARK+5)=VYMAX ELSEIF(ITYPE.EQ.3)THEN XPL(NPL+IMARK+1)=VXMAX YPL(NPL+IMARK+1)=VYMAX XPL(NPL+IMARK+2)=VXMAX YPL(NPL+IMARK+2)=VYMIN XPL(NPL+IMARK+3)=VXMIN YPL(NPL+IMARK+3)=VYMIN XPL(NPL+IMARK+4)=VXMIN YPL(NPL+IMARK+4)=VYMAX XPL(NPL+IMARK+5)=VXMAX YPL(NPL+IMARK+5)=VYMAX ELSEIF(ITYPE.EQ.4)THEN XPL(NPL+IMARK+1)=VXMAX YPL(NPL+IMARK+1)=VYMIN XPL(NPL+IMARK+2)=VXMIN YPL(NPL+IMARK+2)=VYMIN XPL(NPL+IMARK+3)=VXMIN YPL(NPL+IMARK+3)=VYMAX XPL(NPL+IMARK+4)=VXMAX YPL(NPL+IMARK+4)=VYMAX XPL(NPL+IMARK+5)=VXMAX YPL(NPL+IMARK+5)=VYMIN ENDIF XPL(NPL+IMARK+6)=XPL(IMARK) YPL(NPL+IMARK+6)=YPL(IMARK) * Fill the excluded area. CALL GRATTS('OUTSIDE-AREA','AREA') CALL GRARE2(NPL+7,XPL(IMARK),YPL(IMARK)) * Outline. CALL GRATTS('BOX-TICKMARKS','POLYLINE') CALL GRLIN2(NPL+6,XPL(IMARK),YPL(IMARK)) ENDIF *** Display the coordinate axes, first compute locations. IF(PROLAB(1:NCFPRO).NE.'z=0'.OR.PROROT.NE.0)THEN CALL PLACOO(0.0D0,0.0D0,0.0D0,U4,V4) CALL PLACOO(1.0D0,0.0D0,0.0D0,U1,V1) CALL PLACOO(0.0D0,1.0D0,0.0D0,U2,V2) CALL PLACOO(0.0D0,0.0D0,1.0D0,U3,V3) UUMIN=MIN(U4,U1,U2,U3) UUMAX=MAX(U4,U1,U2,U3) VVMIN=MIN(V4,V1,V2,V3) VVMAX=MAX(V4,V1,V2,V3) ENDIF * Proceed only if this worked and if the frame is not degenerate. IF(MAX(UUMAX-UUMIN,VVMAX-VVMIN).GT.0.AND. - (PROLAB(1:NCFPRO).NE.'z=0'.OR.PROROT.NE.0))THEN U4=0.02+0.06*(U4-UUMIN)/MAX(UUMAX-UUMIN,VVMAX-VVMIN) U1=0.02+0.06*(U1-UUMIN)/MAX(UUMAX-UUMIN,VVMAX-VVMIN) U2=0.02+0.06*(U2-UUMIN)/MAX(UUMAX-UUMIN,VVMAX-VVMIN) U3=0.02+0.06*(U3-UUMIN)/MAX(UUMAX-UUMIN,VVMAX-VVMIN) V4=0.02+0.06*(V4-VVMIN)/MAX(UUMAX-UUMIN,VVMAX-VVMIN) V1=0.02+0.06*(V1-VVMIN)/MAX(UUMAX-UUMIN,VVMAX-VVMIN) V2=0.02+0.06*(V2-VVMIN)/MAX(UUMAX-UUMIN,VVMAX-VVMIN) V3=0.02+0.06*(V3-VVMIN)/MAX(UUMAX-UUMIN,VVMAX-VVMIN) * Set representations. CALL GRATTS('BOX-TICKMARKS','POLYLINE') CALL GRATTS('NUMBERS','TEXT') CALL GSTXAL(2,3) CALL GSCHUP(0.0,1.0) * Switch to normalisation transformation 0. CALL GSELNT(0) * Plot the x-axis. IF(ABS(U1-U4).GT.0.001.OR.ABS(V1-V4).GT.0.001)THEN XPL(1)=DISPX0+U4 XPL(2)=DISPX0+U1 YPL(1)=DISPY0+V4 YPL(2)=DISPY0+V1 CALL GPL2(2,XPL,YPL) PHIARR=ATAN2(YPL(2)-YPL(1),XPL(2)-XPL(1)) XPL(1)=DISPX0+U1-SQRT((U1-U4)**2+(V1-V4)**2)* - 0.2*COS(PHIARR+ARRANG) YPL(1)=DISPY0+V1-SQRT((U1-U4)**2+(V1-V4)**2)* - 0.2*SIN(PHIARR+ARRANG) XPL(2)=DISPX0+U1 YPL(2)=DISPY0+V1 XPL(3)=DISPX0+U1-SQRT((U1-U4)**2+(V1-V4)**2)* - 0.2*COS(PHIARR-ARRANG) YPL(3)=DISPY0+V1-SQRT((U1-U4)**2+(V1-V4)**2)* - 0.2*SIN(PHIARR-ARRANG) CALL GPL2(3,XPL,YPL) CALL GTX(DISPX0+REAL(U4+1.2*(U1-U4)), - DISPY0+REAL(V4+1.2*(V1-V4)),'x') PLOTX=.TRUE. ELSE PLOTX=.FALSE. ENDIF * Plot the y-axis, if different from the x-axis. IF((ABS(U2-U4).GT.0.001.OR.ABS(V2-V4).GT.0.001).AND. - (ABS(U2-U1).GT.0.001.OR.ABS(V2-V1).GT.0.001.OR. - .NOT.PLOTX))THEN XPL(1)=DISPX0+U4 XPL(2)=DISPX0+U2 YPL(1)=DISPY0+V4 YPL(2)=DISPY0+V2 CALL GPL2(2,XPL,YPL) PHIARR=ATAN2(YPL(2)-YPL(1),XPL(2)-XPL(1)) XPL(1)=DISPX0+U2-SQRT((U2-U4)**2+(V2-V4)**2)* - 0.2*COS(PHIARR+ARRANG) YPL(1)=DISPY0+V2-SQRT((U2-U4)**2+(V2-V4)**2)* - 0.2*SIN(PHIARR+ARRANG) XPL(2)=DISPX0+U2 YPL(2)=DISPY0+V2 XPL(3)=DISPX0+U2-SQRT((U2-U4)**2+(V2-V4)**2)* - 0.2*COS(PHIARR-ARRANG) YPL(3)=DISPY0+V2-SQRT((U2-U4)**2+(V2-V4)**2)* - 0.2*SIN(PHIARR-ARRANG) CALL GPL2(3,XPL,YPL) CALL GTX(DISPX0+REAL(U4+1.2*(U2-U4)), - DISPY0+REAL(V4+1.2*(V2-V4)),'y') PLOTY=.TRUE. ELSE PLOTY=.FALSE. ENDIF * Plot the z-axis, if different from the x- and y-axes. IF((ABS(U3-U4).GT.0.001.OR.ABS(V3-V4).GT.0.001).AND. - (ABS(U3-U1).GT.0.001.OR.ABS(V3-V1).GT.0.001.OR. - .NOT.PLOTX).AND. - (ABS(U3-U2).GT.0.001.OR.ABS(V3-V2).GT.0.001.OR. - .NOT.PLOTY))THEN XPL(1)=DISPX0+U4 XPL(2)=DISPX0+U3 YPL(1)=DISPY0+V4 YPL(2)=DISPY0+V3 CALL GPL2(2,XPL,YPL) PHIARR=ATAN2(YPL(2)-YPL(1),XPL(2)-XPL(1)) XPL(1)=DISPX0+U3-SQRT((U3-U4)**2+(V3-V4)**2)* - 0.2*COS(PHIARR+ARRANG) YPL(1)=DISPY0+V3-SQRT((U3-U4)**2+(V3-V4)**2)* - 0.2*SIN(PHIARR+ARRANG) XPL(2)=DISPX0+U3 YPL(2)=DISPY0+V3 XPL(3)=DISPX0+U3-SQRT((U3-U4)**2+(V3-V4)**2)* - 0.2*COS(PHIARR-ARRANG) YPL(3)=DISPY0+V3-SQRT((U3-U4)**2+(V3-V4)**2)* - 0.2*SIN(PHIARR-ARRANG) CALL GPL2(3,XPL,YPL) CALL GTX(DISPX0+REAL(U4+1.2*(U3-U4)), - DISPY0+REAL(V4+1.2*(V3-V4)),'z') ENDIF * Switch back to normalisation transformation 1. CALL GSELNT(1) ENDIF *** Get the viewport input priorities right. CALL GSVPIP(1,0,0) *** Reset the bar chart and histogram counters. IGBAR=0 IGHIST=0 END +DECK,GRAXI3. SUBROUTINE GRAXI3(VXMIN,VYMIN,VXMAX,VYMAX, - XTXT,YTXT,ZTXT,TITLE,OPTION) *---------------------------------------------------------------------- * GRAXI3 - Plots axes for a 3D view, with tickmarks along them. * VARIABLES : VXMIN etc : View limits. * [X/Y/Z]TXT : Labels for the x, y and z axes * TITLE : Global title. * OPTION : VIEW (compute view) or PLOT (plot frame). * (Last changed on 5/ 8/02.) *---------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PARAMETERS. +SEQ,GRAPHICS. +SEQ,CONSTANTS. +SEQ,PRINTPLOT. DOUBLE PRECISION XU(101),YU(101), - XUTOD,YUTOD,X,Y,DX,DY,DZ, - TICKX,TICKY,TICKZ,XVAL,YVAL,ZVAL,XSC,YSC,XAUX,YAUX, - X1,X2,X3,X4,X5,X6,X7,X8,Y1,Y2,Y3,Y4,Y5,Y6,Y7,Y8, - XLAB,YLAB,ZLAB,QLAB,XSHIFT,YSHIFT,SNORM,XPERP,YPERP, - WW,ASPECT,VXMIN,VYMIN,VXMAX,VYMAX INTEGER KX,KKX,KY,KKY,KZ,KKZ,NCTICK,NC,I,ICOL LOGICAL INVERT,SEEN(12) CHARACTER*(*) XTXT,YTXT,ZTXT,TITLE,OPTION CHARACTER*80 STRING CHARACTER*13 TICK *** Define 2 statement function to convert from USER to DISP. XUTOD(X)=DISPX0+(DISPX1-DISPX0)*(X-USERX0)/(USERX1-USERX0) YUTOD(Y)=DISPY0+(DISPY1-DISPY0)*(Y-USERY0)/(USERY1-USERY0) *** Output the requested area, if debugging is requested. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GRAXI3 DEBUG :'', - '' Requested area is ''/26X,''('',E10.3,'','',E10.3,'','', - E10.3,'') to''/26X,''('',E10.3,'','',E10.3,'','',E10.3, - '')'')') GXMIN,GYMIN,GZMIN,GXMAX,GYMAX,GZMAX *** Compute dimensions of projected box. CALL PLACOO(GXMIN,GYMIN,GZMIN,X1,Y1) CALL PLACOO(GXMIN,GYMIN,GZMAX,X2,Y2) CALL PLACOO(GXMIN,GYMAX,GZMIN,X3,Y3) CALL PLACOO(GXMIN,GYMAX,GZMAX,X4,Y4) CALL PLACOO(GXMAX,GYMIN,GZMIN,X5,Y5) CALL PLACOO(GXMAX,GYMIN,GZMAX,X6,Y6) CALL PLACOO(GXMAX,GYMAX,GZMIN,X7,Y7) CALL PLACOO(GXMAX,GYMAX,GZMAX,X8,Y8) *** Compute frame size. VXMIN=MIN(X1,X2,X3,X4,X5,X6,X7,X8) VXMAX=MAX(X1,X2,X3,X4,X5,X6,X7,X8) VYMIN=MIN(Y1,Y2,Y3,Y4,Y5,Y6,Y7,Y8) VYMAX=MAX(Y1,Y2,Y3,Y4,Y5,Y6,Y7,Y8) *** Return here unless OPTION has been set to PLOT. IF(INDEX(OPTION,'PLOT').EQ.0)RETURN *** Store frame size. FRXMIN=VXMIN FRXMAX=VXMAX FRYMIN=VYMIN FRYMAX=VYMAX IF(FRXMAX.EQ.FRXMIN)THEN PRINT *,' !!!!!! GRAXI3 WARNING : Frame has zero size in'// - ' x; enlarged.' FRXMIN=FRXMIN-2*ABS(FRXMIN)-1 FRXMAX=FRXMAX+2*ABS(FRXMAX)+1 ENDIF IF(FRYMAX.EQ.FRYMIN)THEN PRINT *,' !!!!!! GRAXI3 WARNING : Frame has zero size in'// - ' y; enlarged.' FRYMIN=FRYMIN-2*ABS(FRYMIN)-1 FRYMAX=FRYMAX+2*ABS(FRYMAX)+1 ENDIF *** Compute aspect ratio. IF(FRYMAX.EQ.FRYMIN.OR.FRXMAX.EQ.FRXMIN)THEN ASPECT=1 PRINT *,' !!!!!! GRAXI3 WARNING : Aspect ratio 0'// - ' or infinite; set to 1 (program bug)' ELSE ASPECT=SQRT(ABS((FRXMAX-FRXMIN)/(FRYMAX-FRYMIN))) ENDIF *** Switch to graphics mode. CALL GRGRAF(.TRUE.) *** Define display area of frame. CALL GSVP(1,DISPX0,DISPX1,DISPY0,DISPY1) *** Define the user area in the plot frame. USERX0=FRXMIN-0.1*(FRXMAX-FRXMIN)/(DISPX1-DISPX0-0.2) USERX1=FRXMAX+0.1*(FRXMAX-FRXMIN)/(DISPX1-DISPX0-0.2) USERY0=FRYMIN-0.1*(FRYMAX-FRYMIN)/(DISPY1-DISPY0-0.2) USERY1=FRYMAX+0.1*(FRYMAX-FRYMIN)/(DISPY1-DISPY0-0.2) CALL GSWN(1,USERX0,USERX1,USERY0,USERY1) CALL GSTXP(0) *** Shade the planes in which the light shines, set the representation. CALL GSELNT(1) CALL GRATTS('BOX-TICKMARKS','AREA') CALL GRATTS('BOX-TICKMARKS','POLYLINE') * Generate the colour table. IF(ICOLBX.EQ.0)THEN ICOLBX=ICOL0 CALL COLSHD(ICOLBX) ICOL0=ICOL0+NPRCOL ENDIF * Set the SEEN flags for the edges of the box. DO 100 I=1,12 SEEN(I)=.FALSE. 100 CONTINUE * The x=xmin plane. IF(FPROJA.GT.0)THEN CALL COLWGT(+1.0D0,0.0D0,0.0D0,WW) IF(WW.GE.0)THEN ICOL=ICOLBX+2+MIN(NINT(WW*(NPRCOL-1)),NPRCOL-3) ELSE ICOL=ICOLBX PRINT *,' !!!!!! GRAXI3 WARNING : Request to plot'// - ' a face seen from the back (program bug).' ENDIF CALL GSFACI(ICOL) XU(1)=X1 YU(1)=Y1 XU(2)=X3 YU(2)=Y3 XU(3)=X4 YU(3)=Y4 XU(4)=X2 YU(4)=Y2 XU(5)=X1 YU(5)=Y1 CALL GFA2(5,XU,YU) CALL GPL2(5,XU,YU) SEEN(1)=.TRUE. SEEN(2)=.TRUE. SEEN(3)=.TRUE. SEEN(4)=.TRUE. * Or the x=xmax plane. ELSEIF(FPROJA.LT.0)THEN CALL COLWGT(-1.0D0,0.0D0,0.0D0,WW) IF(WW.GE.0)THEN ICOL=ICOLBX+2+MIN(NINT(WW*(NPRCOL-1)),NPRCOL-3) ELSE ICOL=ICOLBX PRINT *,' !!!!!! GRAXI3 WARNING : Request to plot'// - ' a face seen from the back (program bug).' ENDIF CALL GSFACI(ICOL) XU(1)=X5 YU(1)=Y5 XU(2)=X7 YU(2)=Y7 XU(3)=X8 YU(3)=Y8 XU(4)=X6 YU(4)=Y6 XU(5)=X5 YU(5)=Y5 CALL GFA2(5,XU,YU) CALL GPL2(5,XU,YU) SEEN(5)=.TRUE. SEEN(6)=.TRUE. SEEN(7)=.TRUE. SEEN(8)=.TRUE. ENDIF * The y=ymin plane. IF(FPROJB.GT.0)THEN CALL COLWGT(0.0D0,+1.0D0,0.0D0,WW) IF(WW.GE.0)THEN ICOL=ICOLBX+2+MIN(NINT(WW*(NPRCOL-1)),NPRCOL-3) ELSE ICOL=ICOLBX PRINT *,' !!!!!! GRAXI3 WARNING : Request to plot'// - ' a face seen from the back (program bug).' ENDIF CALL GSFACI(ICOL) XU(1)=X1 YU(1)=Y1 XU(2)=X2 YU(2)=Y2 XU(3)=X6 YU(3)=Y6 XU(4)=X5 YU(4)=Y5 XU(5)=X1 YU(5)=Y1 CALL GFA2(5,XU,YU) CALL GPL2(5,XU,YU) SEEN(1)=.TRUE. SEEN(5)=.TRUE. SEEN(9)=.TRUE. SEEN(12)=.TRUE. * Or the y=ymax plane. ELSEIF(FPROJB.LT.0)THEN CALL COLWGT(0.0D0,-1.0D0,0.0D0,WW) IF(WW.GE.0)THEN ICOL=ICOLBX+2+MIN(NINT(WW*(NPRCOL-1)),NPRCOL-3) ELSE ICOL=ICOLBX PRINT *,' !!!!!! GRAXI3 WARNING : Request to plot'// - ' a face seen from the back (program bug).' ENDIF CALL GSFACI(ICOL) XU(1)=X3 YU(1)=Y3 XU(2)=X4 YU(2)=Y4 XU(3)=X8 YU(3)=Y8 XU(4)=X7 YU(4)=Y7 XU(5)=X3 YU(5)=Y3 CALL GFA2(5,XU,YU) CALL GPL2(5,XU,YU) SEEN(3)=.TRUE. SEEN(7)=.TRUE. SEEN(10)=.TRUE. SEEN(11)=.TRUE. ENDIF * The z=zmin plane. IF(FPROJC.GT.0)THEN CALL COLWGT(0.0D0,0.0D0,+1.0D0,WW) IF(WW.GE.0)THEN ICOL=ICOLBX+2+MIN(NINT(WW*(NPRCOL-1)),NPRCOL-3) ELSE ICOL=ICOLBX PRINT *,' !!!!!! GRAXI3 WARNING : Request to plot'// - ' a face seen from the back (program bug).' ENDIF CALL GSFACI(ICOL) XU(1)=X1 YU(1)=Y1 XU(2)=X3 YU(2)=Y3 XU(3)=X7 YU(3)=Y7 XU(4)=X5 YU(4)=Y5 XU(5)=X1 YU(5)=Y1 CALL GFA2(5,XU,YU) CALL GPL2(5,XU,YU) SEEN(2)=.TRUE. SEEN(6)=.TRUE. SEEN(9)=.TRUE. SEEN(10)=.TRUE. * Or the z=zmax plane. ELSEIF(FPROJC.LT.0)THEN CALL COLWGT(0.0D0,0.0D0,-1.0D0,WW) IF(WW.GE.0)THEN ICOL=ICOLBX+2+MIN(NINT(WW*(NPRCOL-1)),NPRCOL-3) ELSE ICOL=ICOLBX PRINT *,' !!!!!! GRAXI3 WARNING : Request to plot'// - ' a face seen from the back (program bug).' ENDIF CALL GSFACI(ICOL) XU(1)=X2 YU(1)=Y2 XU(2)=X4 YU(2)=Y4 XU(3)=X8 YU(3)=Y8 XU(4)=X6 YU(4)=Y6 XU(5)=X2 YU(5)=Y2 CALL GFA2(5,XU,YU) CALL GPL2(5,XU,YU) SEEN(4)=.TRUE. SEEN(8)=.TRUE. SEEN(11)=.TRUE. SEEN(12)=.TRUE. ENDIF *** Find a reasonable scale order-of-magnitude in x. KX=INT(LOG10(GXMAX-GXMIN)) IF(LOG10(GXMAX-GXMIN).LT.0.0)KX=KX-1 DX=(GXMAX-GXMIN)/10.0**KX IF(DX.LT.2.0)DX=0.1 IF(DX.GE.2.0.AND.DX.LT.5.0)DX=0.2 IF(DX.GE.5.0)DX=0.5 DX=DX*10.0**KX IF(KX.GE.0.AND.KX.LE.1)THEN KKX=0 ELSEIF(INDEX(OPTION,'NOCELL').NE.0)THEN KKX=3*INT(LOG10(GXMAX-GXMIN)/3.0) IF(GXMAX-GXMIN.LT.0.1)KKX=KKX-3 ELSE KKX=2+3*INT(LOG10(0.01*(GXMAX-GXMIN))/3.0) IF(0.01*(GXMAX-GXMIN).LT.0.1)KKX=KKX-3 ENDIF * And same thing in y. KY=INT(LOG10(GYMAX-GYMIN)) IF(LOG10(GYMAX-GYMIN).LT.0.0)KY=KY-1 DY=(GYMAX-GYMIN)/10.0**KY IF(DY.LT.2.0)DY=0.1 IF(DY.GE.2.0.AND.DY.LT.5.0)DY=0.2 IF(DY.GE.5.0)DY=0.5 DY=DY*10.0**KY IF(KY.GE.0.AND.KY.LE.1)THEN KKY=0 ELSEIF(INDEX(OPTION,'NOCELL').NE.0)THEN KKY=3*INT(LOG10(GYMAX-GYMIN)/3.0) IF(GYMAX-GYMIN.LT.0.1)KKY=KKY-3 ELSE KKY=2+3*INT(LOG10(0.01*(GYMAX-GYMIN))/3.0) IF(0.01*(GYMAX-GYMIN).LT.0.1)KKY=KKY-3 ENDIF * And same thing in z. KZ=INT(LOG10(GZMAX-GZMIN)) IF(LOG10(GZMAX-GZMIN).LT.0.0)KZ=KZ-1 DZ=(GZMAX-GZMIN)/10.0**KZ IF(DZ.LT.2.0)DZ=0.1 IF(DZ.GE.2.0.AND.DZ.LT.5.0)DZ=0.2 IF(DZ.GE.5.0)DZ=0.5 DZ=DZ*10.0**KZ IF(KZ.GE.0.AND.KZ.LE.1)THEN KKZ=0 ELSEIF(INDEX(OPTION,'NOCELL').NE.0)THEN KKZ=3*INT(LOG10(GZMAX-GZMIN)/3.0) IF(GZMAX-GZMIN.LT.0.1)KKZ=KKZ-3 ELSE KKZ=2+3*INT(LOG10(0.01*(GZMAX-GZMIN))/3.0) IF(0.01*(GZMAX-GZMIN).LT.0.1)KKZ=KKZ-3 ENDIF *** Calculate the length of a tick mark. TICKX=(GXMAX-GXMIN)/100.0 TICKY=(GYMAX-GYMIN)/100.0 TICKZ=(GZMAX-GZMIN)/100.0 IF(LDEBUG)WRITE(10,'('' ++++++ GRAXI3 DEBUG : Tickmark size'', - '' in x='',E12.5,'' in y='',E12.5,'' in z='',E12.5)') - TICKX,TICKY,TICKZ *** x-Axis: tickmarks and scales. CALL GSTXAL(1,3) CALL GRATTS('NUMBERS','TEXT') * Determine optimal side to label. XPERP=Y6-Y2 YPERP=X2-X6 IF(XPERP+YPERP.GT.0)THEN XPERP=-XPERP YPERP=-YPERP INVERT=.TRUE. ELSE INVERT=.FALSE. ENDIF YLAB=GYMIN ZLAB=GZMIN QLAB=XPERP*X1+YPERP*Y1 IF(XPERP*X2+YPERP*Y2.GT.QLAB)THEN QLAB=XPERP*X2+YPERP*Y2 YLAB=GYMIN ZLAB=GZMAX ENDIF IF(XPERP*X3+YPERP*Y3.GT.QLAB)THEN QLAB=XPERP*X3+YPERP*Y3 YLAB=GYMAX ZLAB=GZMIN ENDIF IF(XPERP*X4+YPERP*Y4.GT.QLAB)THEN QLAB=XPERP*X2+YPERP*Y2 YLAB=GYMAX ZLAB=GZMAX ENDIF XSHIFT=XUTOD(XPERP)-XUTOD(0.0D0) YSHIFT=YUTOD(YPERP)-YUTOD(0.0D0) SNORM=SQRT(XSHIFT**2+YSHIFT**2) IF(SNORM.GT.0)THEN XSHIFT=XSHIFT/SNORM YSHIFT=YSHIFT/SNORM ENDIF * Loop over the intervals. DO 10 I=0,1+INT((GXMAX-GXMIN)/DX) XVAL=DX*(INT(GXMIN/DX)+I) IF(GXMIN.GE.XVAL.OR.XVAL.GE.GXMAX.OR. - (FPROJB.EQ.0.AND.FPROJC.EQ.0))GOTO 10 * Tickmarks. IF(SEEN(9))THEN CALL PLACOO(XVAL,GYMIN,GZMIN,XU(1),YU(1)) CALL PLACOO(XVAL,GYMIN+TICKY,GZMIN+TICKZ,XU(2),YU(2)) CALL GPL2(2,XU,YU) ENDIF IF(SEEN(12))THEN CALL PLACOO(XVAL,GYMIN,GZMAX,XU(1),YU(1)) CALL PLACOO(XVAL,GYMIN+TICKY,GZMAX-TICKZ,XU(2),YU(2)) CALL GPL2(2,XU,YU) ENDIF IF(SEEN(10))THEN CALL PLACOO(XVAL,GYMAX,GZMIN,XU(1),YU(1)) CALL PLACOO(XVAL,GYMAX-TICKY,GZMIN+TICKZ,XU(2),YU(2)) CALL GPL2(2,XU,YU) ENDIF IF(SEEN(11))THEN CALL PLACOO(XVAL,GYMAX,GZMAX,XU(1),YU(1)) CALL PLACOO(XVAL,GYMAX-TICKY,GZMAX-TICKZ,XU(2),YU(2)) CALL GPL2(2,XU,YU) ENDIF * Optional grid. IF(LGRID)THEN CALL GRATTS('GRID','POLYLINE') IF(FPROJB.GT.0)THEN CALL PLACOO(XVAL,GYMIN,GZMIN+TICKZ,XU(1),YU(1)) CALL PLACOO(XVAL,GYMIN,GZMAX-TICKZ,XU(2),YU(2)) CALL GPL2(2,XU,YU) ELSEIF(FPROJB.LT.0)THEN CALL PLACOO(XVAL,GYMAX,GZMIN+TICKZ,XU(1),YU(1)) CALL PLACOO(XVAL,GYMAX,GZMAX-TICKZ,XU(2),YU(2)) CALL GPL2(2,XU,YU) ENDIF IF(FPROJC.GT.0)THEN CALL PLACOO(XVAL,GYMIN+TICKY,GZMIN,XU(1),YU(1)) CALL PLACOO(XVAL,GYMAX-TICKY,GZMIN,XU(2),YU(2)) CALL GPL2(2,XU,YU) ELSEIF(FPROJC.LT.0)THEN CALL PLACOO(XVAL,GYMIN+TICKY,GZMAX,XU(1),YU(1)) CALL PLACOO(XVAL,GYMAX-TICKY,GZMAX,XU(2),YU(2)) CALL GPL2(2,XU,YU) ENDIF CALL GRATTS('BOX-TICKMARKS','POLYLINE') ENDIF * Scale. CALL OUTFMT(REAL(XVAL/10.0**KKX),2,TICK,NCTICK,'LEFT') IF(XPERP.LT.0)THEN CALL GSCHUP(REAL(YPERP/ASPECT),REAL(-XPERP*ASPECT)) CALL GSTXAL(3,3) ELSE CALL GSCHUP(REAL(-YPERP/ASPECT),REAL(XPERP*ASPECT)) CALL GSTXAL(1,3) ENDIF CALL PLACOO(XVAL,YLAB,ZLAB,XAUX,YAUX) XSC=XUTOD(XAUX)+0.01*XSHIFT YSC=YUTOD(YAUX)+0.01*YSHIFT CALL GSELNT(0) CALL GRTX(REAL(XSC),REAL(YSC),TICK(1:NCTICK)) CALL GSELNT(1) 10 CONTINUE * Label the axis. IF(FPROJB.NE.0.OR.FPROJC.NE.0)THEN STRING=XTXT NC=LEN(XTXT) IF(INDEX(OPTION,'NOCELL').NE.0)THEN IF(KKX.NE.0)THEN CALL OUTFMT(REAL(KKX),2,TICK,NCTICK,'LEFT') STRING(NC+1:NC+NCTICK+7)=' * 10**'//TICK(1:NCTICK) NC=NC+NCTICK+7 ENDIF ELSEIF(KKX.EQ.2)THEN STRING(NC+1:NC+4)=' [m]' NC=NC+NCTICK+4 ELSEIF(KKX.EQ.0)THEN STRING(NC+1:NC+5)=' [cm]' NC=NC+NCTICK+5 ELSEIF(KKX.EQ.-1)THEN STRING(NC+1:NC+5)=' [mm]' NC=NC+NCTICK+5 ELSEIF(KKX.EQ.-4)THEN STRING(NC+1:NC+9)=' [micron]' NC=NC+NCTICK+9 ELSEIF(KKX.EQ.-7)THEN STRING(NC+1:NC+5)=' [nm]' NC=NC+NCTICK+5 ELSE CALL OUTFMT(REAL(KKX),2,TICK,NCTICK,'LEFT') STRING(NC+1:NC+NCTICK+10)=' [10**'//TICK(1:NCTICK)// - ' cm]' NC=NC+NCTICK+10 ENDIF IF(YPERP.LT.0)THEN CALL GSCHUP(REAL(-XPERP*ASPECT),REAL(-YPERP/ASPECT)) ELSE CALL GSCHUP(REAL(XPERP*ASPECT),REAL(YPERP/ASPECT)) ENDIF IF(INVERT)THEN IF(YPERP.LT.0)THEN CALL GSTXAL(1,0) ELSE CALL GSTXAL(3,1) ENDIF ELSE IF(YPERP.LT.0)THEN CALL GSTXAL(3,0) ELSE CALL GSTXAL(1,1) ENDIF ENDIF CALL PLACOO(GXMAX,YLAB,ZLAB,XAUX,YAUX) XSC=XUTOD(XAUX)+0.09*XSHIFT*ASPECT YSC=YUTOD(YAUX)+0.09*YSHIFT/ASPECT CALL GRATTS('LABELS','TEXT') CALL GSELNT(0) CALL GRTX(REAL(XSC),REAL(YSC),STRING(1:NC)) CALL GSELNT(1) ENDIF *** y-Axis: tickmarks and scales. CALL GSTXAL(1,3) CALL GRATTS('NUMBERS','TEXT') * Determine optimal side to label. XPERP=Y4-Y2 YPERP=X2-X4 IF(XPERP+YPERP.GT.0)THEN XPERP=-XPERP YPERP=-YPERP INVERT=.TRUE. ELSE INVERT=.FALSE. ENDIF XLAB=GXMIN ZLAB=GZMIN QLAB=XPERP*X1+YPERP*Y1 IF(XPERP*X2+YPERP*Y2.GT.QLAB)THEN QLAB=XPERP*X2+YPERP*Y2 XLAB=GXMIN ZLAB=GZMAX ENDIF IF(XPERP*X5+YPERP*Y5.GT.QLAB)THEN QLAB=XPERP*X5+YPERP*Y5 XLAB=GXMAX ZLAB=GZMIN ENDIF IF(XPERP*X6+YPERP*Y6.GT.QLAB)THEN QLAB=XPERP*X6+YPERP*Y6 XLAB=GXMAX ZLAB=GZMAX ENDIF XSHIFT=XUTOD(XPERP)-XUTOD(0.0D0) YSHIFT=YUTOD(YPERP)-YUTOD(0.0D0) SNORM=SQRT(XSHIFT**2+YSHIFT**2) IF(SNORM.GT.0)THEN XSHIFT=XSHIFT/SNORM YSHIFT=YSHIFT/SNORM ENDIF * Loop over the intervals. DO 20 I=0,1+INT((GYMAX-GYMIN)/DY) YVAL=DY*(INT(GYMIN/DY)+I) IF(GYMIN.GE.YVAL.OR.YVAL.GE.GYMAX.OR. - (FPROJA.EQ.0.AND.FPROJC.EQ.0))GOTO 20 * Tickmarks. IF(SEEN(2))THEN CALL PLACOO(GXMIN,YVAL,GZMIN,XU(1),YU(1)) CALL PLACOO(GXMIN+TICKX,YVAL,GZMIN+TICKZ,XU(2),YU(2)) CALL GPL2(2,XU,YU) ENDIF IF(SEEN(4))THEN CALL PLACOO(GXMIN,YVAL,GZMAX,XU(1),YU(1)) CALL PLACOO(GXMIN+TICKX,YVAL,GZMAX-TICKZ,XU(2),YU(2)) CALL GPL2(2,XU,YU) ENDIF IF(SEEN(6))THEN CALL PLACOO(GXMAX,YVAL,GZMIN,XU(1),YU(1)) CALL PLACOO(GXMAX-TICKX,YVAL,GZMIN+TICKZ,XU(2),YU(2)) CALL GPL2(2,XU,YU) ENDIF IF(SEEN(8))THEN CALL PLACOO(GXMAX,YVAL,GZMAX,XU(1),YU(1)) CALL PLACOO(GXMAX-TICKX,YVAL,GZMAX-TICKZ,XU(2),YU(2)) CALL GPL2(2,XU,YU) ENDIF * Optional grid. IF(LGRID)THEN CALL GRATTS('GRID','POLYLINE') IF(FPROJA.GT.0)THEN CALL PLACOO(GXMIN,YVAL,GZMIN+TICKZ,XU(1),YU(1)) CALL PLACOO(GXMIN,YVAL,GZMAX-TICKZ,XU(2),YU(2)) CALL GPL2(2,XU,YU) ELSEIF(FPROJA.LT.0)THEN CALL PLACOO(GXMAX,YVAL,GZMIN+TICKZ,XU(1),YU(1)) CALL PLACOO(GXMAX,YVAL,GZMAX-TICKZ,XU(2),YU(2)) CALL GPL2(2,XU,YU) ENDIF IF(FPROJC.GT.0)THEN CALL PLACOO(GXMIN+TICKX,YVAL,GZMIN,XU(1),YU(1)) CALL PLACOO(GXMAX-TICKX,YVAL,GZMIN,XU(2),YU(2)) CALL GPL2(2,XU,YU) ELSEIF(FPROJC.LT.0)THEN CALL PLACOO(GXMIN+TICKX,YVAL,GZMAX,XU(1),YU(1)) CALL PLACOO(GXMAX-TICKX,YVAL,GZMAX,XU(2),YU(2)) CALL GPL2(2,XU,YU) ENDIF CALL GRATTS('BOX-TICKMARKS','POLYLINE') ENDIF * Scale. CALL OUTFMT(REAL(YVAL/10.0**KKY),2,TICK,NCTICK,'LEFT') IF(XPERP.LT.0)THEN CALL GSCHUP(REAL(YPERP/ASPECT),REAL(-XPERP*ASPECT)) CALL GSTXAL(3,3) ELSE CALL GSCHUP(REAL(-YPERP/ASPECT),REAL(XPERP*ASPECT)) CALL GSTXAL(1,3) ENDIF CALL PLACOO(XLAB,YVAL,ZLAB,XAUX,YAUX) XSC=XUTOD(XAUX)+0.01*XSHIFT YSC=YUTOD(YAUX)+0.01*YSHIFT CALL GSELNT(0) CALL GRTX(REAL(XSC),REAL(YSC),TICK(1:NCTICK)) CALL GSELNT(1) 20 CONTINUE * Label the axis. IF(FPROJA.NE.0.OR.FPROJC.NE.0)THEN STRING=YTXT NC=LEN(YTXT) IF(INDEX(OPTION,'NOCELL').NE.0)THEN IF(KKY.NE.0)THEN CALL OUTFMT(REAL(KKY),2,TICK,NCTICK,'LEFT') STRING(NC+1:NC+NCTICK+7)=' * 10**'//TICK(1:NCTICK) NC=NC+NCTICK+7 ENDIF ELSEIF(KKY.EQ.2)THEN STRING(NC+1:NC+4)=' [m]' NC=NC+NCTICK+4 ELSEIF(KKY.EQ.0)THEN STRING(NC+1:NC+5)=' [cm]' NC=NC+NCTICK+5 ELSEIF(KKY.EQ.-1)THEN STRING(NC+1:NC+5)=' [mm]' NC=NC+NCTICK+5 ELSEIF(KKY.EQ.-4)THEN STRING(NC+1:NC+9)=' [micron]' NC=NC+NCTICK+9 ELSEIF(KKY.EQ.-7)THEN STRING(NC+1:NC+5)=' [nm]' NC=NC+NCTICK+5 ELSE CALL OUTFMT(REAL(KKY),2,TICK,NCTICK,'LEFT') STRING(NC+1:NC+NCTICK+10)=' [10**'//TICK(1:NCTICK)// - ' cm]' NC=NC+NCTICK+10 ENDIF IF(YPERP.LT.0)THEN CALL GSCHUP(REAL(-XPERP*ASPECT),REAL(-YPERP/ASPECT)) ELSE CALL GSCHUP(REAL(XPERP*ASPECT),REAL(YPERP/ASPECT)) ENDIF IF(INVERT)THEN IF(YPERP.LT.0)THEN CALL GSTXAL(1,0) ELSE CALL GSTXAL(3,1) ENDIF ELSE IF(YPERP.LT.0)THEN CALL GSTXAL(3,0) ELSE CALL GSTXAL(1,1) ENDIF ENDIF CALL PLACOO(XLAB,GYMAX,ZLAB,XAUX,YAUX) XSC=XUTOD(XAUX)+0.09*XSHIFT*ASPECT YSC=YUTOD(YAUX)+0.09*YSHIFT/ASPECT CALL GRATTS('LABELS','TEXT') CALL GSELNT(0) CALL GRTX(REAL(XSC),REAL(YSC),STRING(1:NC)) CALL GSELNT(1) ENDIF *** z-Axis: tickmarks and scales. CALL GSTXAL(1,3) CALL GRATTS('NUMBERS','TEXT') * Determine optimal side to label. XPERP=Y2-Y1 YPERP=X1-X2 IF(XPERP+YPERP.GT.0)THEN XPERP=-XPERP YPERP=-YPERP INVERT=.TRUE. ELSE INVERT=.FALSE. ENDIF XLAB=GXMIN YLAB=GYMIN QLAB=XPERP*X1+YPERP*Y1 IF(XPERP*X3+YPERP*Y3.GT.QLAB)THEN QLAB=XPERP*X3+YPERP*Y3 XLAB=GXMIN YLAB=GYMAX ENDIF IF(XPERP*X5+YPERP*Y5.GT.QLAB)THEN QLAB=XPERP*X5+YPERP*Y5 XLAB=GXMAX YLAB=GYMIN ENDIF IF(XPERP*X7+YPERP*Y7.GT.QLAB)THEN QLAB=XPERP*X7+YPERP*Y7 XLAB=GXMAX YLAB=GYMAX ENDIF XSHIFT=XUTOD(XPERP)-XUTOD(0.0D0) YSHIFT=YUTOD(YPERP)-YUTOD(0.0D0) SNORM=SQRT(XSHIFT**2+YSHIFT**2) IF(SNORM.GT.0)THEN XSHIFT=XSHIFT/SNORM YSHIFT=YSHIFT/SNORM ENDIF * Loop over the intervals. DO 30 I=0,1+INT((GZMAX-GZMIN)/DZ) ZVAL=DZ*(INT(GZMIN/DZ)+I) IF(GZMIN.GE.ZVAL.OR.ZVAL.GE.GZMAX.OR. - (FPROJA.EQ.0.AND.FPROJB.EQ.0))GOTO 30 * Tickmarks. IF(SEEN(1))THEN CALL PLACOO(GXMIN,GYMIN,ZVAL,XU(1),YU(1)) CALL PLACOO(GXMIN+TICKX,GYMIN+TICKY,ZVAL,XU(2),YU(2)) CALL GPL2(2,XU,YU) ENDIF IF(SEEN(3))THEN CALL PLACOO(GXMIN,GYMAX,ZVAL,XU(1),YU(1)) CALL PLACOO(GXMIN+TICKX,GYMAX-TICKY,ZVAL,XU(2),YU(2)) CALL GPL2(2,XU,YU) ENDIF IF(SEEN(5))THEN CALL PLACOO(GXMAX,GYMIN,ZVAL,XU(1),YU(1)) CALL PLACOO(GXMAX-TICKX,GYMIN+TICKY,ZVAL,XU(2),YU(2)) CALL GPL2(2,XU,YU) ENDIF IF(SEEN(7))THEN CALL PLACOO(GXMAX,GYMAX,ZVAL,XU(1),YU(1)) CALL PLACOO(GXMAX-TICKX,GYMAX-TICKY,ZVAL,XU(2),YU(2)) CALL GPL2(2,XU,YU) ENDIF * Optional grid. IF(LGRID)THEN CALL GRATTS('GRID','POLYLINE') IF(FPROJA.GT.0)THEN CALL PLACOO(GXMIN,GYMIN+TICKY,ZVAL,XU(1),YU(1)) CALL PLACOO(GXMIN,GYMAX-TICKY,ZVAL,XU(2),YU(2)) CALL GPL2(2,XU,YU) ELSEIF(FPROJA.LT.0)THEN CALL PLACOO(GXMAX,GYMIN+TICKY,ZVAL,XU(1),YU(1)) CALL PLACOO(GXMAX,GYMAX-TICKY,ZVAL,XU(2),YU(2)) CALL GPL2(2,XU,YU) ENDIF IF(FPROJB.GT.0)THEN CALL PLACOO(GXMIN+TICKX,GYMIN,ZVAL,XU(1),YU(1)) CALL PLACOO(GXMAX-TICKX,GYMIN,ZVAL,XU(2),YU(2)) CALL GPL2(2,XU,YU) ELSEIF(FPROJB.LT.0)THEN CALL PLACOO(GXMIN+TICKX,GYMAX,ZVAL,XU(1),YU(1)) CALL PLACOO(GXMAX-TICKX,GYMAX,ZVAL,XU(2),YU(2)) CALL GPL2(2,XU,YU) ENDIF CALL GRATTS('BOX-TICKMARKS','POLYLINE') ENDIF * Scale. CALL OUTFMT(REAL(ZVAL/10.0**KKZ),2,TICK,NCTICK,'LEFT') IF(XPERP.LT.0)THEN CALL GSCHUP(REAL(YPERP/ASPECT),REAL(-XPERP*ASPECT)) CALL GSTXAL(3,3) ELSE CALL GSCHUP(REAL(-YPERP/ASPECT),REAL(XPERP*ASPECT)) CALL GSTXAL(1,3) ENDIF CALL PLACOO(XLAB,YLAB,ZVAL,XAUX,YAUX) XSC=XUTOD(XAUX)+0.01*XSHIFT YSC=YUTOD(YAUX)+0.01*YSHIFT CALL GSELNT(0) CALL GRTX(REAL(XSC),REAL(YSC),TICK(1:NCTICK)) CALL GSELNT(1) 30 CONTINUE * Label the axis. IF(FPROJA.NE.0.OR.FPROJB.NE.0)THEN STRING=ZTXT NC=LEN(ZTXT) IF(INDEX(OPTION,'NOCELL').NE.0)THEN IF(KKZ.NE.0)THEN CALL OUTFMT(REAL(KKZ),2,TICK,NCTICK,'LEFT') STRING(NC+1:NC+NCTICK+7)=' * 10**'//TICK(1:NCTICK) NC=NC+NCTICK+7 ENDIF ELSEIF(KKZ.EQ.2)THEN STRING(NC+1:NC+4)=' [m]' NC=NC+NCTICK+4 ELSEIF(KKZ.EQ.0)THEN STRING(NC+1:NC+5)=' [cm]' NC=NC+NCTICK+5 ELSEIF(KKZ.EQ.-1)THEN STRING(NC+1:NC+5)=' [mm]' NC=NC+NCTICK+5 ELSEIF(KKZ.EQ.-4)THEN STRING(NC+1:NC+9)=' [micron]' NC=NC+NCTICK+9 ELSEIF(KKZ.EQ.-7)THEN STRING(NC+1:NC+5)=' [nm]' NC=NC+NCTICK+5 ELSE CALL OUTFMT(REAL(KKZ),2,TICK,NCTICK,'LEFT') STRING(NC+1:NC+NCTICK+10)=' [10**'//TICK(1:NCTICK)// - ' cm]' NC=NC+NCTICK+10 ENDIF IF(YPERP.LT.0)THEN CALL GSCHUP(REAL(-XPERP*ASPECT),REAL(-YPERP/ASPECT)) ELSE CALL GSCHUP(REAL(XPERP*ASPECT),REAL(YPERP/ASPECT)) ENDIF IF(INVERT)THEN IF(YPERP.LT.0)THEN CALL GSTXAL(1,0) ELSE CALL GSTXAL(3,1) ENDIF ELSE IF(YPERP.LT.0)THEN CALL GSTXAL(3,0) ELSE CALL GSTXAL(1,1) ENDIF ENDIF CALL PLACOO(XLAB,YLAB,GZMAX,XAUX,YAUX) XSC=XUTOD(XAUX)+0.09*XSHIFT*ASPECT YSC=YUTOD(YAUX)+0.09*YSHIFT/ASPECT CALL GRATTS('LABELS','TEXT') CALL GSELNT(0) CALL GRTX(REAL(XSC),REAL(YSC),STRING(1:NC)) CALL GSELNT(1) ENDIF *** Now plot the cell elements. IF(INDEX(OPTION,'NOCELL').EQ.0)CALL CELLA3 *** And plot box panels that are seen from the back, attributes. IF(LFULLB)THEN CALL GRATTS('BOX-TICKMARKS','POLYLINE') * The x=xmin plane. IF(FPROJA.LT.0)THEN XU(1)=X1 YU(1)=Y1 XU(2)=X3 YU(2)=Y3 XU(3)=X4 YU(3)=Y4 XU(4)=X2 YU(4)=Y2 XU(5)=X1 YU(5)=Y1 CALL GPL2(5,XU,YU) * Or the x=xmax plane. ELSEIF(FPROJA.GT.0)THEN XU(1)=X5 YU(1)=Y5 XU(2)=X7 YU(2)=Y7 XU(3)=X8 YU(3)=Y8 XU(4)=X6 YU(4)=Y6 XU(5)=X5 YU(5)=Y5 CALL GPL2(5,XU,YU) ENDIF * The y=ymin plane. IF(FPROJB.LT.0)THEN XU(1)=X1 YU(1)=Y1 XU(2)=X2 YU(2)=Y2 XU(3)=X6 YU(3)=Y6 XU(4)=X5 YU(4)=Y5 XU(5)=X1 YU(5)=Y1 CALL GPL2(5,XU,YU) * Or the y=ymax plane. ELSEIF(FPROJB.GT.0)THEN XU(1)=X3 YU(1)=Y3 XU(2)=X4 YU(2)=Y4 XU(3)=X8 YU(3)=Y8 XU(4)=X7 YU(4)=Y7 XU(5)=X3 YU(5)=Y3 CALL GPL2(5,XU,YU) ENDIF * The z=zmin plane. IF(FPROJC.LT.0)THEN XU(1)=X1 YU(1)=Y1 XU(2)=X3 YU(2)=Y3 XU(3)=X7 YU(3)=Y7 XU(4)=X5 YU(4)=Y5 XU(5)=X1 YU(5)=Y1 CALL GPL2(5,XU,YU) * Or the z=zmax plane. ELSEIF(FPROJC.GT.0)THEN XU(1)=X2 YU(1)=Y2 XU(2)=X4 YU(2)=Y4 XU(3)=X8 YU(3)=Y8 XU(4)=X6 YU(4)=Y6 XU(5)=X2 YU(5)=Y2 CALL GPL2(5,XU,YU) ENDIF *** And complete with the tickmarks, loop over the x-axis. DO 40 I=0,1+INT((GXMAX-GXMIN)/DX) XVAL=DX*(INT(GXMIN/DX)+I) IF(GXMIN.GE.XVAL.OR.XVAL.GE.GXMAX)GOTO 40 IF(.NOT.SEEN(9))THEN CALL PLACOO(XVAL,GYMIN,GZMIN,XU(1),YU(1)) CALL PLACOO(XVAL,GYMIN+TICKY,GZMIN+TICKZ,XU(2),YU(2)) CALL GPL2(2,XU,YU) ENDIF IF(.NOT.SEEN(12))THEN CALL PLACOO(XVAL,GYMIN,GZMAX,XU(1),YU(1)) CALL PLACOO(XVAL,GYMIN+TICKY,GZMAX-TICKZ,XU(2),YU(2)) CALL GPL2(2,XU,YU) ENDIF IF(.NOT.SEEN(10))THEN CALL PLACOO(XVAL,GYMAX,GZMIN,XU(1),YU(1)) CALL PLACOO(XVAL,GYMAX-TICKY,GZMIN+TICKZ,XU(2),YU(2)) CALL GPL2(2,XU,YU) ENDIF IF(.NOT.SEEN(11))THEN CALL PLACOO(XVAL,GYMAX,GZMAX,XU(1),YU(1)) CALL PLACOO(XVAL,GYMAX-TICKY,GZMAX-TICKZ,XU(2),YU(2)) CALL GPL2(2,XU,YU) ENDIF 40 CONTINUE * Over the y-axis. DO 50 I=0,1+INT((GYMAX-GYMIN)/DY) YVAL=DY*(INT(GYMIN/DY)+I) IF(GYMIN.GE.YVAL.OR.YVAL.GE.GYMAX)GOTO 50 IF(.NOT.SEEN(2))THEN CALL PLACOO(GXMIN,YVAL,GZMIN,XU(1),YU(1)) CALL PLACOO(GXMIN+TICKX,YVAL,GZMIN+TICKZ,XU(2),YU(2)) CALL GPL2(2,XU,YU) ENDIF IF(.NOT.SEEN(4))THEN CALL PLACOO(GXMIN,YVAL,GZMAX,XU(1),YU(1)) CALL PLACOO(GXMIN+TICKX,YVAL,GZMAX-TICKZ,XU(2),YU(2)) CALL GPL2(2,XU,YU) ENDIF IF(.NOT.SEEN(6))THEN CALL PLACOO(GXMAX,YVAL,GZMIN,XU(1),YU(1)) CALL PLACOO(GXMAX-TICKX,YVAL,GZMIN+TICKZ,XU(2),YU(2)) CALL GPL2(2,XU,YU) ENDIF IF(.NOT.SEEN(8))THEN CALL PLACOO(GXMAX,YVAL,GZMAX,XU(1),YU(1)) CALL PLACOO(GXMAX-TICKX,YVAL,GZMAX-TICKZ,XU(2),YU(2)) CALL GPL2(2,XU,YU) ENDIF 50 CONTINUE * And the z-axis. DO 60 I=0,1+INT((GZMAX-GZMIN)/DZ) ZVAL=DZ*(INT(GZMIN/DZ)+I) IF(GZMIN.GE.ZVAL.OR.ZVAL.GE.GZMAX)GOTO 60 IF(.NOT.SEEN(1))THEN CALL PLACOO(GXMIN,GYMIN,ZVAL,XU(1),YU(1)) CALL PLACOO(GXMIN+TICKX,GYMIN+TICKY,ZVAL,XU(2),YU(2)) CALL GPL2(2,XU,YU) ENDIF IF(.NOT.SEEN(3))THEN CALL PLACOO(GXMIN,GYMAX,ZVAL,XU(1),YU(1)) CALL PLACOO(GXMIN+TICKX,GYMAX-TICKY,ZVAL,XU(2),YU(2)) CALL GPL2(2,XU,YU) ENDIF IF(.NOT.SEEN(5))THEN CALL PLACOO(GXMAX,GYMIN,ZVAL,XU(1),YU(1)) CALL PLACOO(GXMAX-TICKX,GYMIN+TICKY,ZVAL,XU(2),YU(2)) CALL GPL2(2,XU,YU) ENDIF IF(.NOT.SEEN(7))THEN CALL PLACOO(GXMAX,GYMAX,ZVAL,XU(1),YU(1)) CALL PLACOO(GXMAX-TICKX,GYMAX-TICKY,ZVAL,XU(2),YU(2)) CALL GPL2(2,XU,YU) ENDIF 60 CONTINUE ENDIF *** Plot the title at the top. CALL GRATTS('TITLE','TEXT') CALL GSTXAL(1,1) CALL GSCHUP(0.0,1.0) CALL GSELNT(0) CALL GRTX(DISPX0+0.1,DISPY1-GPXT,TITLE) CALL GSELNT(1) *** And make a little sketch of the light source. CALL GSELNT(0) CALL GRATTS('BOX-TICKMARKS','POLYLINE') DO 110 I=1,101 XU(I)=DISPX1-0.05+0.04*COS(0.02*I*PI) YU(I)=DISPY0+0.05+0.04*SIN(0.02*I*PI) 110 CONTINUE CALL GPL2(101,XU,YU) CALL PLACOO(DBLE(PRAL),DBLE(PRBL),DBLE(PRCL),XAUX,YAUX) XAUX=XAUX*0.04 YAUX=YAUX*0.04 CALL GRATTS('FUNCTION-1','POLYLINE') XU(1)=DISPX1-0.05+XAUX YU(1)=DISPY0+0.05+YAUX+0.005 XU(2)=DISPX1-0.05+XAUX YU(2)=DISPY0+0.05+YAUX-0.005 CALL GPL2(2,XU,YU) XU(1)=DISPX1-0.05+XAUX+0.005 YU(1)=DISPY0+0.05+YAUX XU(2)=DISPX1-0.05+XAUX-0.005 YU(2)=DISPY0+0.05+YAUX CALL GPL2(2,XU,YU) CALL GSELNT(1) *** Reset the bar chart and histogram counters. IGBAR=0 IGHIST=0 CALL GSTXAL(0,0) END +DECK,GRAXIS. SUBROUTINE GRAXIS(XXMIN,YYMIN,XXMAX,YYMAX,TITLE) *----------------------------------------------------------------------- * GRAXIS - Draws axis for the cell, using any kind of axis. * (Last changed on 28/10/97.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. REAL XXMIN,XXMAX,YYMIN,YYMAX CHARACTER*(*) TITLE *** Frame depending on the coordinate system. IF(.NOT.POLAR)THEN CALL GRCART(XXMIN,YYMIN,XXMAX,YYMAX, - 'x-axis [cm]','y-axis [cm]',TITLE) ELSE CALL GRAPOL(XXMIN,YYMIN,XXMAX,YYMAX, - 'Radial distances are in cm ', - 'Angles are in degrees ',TITLE) ENDIF *** Get the viewport input priorities right. CALL GSVPIP(1,0,0) END +DECK,GRCART. SUBROUTINE GRCART(XMIN1,YMIN1,XMAX1,YMAX1,XTXT,YTXT,TITLE) *---------------------------------------------------------------------- * GRCART - Subroutine plotting axis, annotating them and adding * tickmarks along them. * This routine is for cartesian coordinates. * VARIABLES : XMIN,XMAX : User minimum and maximum for plots in x. * XTXT,YTXT : Titel along the x and y axis. * TITLE : Global title. * (Last changed on 16/ 5/08.) *---------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PARAMETERS. +SEQ,GRAPHICS. +SEQ,PRINTPLOT. REAL XU(5),YU(5),XMIN1,YMIN1,XMAX1,YMAX1,XUTOD,YUTOD,X,Y, - XMIN,YMIN,XMAX,YMAX,DX,DY,TICKX,TICKY,XVAL,YVAL,XSC,YSC, - CPX,CPY,XBOX(5),YBOX(5),XPOWER,YPOWER,YSHIFT INTEGER NDECX,NDECY,NDEC0,NDEC1,KX,KKX,KY,KKY,NC,I,IDEC,IERR, - IWK CHARACTER*(*) XTXT,YTXT,TITLE CHARACTER*13 AUX CHARACTER*13 TICK *** Define 2 statement function to convert from USER to DISP. XUTOD(X)=DISPX0+(DISPX1-DISPX0)*(X-USERX0)/(USERX1-USERX0) YUTOD(Y)=DISPY0+(DISPY1-DISPY0)*(Y-USERY0)/(USERY1-USERY0) *** Set a workstation for inquiries of the power-of-10 box size. IWK=1 *** Output the requested area, if debugging is requested. IF(LDEBUG)WRITE(LUNOUT,*) ' ++++++ GRCART DEBUG : Requested'// - ' area (',XMIN1,YMIN1,') to (',XMAX1,YMAX1,')' *** Check input and define maxima and minima, first order x. IF(XMAX1.LT.XMIN1)PRINT *,' !!!!!! GRCART WARNING : Maximum'// - ' for x exceeds the minimum ; reversed.' XMIN=MIN(XMIN1,XMAX1) XMAX=MAX(XMIN1,XMAX1) * Check for very small ranges. IF(ABS(XMAX-XMIN).LT.1.0E-5*(1.0E-25+ABS(XMIN)+ABS(XMAX)))THEN IF(LOGX)THEN XMAX=XMAX*2 XMIN=XMIN/2 PRINT *,' !!!!!! GRCART WARNING : Zero range in x;'// - ' range enlarged by a factor 2.' ELSE XMAX=XMAX+1.0E-4*MAX(1.0,ABS(XMAX)) XMIN=XMIN-1.0E-4*MAX(1.0,ABS(XMIN)) PRINT *,' !!!!!! GRCART WARNING : Zero range in x;'// - ' range scaled up by 1E-4.' ENDIF ENDIF * Order y. IF(YMAX1.LT.YMIN1)PRINT *,' !!!!!! GRCART WARNING : Maximum'// - ' for y exceeds the minimum ; reversed.' YMIN=MIN(YMIN1,YMAX1) YMAX=MAX(YMIN1,YMAX1) * Check for very small ranges. IF(ABS(YMAX-YMIN).LT.1.0E-5*(1.0E-25+ABS(YMIN)+ABS(YMAX)))THEN IF(LOGY)THEN YMAX=YMAX*2 YMIN=YMIN/2 PRINT *,' !!!!!! GRCART WARNING : Zero range in y;'// - ' range enlarged by a factor 2.' ELSE YMAX=YMAX+1.0E-4*MAX(1.0,ABS(YMAX)) YMIN=YMIN-1.0E-4*MAX(1.0,ABS(YMIN)) PRINT *,' !!!!!! GRCART WARNING : Zero range in y;'// - ' range scaled up by 1E-4.' ENDIF ENDIF * Avoid negative values on log scales. IF((LOGX.AND.(XMAX.LE.0.0.OR.XMIN.LE.0.0)).OR. - (LOGY.AND.(YMAX.LE.0.0.OR.YMIN.LE.0.0)))THEN PRINT *,' !!!!!! GRCART WARNING : Non-positive bounds'// - ' found for an axis with log scale; range modified.' IF(LOGX.AND.XMIN.LE.0.0.OR.XMAX.LE.0.0)THEN XMIN=MAX(XMIN,1.0E-3) XMAX=MAX(XMIN,XMAX) IF(XMIN.GE.XMAX)THEN XMIN=XMIN/2 XMAX=XMAX*2 ENDIF ENDIF IF(LOGY.AND.YMIN.LE.0.0.OR.YMAX.LE.0.0)THEN YMIN=MAX(YMIN,1.0E-3) YMAX=MAX(YMIN,YMAX) IF(YMIN.GE.YMAX)THEN YMIN=YMIN/2 YMAX=YMAX*2 ENDIF ENDIF ENDIF *** Store frame size. FRXMIN=XMIN FRXMAX=XMAX FRYMIN=YMIN FRYMAX=YMAX IF(LOGX)THEN FRXMIN=LOG10(FRXMIN) FRXMAX=LOG10(FRXMAX) ENDIF IF(LOGY)THEN FRYMIN=LOG10(FRYMIN) FRYMAX=LOG10(FRYMAX) ENDIF *** Switch to graphics mode. CALL GRGRAF(.TRUE.) *** Define display area of frame. CALL GSVP(1,DISPX0,DISPX1,DISPY0,DISPY1) *** Define the user area in the plot frame. IF(LOGX)THEN USERX0=LOG10(XMIN)-0.1*LOG10(XMAX/XMIN)/(DISPX1-DISPX0-0.2) USERX1=LOG10(XMAX)+0.1*LOG10(XMAX/XMIN)/(DISPX1-DISPX0-0.2) ELSE USERX0=XMIN-0.1*(XMAX-XMIN)/(DISPX1-DISPX0-0.2) USERX1=XMAX+0.1*(XMAX-XMIN)/(DISPX1-DISPX0-0.2) ENDIF IF(LOGY)THEN USERY0=LOG10(YMIN)-0.1*LOG10(YMAX/YMIN)/(DISPY1-DISPY0-0.2) USERY1=LOG10(YMAX)+0.1*LOG10(YMAX/YMIN)/(DISPY1-DISPY0-0.2) ELSE USERY0=YMIN-0.1*(YMAX-YMIN)/(DISPY1-DISPY0-0.2) USERY1=YMAX+0.1*(YMAX-YMIN)/(DISPY1-DISPY0-0.2) ENDIF CALL GSWN(1,USERX0,USERX1,USERY0,USERY1) CALL GRATTS('BOX-TICKMARKS','POLYLINE') CALL GRATTS('NUMBERS','TEXT') CALL GSTXP(0) *** Figure out number of decades for log scaled plots. NDECX=0 NDECY=0 IF(LOGX)NDECX=NINT(LOG10(MAX(XMIN,XMAX)/MIN(XMIN,XMAX))) IF(LOGY)NDECY=NINT(LOG10(MAX(YMIN,YMAX)/MIN(YMIN,YMAX))) IF(LDEBUG)WRITE(10,'('' ++++++ GRAXIS DEBUG : Number of'', - '' decades in x='',I3,'' in y='',I3)') NDECX,NDECY *** Find a reasonable scale order-of-magnitude in x. IF(NDECX.LE.1)THEN KX=INT(LOG10(XMAX-XMIN)) KKX=3*INT(LOG10(XMAX-XMIN)/3.0) IF(LOG10(XMAX-XMIN).LT.0.0)KX=KX-1 IF(XMAX-XMIN.LT.0.1)KKX=KKX-3 DX=(XMAX-XMIN)/10.0**KX IF(DX.LT.2.0)DX=0.1 IF(DX.GE.2.0.AND.DX.LT.5.0)DX=0.2 IF(DX.GE.5.0)DX=0.5 DX=DX*10.0**KX ELSE KKX=0 ENDIF * And same thing in y. IF(NDECY.LE.1)THEN KY=INT(LOG10(YMAX-YMIN)) KKY=3*INT(LOG10(YMAX-YMIN)/3.0) IF(LOG10(YMAX-YMIN).LT.0.0)KY=KY-1 IF(YMAX-YMIN.LT.0.1)KKY=KKY-3 DY=(YMAX-YMIN)/10.0**KY IF(DY.LT.2.0)DY=0.1 IF(DY.GE.2.0.AND.DY.LT.5.0)DY=0.2 IF(DY.GE.5.0)DY=0.5 DY=DY*10.0**KY ELSE KKY=0 ENDIF *** Calculate the length of a tick mark. IF(LOGX)THEN TICKX=10.0**(LOG10(XMAX/XMIN)/100.0) ELSE TICKX=(XMAX-XMIN)/100.0 ENDIF IF(LOGY)THEN TICKY=10.0**(LOG10(YMAX/YMIN)/100.0) ELSE TICKY=(YMAX-YMIN)/100.0 ENDIF IF(LDEBUG)WRITE(10,'('' ++++++ GRAXIS DEBUG : Tickmark size'', - '' in x='',E12.5,'' in y='',E12.5)') TICKX,TICKY *** Plot a box around the user area. XU(1)=XMIN YU(1)=YMIN XU(2)=XMAX YU(2)=YMIN XU(3)=XMAX YU(3)=YMAX XU(4)=XMIN YU(4)=YMAX XU(5)=XMIN YU(5)=YMIN CALL GSELNT(1) CALL GRLINE(5,XU,YU) *** x-Axis: tickmarks and scales. IF(NDECX.LE.1)THEN CALL GSCHUP(+1.0,0.0) CALL GSTXAL(1,3) DO 20 I=0,1+INT((XMAX-XMIN)/DX) XVAL=DX*(INT(XMIN/DX)+I) IF(XMIN.GE.XVAL.OR.XVAL.GE.XMAX)GOTO 20 * Tickmarks. XU(1)=XVAL XU(2)=XVAL YU(1)=YMIN IF(LOGY)THEN YU(2)=YMIN*TICKY ELSE YU(2)=YMIN+TICKY ENDIF CALL GRLINE(2,XU,YU) YU(1)=YMAX IF(LOGY)THEN YU(2)=YMAX/TICKY ELSE YU(2)=YMAX-TICKY ENDIF CALL GRLINE(2,XU,YU) * Optional grid. IF(LGRID)THEN IF(LOGY)THEN YU(1)=YMIN*TICKY YU(2)=YMAX/TICKY ELSE YU(1)=YMIN+TICKY YU(2)=YMAX-TICKY ENDIF CALL GRATTS('GRID','POLYLINE') CALL GRLINE(2,XU,YU) CALL GRATTS('BOX-TICKMARKS','POLYLINE') ENDIF * Scale. CALL OUTFMT(XVAL/10.0**KKX,2,TICK,NC,'LEFT') CALL GSELNT(0) IF(.NOT.LOGX)XSC=XUTOD(XVAL) IF(LOGX)XSC=XUTOD(LOG10(XVAL)) CALL GRTX(XSC,DISPY0+0.1-GPXN,TICK(1:NC)) CALL GSELNT(1) 20 CONTINUE ** Log scale of 3 decades and less: 1-9 every decade. ELSE * Compute the size of the power-of-10 box. CALL GSCHUP(0.0,1.0) CALL GSTXAL(0,0) CALL GSELNT(0) CALL GQTXX(IWK,0.5,0.5,'9',IERR,CPX,CPY,XBOX,YBOX) YPOWER=MAX(YBOX(1),YBOX(2),YBOX(3),YBOX(4))- - MIN(YBOX(1),YBOX(2),YBOX(3),YBOX(4)) CALL GSELNT(1) * Establish range of decades. NDEC0=INT(LOG10(XMIN))-1 NDEC1=INT(LOG10(XMAX))+1 * Loop over the decades. DO 30 IDEC=NDEC0,NDEC1 DO 40 I=1,9 XVAL=I*10.0**IDEC IF(XVAL.LE.XMIN.OR.XVAL.GE.XMAX)GOTO 40 * Tickmarks. XU(1)=XVAL XU(2)=XVAL YU(1)=YMIN IF(LOGY)THEN YU(2)=YMIN*TICKY ELSE YU(2)=YMIN+TICKY ENDIF CALL GRLINE(2,XU,YU) YU(1)=YMAX IF(LOGY)THEN YU(2)=YMAX/TICKY ELSE YU(2)=YMAX-TICKY ENDIF CALL GRLINE(2,XU,YU) * Optional grid. IF(LGRID.AND.(LGRALL.OR.I.EQ.1))THEN IF(LOGY)THEN YU(1)=YMIN*TICKY YU(2)=YMAX/TICKY ELSE YU(1)=YMIN+TICKY YU(2)=YMAX-TICKY ENDIF CALL GRATTS('GRID','POLYLINE') CALL GRLINE(2,XU,YU) CALL GRATTS('BOX-TICKMARKS','POLYLINE') ENDIF * Scale. CALL GSELNT(0) * Decades. IF(I.EQ.1)THEN IF(LOGX)THEN XSC=XUTOD(LOG10(XVAL)) ELSE XSC=XUTOD(XVAL) ENDIF IF(IDEC.EQ.0)THEN CALL GSTXAL(2,1) CALL GRTX(XSC,DISPY0+0.1-GPXN10-YPOWER,'1') ELSEIF(IDEC.EQ.1)THEN CALL GSTXAL(2,1) CALL GRTX(XSC,DISPY0+0.1-GPXN10-YPOWER,'10') ELSE CALL GSTXAL(2,1) CALL GRTX(XSC,DISPY0+0.1-GPXN10-YPOWER,'10') CALL GQTXX(IWK,0.5,0.5,'10',IERR,CPX,CPY, - XBOX,YBOX) XPOWER=MAX(XBOX(1),XBOX(2),XBOX(3),XBOX(4))- - MIN(XBOX(1),XBOX(2),XBOX(3),XBOX(4)) CALL OUTFMT(REAL(IDEC),2,TICK,NC,'LEFT') CALL GSTXAL(1,0) CALL GRTX(XSC+XPOWER/2,DISPY0+0.1-GPXN10-YPOWER, - TICK(1:NC)) ENDIF * Numbers. ELSEIF(NDECX.LE.3)THEN CALL OUTFMT(REAL(I),2,TICK,NC,'LEFT') IF(LOGX)THEN XSC=XUTOD(LOG10(XVAL)) ELSE XSC=XUTOD(XVAL) ENDIF CALL GSTXAL(2,1) CALL GRTX(XSC,DISPY0+0.1-GPXN,TICK(1:NC)) ENDIF CALL GSELNT(1) 40 CONTINUE 30 CONTINUE ENDIF *** y-Axis: Tickmarks and scales. CALL GSCHUP(0.0,1.0) IF(NDECY.LE.1)THEN CALL GSTXAL(3,3) DO 50 I=0,1+INT((YMAX-YMIN)/DY) YVAL=DY*(INT(YMIN/DY)+I) IF(YMIN.GE.YVAL.OR.YVAL.GE.YMAX)GOTO 50 * Tickmarks. YU(1)=YVAL YU(2)=YVAL XU(1)=XMIN IF(LOGX)THEN XU(2)=XMIN*TICKX ELSE XU(2)=XMIN+TICKX ENDIF CALL GRLINE(2,XU,YU) XU(1)=XMAX IF(LOGX)THEN XU(2)=XMAX/TICKX ELSE XU(2)=XMAX-TICKX ENDIF CALL GRLINE(2,XU,YU) * Optional grid. IF(LGRID)THEN IF(LOGX)THEN XU(1)=XMIN*TICKX XU(2)=XMAX/TICKX ELSE XU(1)=XMIN+TICKX XU(2)=XMAX-TICKX ENDIF CALL GRATTS('GRID','POLYLINE') CALL GRLINE(2,XU,YU) CALL GRATTS('BOX-TICKMARKS','POLYLINE') ENDIF * Scale. CALL OUTFMT(YVAL/10.0**KKY,2,TICK,NC,'LEFT') CALL GSELNT(0) IF(LOGY)THEN YSC=YUTOD(LOG10(YVAL)) ELSE YSC=YUTOD(YVAL) ENDIF CALL GRTX(DISPX0+0.1-GPYN,YSC,TICK(1:NC)) CALL GSELNT(1) 50 CONTINUE ** Log scale of 3 decades and less: 1-9 every decade. ELSE * Compute decade range. NDEC0=INT(LOG10(YMIN))-1 NDEC1=INT(LOG10(YMAX))+1 * Loop over the decades. DO 60 IDEC=NDEC0,NDEC1 DO 70 I=1,9 YVAL=I*10.0**IDEC IF(YVAL.LE.YMIN.OR.YVAL.GE.YMAX)GOTO 70 * Tickmarks. XU(1)=XMIN IF(LOGX)THEN XU(2)=XMIN*TICKX ELSE XU(2)=XMIN+TICKX ENDIF YU(1)=YVAL YU(2)=YVAL CALL GRLINE(2,XU,YU) XU(1)=XMAX IF(LOGX)THEN XU(2)=XMAX/TICKX ELSE XU(2)=XMAX-TICKX ENDIF CALL GRLINE(2,XU,YU) * Optional grid. IF(LGRID.AND.(LGRALL.OR.I.EQ.1))THEN IF(LOGX)THEN XU(1)=XMIN*TICKX XU(2)=XMAX/TICKX ELSE XU(1)=XMIN+TICKX XU(2)=XMAX-TICKX ENDIF CALL GRATTS('GRID','POLYLINE') CALL GRLINE(2,XU,YU) CALL GRATTS('BOX-TICKMARKS','POLYLINE') ENDIF * Scale. CALL GSELNT(0) IF(I.EQ.1)THEN IF(LOGY)THEN YSC=YUTOD(LOG10(YVAL)) ELSE YSC=YUTOD(YVAL) ENDIF IF(IDEC.EQ.0)THEN CALL GSTXAL(3,3) CALL GRTX(DISPX0+0.1-GPYN10,YSC,'1') ELSEIF(IDEC.EQ.1)THEN CALL GSTXAL(3,3) CALL GRTX(DISPX0+0.1-GPYN10,YSC,'10') ELSE CALL GSTXAL(3,3) CALL OUTFMT(REAL(IDEC),2,TICK,NC,'LEFT') CALL GQTXX(IWK,0.5,0.5,TICK(1:NC),IERR,CPX,CPY, - XBOX,YBOX) XPOWER=MAX(XBOX(1),XBOX(2),XBOX(3),XBOX(4))- - MIN(XBOX(1),XBOX(2),XBOX(3),XBOX(4)) YPOWER=MAX(YBOX(1),YBOX(2),YBOX(3),YBOX(4))- - MIN(YBOX(1),YBOX(2),YBOX(3),YBOX(4)) CALL GRTX(DISPX0+0.1-GPYN10-XPOWER,YSC,'10') CALL GSTXAL(1,0) CALL GRTX(DISPX0+0.1-GPYN10-XPOWER,YSC+YPOWER/2, - TICK(1:NC)) ENDIF ELSEIF(NDECY.LE.3)THEN CALL OUTFMT(REAL(I),2,TICK,NC,'LEFT') IF(LOGY)THEN YSC=YUTOD(LOG10(YVAL)) ELSE YSC=YUTOD(YVAL) ENDIF CALL GSTXAL(3,3) CALL GRTX(DISPX0+0.1-GPYN,YSC,TICK(1:NC)) ENDIF CALL GSELNT(1) 70 CONTINUE 60 CONTINUE ENDIF *** Plot the title at the top and labels along the axis. CALL GSELNT(0) * Title. CALL GSCHUP(0.0,1.0) CALL GSTXAL(1,1) CALL GRATTS('TITLE','TEXT') CALL GRTX(DISPX0+0.1,DISPY1-GPXT,TITLE) * Label the x-axis. CALL GSTXAL(3,0) CALL GSCHUP(0.0,1.0) CALL GRATTS('LABELS','TEXT') CALL GQTXX(IWK,0.5,0.5,XTXT,IERR,CPX,CPY,XBOX,YBOX) YSHIFT=0.5-MIN(YBOX(1),YBOX(2),YBOX(3),YBOX(4)) CALL GRTX(DISPX1-0.1,DISPY0+GPXL+YSHIFT,XTXT) IF(KKX.NE.0)THEN CALL GSTXAL(1,0) CALL GSCHUP(1.0,0.0) CALL OUTFMT(REAL(KKX),2,AUX,NC,'LEFT') CALL GQTXX(IWK,0.5,0.5,AUX(1:NC),IERR,CPX,CPY,XBOX,YBOX) XPOWER=MAX(XBOX(1),XBOX(2),XBOX(3),XBOX(4))- - MIN(XBOX(1),XBOX(2),XBOX(3),XBOX(4)) YPOWER=MAX(YBOX(1),YBOX(2),YBOX(3),YBOX(4))- - MIN(YBOX(1),YBOX(2),YBOX(3),YBOX(4)) CALL GSTXAL(3,1) CALL GRATTS('LABELS','TEXT') CALL GRTX(DISPX1-GPYL-XPOWER,DISPY0+GPXL+YPOWER,'*10') CALL GRATTS('NUMBERS','TEXT') CALL GRTX(DISPX1-GPYL,DISPY0+GPXL,AUX(1:NC)) ENDIF * And label the y-axis. CALL GSTXAL(3,1) CALL GSCHUP(-1.0,0.0) CALL GRATTS('LABELS','TEXT') CALL GRTX(DISPX0+GPYL,DISPY1-0.1,YTXT) IF(KKY.NE.0)THEN CALL GSTXAL(0,0) CALL GSCHUP(0.0,1.0) CALL OUTFMT(REAL(KKY),2,AUX,NC,'LEFT') CALL GQTXX(IWK,0.5,0.5,'*10',IERR,CPX,CPY,XBOX,YBOX) XPOWER=MAX(XBOX(1),XBOX(2),XBOX(3),XBOX(4))- - MIN(XBOX(1),XBOX(2),XBOX(3),XBOX(4)) YPOWER=MAX(YBOX(1),YBOX(2),YBOX(3),YBOX(4))- - MIN(YBOX(1),YBOX(2),YBOX(3),YBOX(4)) CALL GRATTS('LABELS','TEXT') CALL GRTX(DISPX0+GPYL,DISPY1-0.08,'*10') CALL GRATTS('NUMBERS','TEXT') CALL GRTX(DISPX0+GPYL+XPOWER,DISPY1-0.08+YPOWER,AUX(1:NC)) ENDIF * Reset normalisation transformation, alignment and up-vector. CALL GSELNT(1) CALL GSTXAL(0,0) CALL GSCHUP(0.0,1.0) *** Set a reasonable default representation. CALL GRATTS('FUNCTION-1','POLYLINE') CALL GRATTS('FUNCTION-1','POLYMARKER') CALL GRATTS('FUNCTION-1','TEXT') CALL GRATTS('FUNCTION-1','AREA') *** Reset the bar chart and histogram counters. IGBAR=0 IGHIST=0 END +DECK,GRCLWK. SUBROUTINE GRCLWK(NAME,OPTION) *----------------------------------------------------------------------- * GRCLWK - Closes a workstation - GKS version. * (Last changed on 6/ 3/04.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. +SEQ,GRAPHICS. EXTERNAL INPCMX INTEGER INPCMX,IFAIL,IFAIL1,IWK,IERR,ISTATE,NC,IOS CHARACTER*(*) NAME,OPTION CHARACTER*(MXNAME) AUX *** Locate workstation. CALL GRQIWK(NAME,IWK,IFAIL) IF(IFAIL.NE.0)RETURN *** Delayed processing. IF(OPTION.EQ.'DELAY'.AND..NOT.WKMULT(IWK))THEN WKSREQ(IWK)=1 RETURN ENDIF *** Check the current state of the workstation. IF(WKSTAT(IWK).LT.2)THEN PRINT *,' !!!!!! GRCLWK WARNING : Workstation ',NAME, - ' is not open ; not closed.' RETURN ENDIF CALL GQWKS(IWK,IERR,ISTATE) IF(IERR.NE.0)PRINT *,' !!!!!! GRCLWK WARNING : Inquiry error'// - ' for state of ',NAME,' ; assumed active.' IF(IERR.NE.0.OR.ISTATE.EQ.1)THEN PRINT *,' !!!!!! GRCLWK WARNING : Workstation ',NAME, - ' is still active; deactivated.' CALL GDAWK(IWK) WKSTAT(IWK)=2 +SELF,IF=HIGZ. CALL SGFLAG +SELF. ENDIF *** And at last close the workstation. CALL GCLWK(IWK) IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GRCLWK DEBUG :'', - '' Workstation '',A,'' has been closed.'')') NAME WKSTAT(IWK)=1 * And any file associated with it. IF(WKLUN(IWK).GT.0)THEN CLOSE(UNIT=WKLUN(IWK),ERR=2030,IOSTAT=IOS) IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GRCLWK DEBUG :'', - '' The associated file on unit '',I3, - '' has been closed.'')') WKLUN(IWK) ENDIF RETURN *** Error handling. 2030 CONTINUE CALL STRBUF('READ',WKFREF(IWK),AUX,NC,IFAIL1) PRINT *,' !!!!!! GRCLWK WARNING : Metafile '//AUX(1:NC)//' on '// - ' unit ',WKLUN(IWK),' is not properly closed.' CALL INPIOS(IOS) END +DECK,GRCOLC. SUBROUTINE GRCOLC(IWKID,IWKTYP,IFLAG) *----------------------------------------------------------------------- * GRCOLC - Routine figures out whether a wk has got colours or not. * (Last changed on 5/ 9/99.) *----------------------------------------------------------------------- implicit none +SEQ,PRINTPLOT. INTEGER IWKID,IWKTYP,IFLAG,IERR,ISTATE,ICONID,IWKCAT, - NCOLS,ICOLS,NPRE *** Initial value: 1 meaning no colours. IFLAG=1 *** Make sure the wk is active. CALL GQWKS(IWKID,IERR,ISTATE) IF(IERR.NE.0.OR.ISTATE.NE.1)THEN PRINT *,' !!!!!! GRCOLC WARNING : The workstation on'// - ' which the colours are to be set is not active.' RETURN ENDIF *** Determine wk type and category. CALL GQWKC(IWKID,IERR,ICONID,IWKTYP) IF(IERR.NE.0)THEN PRINT *,' !!!!!! GRCOLC WARNING : Unable to determine the'// - ' workstation type ; no colours set.' RETURN ENDIF CALL GQWKCA(IWKTYP,IERR,IWKCAT) IF(IERR.NE.0)THEN PRINT *,' !!!!!! GRCOLC WARNING : Unable to determine the'// - ' workstation category ; no colours set.' RETURN ENDIF * For WISS and MO, no way to see whether there are colours. IF(IWKCAT.EQ.3.OR.IWKCAT.EQ.4)THEN IF(LDEBUG)PRINT *,' ++++++ GRCOLC DEBUG : Workstation'// - ' category WISS or MO; no further checks.' IFLAG=-1 RETURN ENDIF *** Ask the number of colours. CALL GQCF(IWKTYP,IERR,NCOLS,ICOLS,NPRE) IF(LDEBUG)WRITE(LUNOUT,*) - ' ++++++ GRCOLC DEBUG : Colour data'// - ' for workstation ',IWKID,' of type ',IWKTYP,':' IF(LDEBUG)WRITE(LUNOUT,*) - ' Colours y/n', - ICOLS,', number of colours: ',NCOLS,', predefined: ',NPRE IF(IERR.NE.0)THEN PRINT *,' !!!!!! GRCOLC WARNING : Unable to determine'// - ' whether the workstation has colours ; nothing done.' RETURN ELSEIF(ICOLS.EQ.0.OR.NCOLS.EQ.2)THEN PRINT *,' !!!!!! GRCOLC WARNING : The workstation has'// - ' no colour facilities ; nothing done.' RETURN ENDIF *** OK, set flag to 0. IFLAG=0 END +DECK,GRCOLR. SUBROUTINE GRCOLR(IKEY,IFAIL) *----------------------------------------------------------------------- * GRCOLR - Reads colour descriptions and stores them. * GRCOLQ - Returns the index for a given colour name. * GRCOLD - Returns the name for a colour with a given index. * GRCOLW - Writes a colour table to a library. * GRCOLG - Retrieves a colour table from a library. * GRCOLM - Plots a colour map. * GRCOLS - Resets the colour table. * (Last changed on 14/11/09.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. INTEGER MXCOL PARAMETER (MXCOL=25) CHARACTER*(*) COLCMP,OPTION CHARACTER*(MXINCH) STRING CHARACTER*(MXNAME) FILE CHARACTER*80 DESCR,AUX CHARACTER*29 REMARK CHARACTER*20 COLNAM(0:MXCOL),AUX1,AUX2,AUX3 CHARACTER*8 TIME,DATE,MEMBER LOGICAL EXIS,DSNCMP,EXMEMB INTEGER INPTYP,INPCMP,INPCMX,NC,NC1,NC2,NC3,ICOL,NCOL,IKEY, - IOPSTA,NWORD,IWK,IERR,IDUM,IWKID,ITYPE,IWKTYP, - IERR0,IERR1,IERR2,MPL,MPM,MTX,MFA,MPA,MXCOLI, - IWKCAT,INEXT,IFAIL,IFAIL1,IFLAG,IC,NCC,IWKDUM,ICIND,NCD, - NCFILE,NCMEMB,NCREM,I,II,IOS,ICONID,IWKDES,NACT,IRGB REAL XPL(5),YPL(5),BLUE,GREEN,RED,BLUES,GREENS,REDS,BLUER,GREENR, - REDR EXTERNAL INPTYP,INPCMP,INPCMX +SELF,IF=SAVE. SAVE COLNAM,NCOL +SELF. DATA NCOL /1/ DATA (COLNAM(I),I=0,1) / - 'BACKGROUND ', - 'FOREGROUND '/ *** Assume the command fails. IFAIL=1 *** Pick up the name of the colour. CALL INPNUM(NWORD) ICOL=-1 IF(IKEY+1.LE.NWORD)THEN CALL INPSTR(IKEY+1,IKEY+1,STRING,NC) IF(NC.GT.20)THEN PRINT *,' !!!!!! GRCOLR WARNING : The name of the'// - ' colour is longer than 20 chars ; truncated.' NC=20 ENDIF DO 10 I=0,NCOL IF(STRING(1:NC).EQ.COLNAM(I))THEN ICOL=I GOTO 20 ENDIF 10 CONTINUE ICOL=NCOL+1 20 CONTINUE ELSE STRING=' ' NC=1 ENDIF *** Default workstation (find one that has output). CALL GQOPS(IOPSTA) * No active workstations. IF(IOPSTA.LT.3)THEN PRINT *,' !!!!!! GRCOLR WARNING : No active workstations'// - ' ; COLOUR not executed.' RETURN ENDIF * Determine number of active workstations. CALL GQACWK(0,IERR,NACT,IWK) IWKID=-1 ITYPE=0 DO 30 I=1,NACT CALL GQACWK(I,IERR,IDUM,IWK) * Locate one an out/in ws, if not existing one of type out. CALL GQWKC(IWK,IERR1,ICONID,IWKTYP) CALL GQWKCA(IWKTYP,IERR2,IWKCAT) IF(IWKCAT.EQ.2.AND.ITYPE.LT.2)THEN IWKID=IWK ITYPE=2 ELSEIF((IWKCAT.EQ.0.OR.IWKCAT.EQ.4).AND.ITYPE.LT.1)THEN IWKID=IWK ITYPE=1 ENDIF 30 CONTINUE * Issue an string request to an input workstation. IF(IWKID.EQ.-1)THEN PRINT *,' !!!!!! GRCOLR WARNING : No active workstations'// - ' with output facilities ; COLOUR not executed.' RETURN ENDIF *** Default colour. BLUE=-1.0 GREEN=-1.0 RED=-1.0 *** Read the various components of the colour description. INEXT=IKEY+2 DO 100 I=IKEY+2,NWORD IF(I.LT.INEXT)GOTO 100 IF(INPCMP(I,'BL#UE').NE.0)THEN IF(NWORD.LT.I+1.OR.INPTYP(I+1).LE.0)THEN CALL INPMSG(I,'Blue value missing or not real') ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,BLUE,-1.0) IF(IFAIL1.EQ.0.AND.(BLUE.LT.0.0.OR.BLUE.GT.1.0)) - CALL INPMSG(I+1,'Blue value not in range [0,1].') INEXT=I+2 ENDIF ELSEIF(INPCMP(I,'GR#EEN').NE.0)THEN IF(NWORD.LT.I+1.OR.INPTYP(I+1).LE.0)THEN CALL INPMSG(I,'Green is missing or not real. ') ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,GREEN,-1.0) IF(IFAIL1.EQ.0.AND.(GREEN.LT.0.0.OR.GREEN.GT.1.0)) - CALL INPMSG(I+1,'Green value not in range [0,1]') INEXT=I+2 ENDIF ELSEIF(INPCMP(I,'RED').NE.0)THEN IF(NWORD.LT.I+1.OR.INPTYP(I+1).LE.0)THEN CALL INPMSG(I,'Red value missing or not real.') ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,RED,-1.0) IF(IFAIL1.EQ.0.AND.(RED.LT.0.0.OR.RED.GT.1.0)) - CALL INPMSG(I+1,'Red value not in range [0,1]. ') INEXT=I+2 ENDIF ELSEIF(INPCMP(I,'HEX#ADECIMAL')+INPCMP(I,'RGB').NE.0)THEN IF(NWORD.LT.I+1.OR.INPTYP(I+1).LE.0)THEN CALL INPMSG(I,'Red value missing or not real.') ELSE CALL INPCHK(I+1,3,IFAIL1) CALL INPRDH(I+1,IRGB,-1) IF(IFAIL1.EQ.0.AND.(IRGB.LT.0.OR.IRGB.GT.16**6-1))THEN CALL INPMSG(I+1,'RGB value not in range [0,1]. ') ELSEIF(IFAIL1.EQ.0)THEN BLUE=REAL(IRGB-256*(IRGB/256))/255.0 IRGB=IRGB/256 GREEN=REAL(IRGB-256*(IRGB/256))/255.0 IRGB=IRGB/256 RED=REAL(IRGB-256*(IRGB/256))/255.0 ENDIF INEXT=I+2 ENDIF ELSEIF(INPCMP(I,'WORK#STATION').NE.0)THEN IF(NWORD.LT.I+1.OR.INPTYP(I+1).LE.0)THEN CALL INPMSG(I,'Workstation missing or invalid') ELSE CALL INPCHK(I+1,1,IFAIL1) CALL INPRDI(I+1,IWKID,1) INEXT=I+2 ENDIF ELSE CALL INPMSG(I,'This is not a known keyword. ') ENDIF 100 CONTINUE *** Dump the error messages. CALL INPERR *** Now check whether the workstation has at all colour facilities. CALL GRCOLC(IWKID,IWKTYP,IFLAG) IF(IFLAG.GT.0)THEN PRINT *,' !!!!!! GRCOLR WARNING : The workstation does'// - ' not have colour facilities.' RETURN ENDIF *** Check validity of the request in terms of intensities. IF(NWORD.GT.IKEY+1.AND.(BLUE.LT.0.OR.BLUE.GT.1.OR.RED.LT.0.OR. - RED.GT.1.OR.GREEN.LT.0.OR.GREEN.GT.1))THEN PRINT *,' !!!!!! GRCOLR WARNING : Your update request is'// - ' not carried out because the' PRINT *,' colour is either'// - ' incompletely or incorrectly specified.' RETURN ENDIF *** Try incrementing the number of colours if update is requested. IF(ICOL.GT.NCOL.AND.NWORD.GT.IKEY+1)THEN IF(IFLAG.LT.0)GOTO 1010 CALL GQLWK(IWKTYP,IERR,MPL,MPM,MTX,MFA,MPA,MXCOLI) IF(LDEBUG)WRITE(LUNOUT,*) ' ++++++ GRCOLR DEBUG : Max.'// - ' number of colours on this workstation: ',MXCOLI IF(IERR.NE.0)THEN PRINT *,' !!!!!! GRCOLR WARNING : Unable to obtain'// - ' the wk state table length; nothing done.' RETURN ENDIF IF(ICOL+1.GT.MXCOLI)THEN PRINT *,' !!!!!! GRCOLR WARNING : Workstation table'// - ' of colours is full; new colour not defined.' RETURN ENDIF 1010 CONTINUE IF(ICOL+1.GT.MXCOL)THEN PRINT *,' !!!!!! GRCOLR WARNING : Internal colour'// - ' name table is full; increase MXCOL, not defined.' RETURN ENDIF NCOL=ICOL COLNAM(ICOL)=STRING(1:NC) *** Failing inquiry because the colour is not known. ELSEIF(ICOL.GT.NCOL.AND.NWORD.EQ.IKEY+1)THEN PRINT *,' !!!!!! GRCOLR WARNING : The colour is not known.' RETURN ENDIF *** Inquiry and update. DO 200 I=0,NCOL IF(ICOL.EQ.-1.OR.(IKEY+1.EQ.NWORD.AND. - STRING(1:NC).EQ.COLNAM(I)))THEN CALL GRQCR(IWKID,I,0,IERR0,REDS,GREENS,BLUES) CALL GRQCR(IWKID,I,1,IERR1,REDR,GREENR,BLUER) DO 210 IC=20,1,-1 IF(COLNAM(I)(IC:IC).NE.' ')THEN NCC=IC GOTO 220 ENDIF 210 CONTINUE NCC=1 220 CONTINUE IF(IERR0.NE.0.OR.IERR1.NE.0)THEN WRITE(LUNOUT,'(/'' Unable to retrieve the current'', - '' representation of colour '',A,''.''/)') - COLNAM(I)(1:NCC) ELSE WRITE(LUNOUT,'(/'' Current representation of'', - '' colour '',A,'' on workstation '',I3,'':''// - 2X,'' Blue: '',F10.3,'' (set), '', - F10.3,'' (realised),''/ - 2X,'' Green: '',F10.3,'' (set), '', - F10.3,'' (realised),''/ - 2X,'' Red: '',F10.3,'' (set), '', - F10.3,'' (realised).''/)') COLNAM(I)(1:NCC), - IWKID,BLUES,BLUER,GREENS,GREENR,REDS,REDR ENDIF ELSEIF(NWORD.GT.IKEY+1.AND.STRING(1:NC).EQ.COLNAM(I))THEN CALL GRSCR(IWKID,ICOL,RED,GREEN,BLUE) ENDIF 200 CONTINUE *** If we get here, things are probably OK. IFAIL=0 RETURN *** GRCOLQ: Return the table index corresponding to a colour name. ENTRY GRCOLQ(IWKDUM,COLCMP,ICIND) * Try to locate the colour in the table. DO 300 I=0,NCOL IF(INPCMX(COLCMP,COLNAM(I)).NE.0)THEN ICIND=I GOTO 320 ENDIF 300 CONTINUE * Set to -1 if not found. ICIND=-1 320 CONTINUE RETURN *** GRCOLD: Return a string containing the description. ENTRY GRCOLD(IWKDES,ICIND,DESCR,NCD,OPTION) * Reject invalid colour reference numbers. IF(ICIND.LT.0.OR.ICIND.GT.NCOL)THEN DESCR='# Not a known colour.' NCD=21 RETURN ENDIF * Inquire GKS about the intensities. CALL GRQCR(IWKDES,ICIND,1,IERR,RED,GREEN,BLUE) * And format the colour description. IF(IERR.NE.0)THEN DESCR='# Error retrieving the data.' NCD=28 CALL INPFIX(COLNAM(ICIND),AUX,NC) DESCR=AUX(1:NC)//' (Unable to retrieve the description)' NCD=NC+37 ELSE IF(OPTION.EQ.'RAW')THEN DESCR=COLNAM(ICIND) NCD=20 ELSE CALL INPFIX(COLNAM(ICIND),AUX,NC) CALL OUTFMT(RED,2,AUX1,NC1,'LEFT') CALL OUTFMT(BLUE,2,AUX2,NC2,'LEFT') CALL OUTFMT(GREEN,2,AUX3,NC3,'LEFT') DESCR=AUX(1:NC)//' (Red '//AUX1(1:NC1)//', Blue '// - AUX2(1:NC2)//', Green '//AUX3(1:NC3)//')' NCD=NC+NC1+NC2+NC3+22 ENDIF ENDIF RETURN *** Write the settings to a file. ENTRY GRCOLW(IKEY,IFAIL) * Initial settings. FILE=' ' NCFILE=1 MEMBER='< none >' NCMEMB=8 REMARK='none' NCREM=4 IFAIL=1 IWKID=1 * Make sure there are colours. CALL GRCOLC(IWKID,IWKTYP,IFLAG) IF(IFLAG.GT.0)THEN PRINT *,' !!!!!! GRCOLW WARNING : The workstation does'// - ' not have colour facilities.' RETURN ENDIF * First decode the argument string. CALL INPNUM(NWORD) * Make sure there is at least one argument. IF(NWORD.EQ.IKEY)THEN PRINT *,' !!!!!! GRCOLW WARNING : WRITE takes at least one', - ' argument (a dataset name); data will not be written.' RETURN * Check whether keywords have been used. ELSEIF(INPCMP(IKEY+1,'D#ATASET')+ - INPCMP(IKEY+1,'R#EMARK').NE.0)THEN INEXT=IKEY+1 DO 410 I=IKEY+1,NWORD IF(I.LT.INEXT)GOTO 410 IF(INPCMP(I,'D#ATASET').NE.0)THEN IF(INPCMP(I+1,'R#EMARK').NE.0.OR.I+1.GT.NWORD)THEN CALL INPMSG(I,'The dataset name is missing. ') INEXT=I+1 ELSE CALL INPSTR(I+1,I+1,STRING,NCFILE) FILE=STRING INEXT=I+2 IF(INPCMP(I+2,'R#EMARK').EQ.0.AND. - I+2.LE.NWORD)THEN CALL INPSTR(I+2,I+2,STRING,NCMEMB) MEMBER=STRING INEXT=I+3 ENDIF ENDIF ELSEIF(INPCMP(I,'R#EMARK').NE.0)THEN IF(INPCMP(I+1,'D#ATASET').NE.0.OR.I+1.GT.NWORD)THEN CALL INPMSG(I,'The remark is missing. ') INEXT=I+1 ELSE CALL INPSTR(I+1,I+1,STRING,NCREM) REMARK=STRING INEXT=I+2 ENDIF ELSE CALL INPMSG(I,'The parameter is not known. ') ENDIF 410 CONTINUE * Otherwise the string is interpreted as a file name (+ member name). ELSE CALL INPSTR(IKEY+1,IKEY+1,STRING,NCFILE) FILE=STRING IF(NWORD.GE.IKEY+2)THEN CALL INPSTR(IKEY+2,IKEY+2,STRING,NCMEMB) MEMBER=STRING ENDIF IF(NWORD.GE.IKEY+3)THEN CALL INPSTR(IKEY+3,NWORD,STRING,NCREM) REMARK=STRING ENDIF ENDIF * Print error messages. CALL INPERR IF(NCFILE.GT.MXNAME)PRINT *,' !!!!!! GRCOLW WARNING : The file', - ' name is truncated to MXNAME (=',MXNAME,') characters.' IF(NCMEMB.GT.8)PRINT *,' !!!!!! GRCOLW WARNING : The member', - ' name is shortened to ',MEMBER,', first 8 characters.' IF(NCREM.GT.29)PRINT *,' !!!!!! GRCOLW WARNING : The remark', - ' shortened to ',REMARK,', first 29 characters.' NCFILE=MIN(NCFILE,MXNAME) NCMEMB=MIN(NCMEMB,8) NCREM=MIN(NCREM,29) * Check whether the member already exists. CALL DSNREM(FILE(1:NCFILE),MEMBER(1:NCMEMB),'GRAPHCOL',EXMEMB) IF(JEXMEM.EQ.2.AND.EXMEMB)THEN PRINT *,' ------ GRCOLW MESSAGE : A copy of the member'// - ' exists; new member will be appended.' ELSEIF(JEXMEM.EQ.3.AND.EXMEMB)THEN PRINT *,' !!!!!! GRCOLW WARNING : A copy of the member'// - ' exists already; member will not be written.' RETURN ENDIF * Print some debugging output if requested. IF(LDEBUG)THEN PRINT *,' ++++++ GRCOLW DEBUG : File= '//FILE(1:NCFILE)// - ', member= '//MEMBER(1:NCMEMB) PRINT *,' Remark= '//REMARK(1:NCREM) ENDIF ** Open the dataset for sequential write and inform DSNLOG. CALL DSNOPN(FILE,NCFILE,12,'WRITE-LIBRARY',IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! GRCOLW WARNING : Opening '//FILE(1:NCFILE), - ' failed ; the colour data will not be written.' RETURN ENDIF CALL DSNLOG(FILE,'Colours ','Sequential','Write ') IF(LDEBUG)PRINT *,' ++++++ GRCOLW DEBUG : Dataset ', - FILE(1:NCFILE),' opened on unit 12 for seq write.' * Now write a heading record to the file. CALL DATTIM(DATE,TIME) WRITE(STRING,'(''% Created '',A8,'' At '',A8,1X,A8,'' GRAPHCOL'', - 1X,''"'',A29,''"'')') DATE,TIME,MEMBER,REMARK WRITE(12,'(A80)',IOSTAT=IOS,ERR=2010) STRING IF(LDEBUG)THEN PRINT *,' ++++++ GRCOLW DEBUG : Dataset heading record:' PRINT *,STRING ENDIF * Write the actual data, start with the number of colours. WRITE(12,'('' NCOL='',I3)',ERR=2010,IOSTAT=IOS) NCOL * Next a list of Polyline attributes. DO 420 I=0,NCOL CALL GRQCR(IWKID,I,1,IERR,RED,GREEN,BLUE) IF(IERR.NE.0)THEN PRINT *,' !!!!!! GRCOLW WARNING : Unable to retrieve data'// - ' about colour ',I GOTO 420 ENDIF WRITE(12,'(A20,3E15.8)',ERR=2010,IOSTAT=IOS) - COLNAM(I),RED,BLUE,GREEN 420 CONTINUE ** Close the file after the operation. CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) CALL TIMLOG('Writing out a list of colours: ') IFAIL=0 RETURN *** Read the presentation from dataset. ENTRY GRCOLG(IKEY,IFAIL) * Initial values. FILE=' ' MEMBER='*' NCFILE=8 NCMEMB=1 IFAIL=1 IWKID=1 * Make sure there are colours. CALL GRCOLC(IWKID,IWKTYP,IFLAG) IF(IFLAG.GT.0)THEN PRINT *,' !!!!!! GRCOLW WARNING : The workstation does'// - ' not have colour facilities.' RETURN ENDIF ** First decode the argument string, setting file name + member name. CALL INPNUM(NWORD) * If there's only one argument, it's the dataset name. IF(NWORD.GE.IKEY+1)THEN CALL INPSTR(IKEY+1,IKEY+1,STRING,NCFILE) FILE=STRING ENDIF * If there's a second argument, it is the member name. IF(NWORD.GE.IKEY+2)THEN CALL INPSTR(IKEY+2,IKEY+2,STRING,NCMEMB) MEMBER=STRING ENDIF * Check the various lengths. IF(NCFILE.GT.MXNAME)THEN PRINT *,' !!!!!! GRCOLG WARNING : The file name is'// - ' truncated to MXNAME (=',MXNAME,') characters.' NCFILE=MIN(NCFILE,MXNAME) ENDIF IF(NCMEMB.GT.8)THEN PRINT *,' !!!!!! GRCOLG WARNING : The member name is'// - ' shortened to ',MEMBER,', first 8 characters.' NCMEMB=MIN(NCMEMB,8) ELSEIF(NCMEMB.LE.0)THEN PRINT *,' !!!!!! GRCOLG WARNING : The member'// - ' name has zero length, replaced by "*".' MEMBER='*' NCMEMB=1 ENDIF * Reject the empty file name case. IF(FILE.EQ.' '.OR.NWORD.EQ.1)THEN PRINT *,' !!!!!! GRCOLG WARNING : GET must be at least'// - ' followed by a dataset name ; no data are read.' RETURN ENDIF * If there are even more args, warn they are ignored. IF(NWORD.GT.IKEY+2)PRINT *,' !!!!!! GRCOLG WARNING : GET takes'// - ' at most two arguments (dataset and member); rest ignored.' ** Open the dataset and inform DSNLOG. CALL DSNOPN(FILE,NCFILE,12,'READ-LIBRARY',IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! GRCOLG WARNING : Opening ',FILE(1:NCFILE), - ' failed ; colour data are not read.' RETURN ENDIF CALL DSNLOG(FILE,'Colours ','Sequential','Read only ') IF(LDEBUG)PRINT *,' ++++++ GRCOLG DEBUG : Dataset', - FILE(1:NCFILE),' opened on unit 12 for seq read.' * Locate the pointer on the header of the requested member. CALL DSNLOC(MEMBER,NCMEMB,'GRAPHCOL',12,EXIS,'RESPECT') IF(.NOT.EXIS)THEN CALL DSNLOC(MEMBER,NCMEMB,'GRAPHCOL',12,EXIS,'IGNORE') IF(EXIS)THEN PRINT *,' ###### GRCOLG ERROR : Colour data ', - MEMBER(1:NCMEMB),' has been deleted from ', - FILE(1:NCFILE),'; not read.' ELSE PRINT *,' ###### GRCOLG ERROR : Colour data ', - MEMBER(1:NCMEMB),' not found on ',FILE(1:NCFILE) ENDIF CLOSE(UNIT=12,IOSTAT=IOS,ERR=2030) RETURN ENDIF ** Check that the member is acceptable date wise. READ(12,'(A80)',END=2000,IOSTAT=IOS,ERR=2010) STRING IF(LDEBUG)THEN PRINT *,' ++++++ GRCOLG DEBUG : Dataset header'// - ' record follows:' PRINT *,STRING ENDIF IF(DSNCMP('14-07-89',STRING(11:18)))THEN PRINT *,' !!!!!! GRCOLG WARNING : Member '//STRING(32:39)// - ' can not be read because of a change in format.' CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) RETURN ENDIF WRITE(LUNOUT,'('' Member '',A8,'' was created on '',A8, - '' at '',A8/'' Remarks: '',A29)') - STRING(32:39),STRING(11:18),STRING(23:30),STRING(51:79) * Read the actual data, start with the number of items of each type. READ(12,'(6X,I3)',END=2000,ERR=2010,IOSTAT=IOS) NCOL * Make sure none of these exceeds the maximum numbers. CALL GQLWK(IWKTYP,IERR,MPL,MPM,MTX,MFA,MPA,MXCOLI) IF(NCOL.GT.MXCOLI.OR.NCOL.GT.MXCOL)THEN PRINT *,' !!!!!! GRCOLG WARNING : The number of colours'// - ' is larger than either the GKS or' PRINT *,' the compilation maxima;'// - ' increase these and recompile.' CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) RETURN ENDIF * Read the list of colours. DO 430 I=0,NCOL READ(12,'(A20,3E15.8)',END=2000,ERR=2010,IOSTAT=IOS) - COLNAM(I),RED,BLUE,GREEN CALL GRSCR(IWKID,I,RED,GREEN,BLUE) 430 CONTINUE ** Close the file after the operation. CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) CALL TIMLOG('Reading in a list of colours: ') IFAIL=0 RETURN *** Plot a colour map. ENTRY GRCOLM ** Loop over the colours, first the loop over the pages. DO 510 II=0,NCOL,20 * Switch to graphics mode. CALL GRGRAF(.TRUE.) * Switch to normalised device coordinates. CALL GSELNT(0) * Switch to solid interior style. CALL GSFAIS(1) * Set reasonable character attributes. CALL GSTXFP(0,2) CALL GSCHXP(1.0) CALL GSCHSP(0.0) CALL GSCHH(0.02) CALL GSTXAL(1,3) CALL GSCHUP(0.0,1.0) CALL GSTXCI(1) * Put some bands over the screen to compare colours, first white. XPL(1)=0.25 YPL(1)=0 XPL(2)=0.25 YPL(2)=1 XPL(3)=0.375 YPL(3)=1 XPL(4)=0.375 YPL(4)=0 XPL(5)=0.25 YPL(5)=0 CALL GSFACI(0) CALL GFA(5,XPL,YPL) * Then a black band. XPL(1)=0.375 YPL(1)=0 XPL(2)=0.375 YPL(2)=1 XPL(3)=0.5 YPL(3)=1 XPL(4)=0.5 YPL(4)=0 XPL(5)=0.375 YPL(5)=0 CALL GSFACI(1) CALL GFA(5,XPL,YPL) * If there are lots of colours, another white band. IF(MIN(19,NCOL-II).GE.10)THEN XPL(1)=0.75 YPL(1)=0 XPL(2)=0.75 YPL(2)=1 XPL(3)=0.875 YPL(3)=1 XPL(4)=0.875 YPL(4)=0 XPL(5)=0.75 YPL(5)=0 CALL GSFACI(0) CALL GFA(5,XPL,YPL) * And another black band. XPL(1)=0.875 YPL(1)=0 XPL(2)=0.875 YPL(2)=1 XPL(3)=1 YPL(3)=1 XPL(4)=1 YPL(4)=0 XPL(5)=0.875 YPL(5)=0 CALL GSFACI(1) CALL GFA(5,XPL,YPL) ENDIF ** Then the loop over the colours on this page. DO 520 I=0,MIN(19,NCOL-II) * Plot the colour name. CALL INPFIX(COLNAM(II+I),AUX,NC) IF(I.LE.9)THEN CALL GTX(0.02,0.95-0.1*I,AUX(1:NC)) ELSE CALL GTX(0.52,1.95-0.1*I,AUX(1:NC)) ENDIF * Set the colour. CALL GSFACI(II+I) * Plot a box with the colour. IF(I.LE.9)THEN XPL(1)=0.26 YPL(1)=0.99-0.1*I XPL(2)=0.26 YPL(2)=0.91-0.1*I XPL(3)=0.49 YPL(3)=0.91-0.1*I XPL(4)=0.49 YPL(4)=0.99-0.1*I XPL(5)=0.26 YPL(5)=0.99-0.1*I ELSE XPL(1)=0.76 YPL(1)=1.99-0.1*I XPL(2)=0.76 YPL(2)=1.91-0.1*I XPL(3)=0.99 YPL(3)=1.91-0.1*I XPL(4)=0.99 YPL(4)=1.99-0.1*I XPL(5)=0.76 YPL(5)=1.99-0.1*I ENDIF CALL GFA(5,XPL,YPL) * Next colour. 520 CONTINUE * Next page. CALL GRALOG('Colour map:') CALL GRNEXT 510 CONTINUE * Keep track of CPU time consumption. CALL TIMLOG('Producing a colour map: ') RETURN *** Colour table reset. ENTRY GRCOLS NCOL=1 RETURN *** Handle the error conditions. 2000 CONTINUE PRINT *,' ###### GRCOLG ERROR : Premature EOF ecountered on '// - FILE(1:NCFILE)//' read via unit 12 ; no valid data read.' CALL INPIOS(IOS) CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) RETURN 2010 CONTINUE PRINT *,' ###### GRCOLW ERROR : I/O error accessing '// - FILE(1:NCFILE)//' via unit 12 ; no data read or written.' CALL INPIOS(IOS) CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) RETURN 2030 CONTINUE PRINT *,' ###### GRCOLW ERROR : Dataset '//FILE(1:NCFILE)// - ' unit 12 cannot be closed ; results not predictable' CALL INPIOS(IOS) END +DECK,GRSCRH,IF=HIGZ. SUBROUTINE GRSCR(IWKID,ICOL,RED,GREEN,BLUE) *----------------------------------------------------------------------- * GRSCR - Sets a colour representation. * GRQCR - Query of a colour representation. * (Last changed on 18/ 5/96.) *----------------------------------------------------------------------- INTEGER IWKID,ICOL,IERR,IFLAG,MXCOL PARAMETER(MXCOL=100) REAL RED,GREEN,BLUE,RGB(MXCOL,3) LOGICAL COLSET(MXCOL) +SELF,IF=SAVE. SAVE RGB,COLSET +SELF. DATA RGB /MXCOL*0,MXCOL*0,MXCOL*0/, - COLSET /MXCOL*.FALSE./ *** Setting colours: if index makes sense, store it. IF(ICOL.GE.1.AND.ICOL.LE.MXCOL)THEN RGB(ICOL,1)=RED RGB(ICOL,2)=GREEN RGB(ICOL,3)=BLUE COLSET(ICOL)=.TRUE. ENDIF * At any rate pass on to HIGZ. CALL ISCR(IWKID,ICOL,RED,GREEN,BLUE) RETURN *** Queries on colour. ENTRY GRQCR(IWKID,ICOL,IFLAG,IERR,RED,GREEN,BLUE) * If within range, return colour setting. IF(ICOL.EQ.0)THEN RED=1 GREEN=1 BLUE=1 IERR=0 ELSEIF(ICOL.EQ.1)THEN RED=0 GREEN=0 BLUE=0 IERR=0 ELSEIF(ICOL.GE.1.AND.ICOL.LE.MXCOL)THEN RED=RGB(ICOL,1) GREEN=RGB(ICOL,2) BLUE=RGB(ICOL,3) IF(COLSET(ICOL))THEN IERR=0 ELSE IERR=1 ENDIF * Otherwise don't. ELSE RED=0 GREEN=0 BLUE=0 IERR=1 ENDIF END +DECK,GRSCRG,IF=-HIGZ. SUBROUTINE GRSCR(IWKID,ICOL,RED,GREEN,BLUE) *----------------------------------------------------------------------- * GRSCR - Sets a colour representation. * GRQCR - Query of a colour representation. * (Last changed on 16/ 8/96.) *----------------------------------------------------------------------- INTEGER IWKID,ICOL,IERR,IFLAG,MXCOL REAL RED,GREEN,BLUE *** Setting colours. CALL GSCR(IWKID,ICOL,RED,GREEN,BLUE) RETURN *** Queries on colour. ENTRY GRQCR(IWKID,ICOL,IFLAG,IERR,RED,GREEN,BLUE) CALL GQCR(IWKID,ICOL,IFLAG,IERR,RED,GREEN,BLUE) END +DECK,GRSPLN. SUBROUTINE GRSPLN(NU,XU,YU) *----------------------------------------------------------------------- * GRSPLN - Plots a smooth line through a set of points. * (Last changed on 12/ 8/96.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. INTEGER NU,IFAIL,I REAL XU(*),YU(*),XPL(MXLIST),YPL(MXLIST),Z(MXLIST),C(MXLIST) *** Check number of points. IF(NU.LE.1)THEN WRITE(10,'('' !!!!!! GRSPLN WARNING : Insufficient'', - '' number ('',I3,'') of points on line; not'', - '' plotted.'')') NU RETURN ELSEIF(NU.GT.MXLIST)THEN WRITE(10,'('' !!!!!! GRSPLN WARNING : Too many points'', - '' ('',I3,'') on line; not plotted.'')') NU RETURN ENDIF *** Prepare interpolation vector. DO 10 I=1,NU Z(I)=1+REAL(MXLIST-1)*REAL(I-1)/REAL(NU-1) 10 CONTINUE *** Prepare x-spline interpolation. CALL SPLINE(Z,XU,C,NU,IFAIL) IF(IFAIL.NE.0)THEN WRITE(10,'('' !!!!!! GRSPLN WARNING : Preparation of'', - '' x-spline failed; line not plotted.'')') RETURN ENDIF *** Perform x-spline interpolation. DO 20 I=1,MXLIST IF(I.EQ.1)THEN XPL(I)=XU(1) ELSEIF(I.EQ.MXLIST)THEN XPL(I)=XU(NU) ELSE CALL INTERP(Z,XU,C,N,REAL(I),XPL(I),IFAIL) IF(IFAIL.NE.0)THEN WRITE(10,'('' !!!!!! GRSPLN WARNING : Interpolating'', - '' x-spline failed; line not plotted.'')') RETURN ENDIF ENDIF 20 CONTINUE *** Prepare y-spline interpolation. CALL SPLINE(Z,YU,C,NU,IFAIL) IF(IFAIL.NE.0)THEN WRITE(10,'('' !!!!!! GRSPLN WARNING : Preparation of'', - '' y-spline failed; line not plotted.'')') RETURN ENDIF *** Perform x-spline interpolation. DO 30 I=1,MXLIST IF(I.EQ.1)THEN YPL(I)=YU(1) ELSEIF(I.EQ.MXLIST)THEN YPL(I)=YU(NU) ELSE CALL INTERP(Z,YU,C,N,REAL(I),YPL(I),IFAIL) IF(IFAIL.NE.0)THEN WRITE(10,'('' !!!!!! GRSPLN WARNING : Interpolating'', - '' y-spline failed; line not plotted.'')') RETURN ENDIF ENDIF 30 CONTINUE *** Plot the curve. CALL GRLINE(MXLIST,XPL,YPL) END +DECK,GRCOMM. SUBROUTINE GRCOMM(I,TEXT) *----------------------------------------------------------------------- * GRCOMM - Plotting a comment line on the plot (up to 4 of them). * (Last changed on 29/11/01.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,GRAPHICS. INTEGER I CHARACTER*(*) TEXT *** Check that the field label is in the range 1 to 4. IF(I.LT.1.OR.I.GT.5)THEN PRINT *,' ###### GRCOMM ERROR : Invalid field label ',I, - ' for the text "',TEXT,'" ; ignored (program bug).' RETURN ENDIF *** Make sure we're in the NDC coordinates. CALL GSELNT(0) *** Set the attributes belonging to comments. CALL GRATTS('COMMENT','TEXT') *** Set the text alignment and character-up vectors properly. CALL GSTXAL(0,0) CALL GSCHUP(0.0,1.0) *** Plot the string in the appropriate place. IF(I.EQ.1)THEN CALL GRTX(DISPX0+0.1,DISPY1-0.1+0.03,TEXT) ELSEIF(I.EQ.2)THEN CALL GRTX(DISPX0+0.1,DISPY1-0.1+0.01,TEXT) ELSEIF(I.EQ.3)THEN CALL GRTX((DISPX0+DISPX1)/2,DISPY1-0.1+0.03,TEXT) ELSEIF(I.EQ.4)THEN CALL GRTX((DISPX0+DISPX1)/2,DISPY1-0.1+0.01,TEXT) ELSEIF(I.EQ.5)THEN CALL GRTX(DISPX0+0.1,DISPY0+0.01,TEXT) ENDIF *** Switch back to the regular coordinate system. CALL GSELNT(1) END +DECK,GREBAR. SUBROUTINE GREBAR(N,X,Y,EX1,EX2,EY1,EY2,TYPE,SIZE) *----------------------------------------------------------------------- * GREBAR - Plots error bars. * (Last changed on 15/ 7/09.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,MATDATA. INTEGER N,ISIZ(1),IMOD,I,MATSLT, - IFAIL1,IFAIL2,IFAIL3,IFAIL4,IFAIL5,IFAIL6, - IRX,IRY,IREX1,IREX2,IREY1,IREY2, - ISX,ISY,ISEX1,ISEX2,ISEY1,ISEY2 REAL X(N),Y(N),EX1(N),EX2(N),EY1(N),EY2(N),SIZE CHARACTER*(*) TYPE EXTERNAL MATSLT *** Allocate matrix space ISIZ(1)=N IMOD=2 CALL MATADM('ALLOCATE',IRX,1,ISIZ,IMOD,IFAIL1) CALL MATADM('ALLOCATE',IRY,1,ISIZ,IMOD,IFAIL2) CALL MATADM('ALLOCATE',IREX1,1,ISIZ,IMOD,IFAIL3) CALL MATADM('ALLOCATE',IREX2,1,ISIZ,IMOD,IFAIL4) CALL MATADM('ALLOCATE',IREY1,1,ISIZ,IMOD,IFAIL5) CALL MATADM('ALLOCATE',IREY2,1,ISIZ,IMOD,IFAIL6) IF(IFAIL1+IFAIL2+IFAIL3+IFAIL4+IFAIL5+IFAIL6.NE.0)THEN PRINT *,' !!!!!! GREBAR WARNING : Allocating memory'// - ' failed; error bars not plotted.' GOTO 1000 ENDIF *** Locate the matrices. ISX=MATSLT(IRX) ISY=MATSLT(IRY) ISEX1=MATSLT(IREX1) ISEY1=MATSLT(IREY1) ISEX2=MATSLT(IREX2) ISEY2=MATSLT(IREY2) IF(ISX*ISY*ISEX1*ISEX2*ISEY1*ISEY2.EQ.0)THEN PRINT *,' !!!!!! GREBAR WARNING : Locating memory'// - ' failed; error bars not plotted.' GOTO 1000 ENDIF *** Copy the data. DO 10 I=1,N MVEC(MORG(ISX)+I)=X(I) MVEC(MORG(ISY)+I)=Y(I) MVEC(MORG(ISEX1)+I)=EX1(I) MVEC(MORG(ISEX2)+I)=EX2(I) MVEC(MORG(ISEY1)+I)=EY1(I) MVEC(MORG(ISEY2)+I)=EY2(I) 10 CONTINUE *** Plot the error bars. CALL MATERR(IRX,IRY,IREX1,IREY1,IREX2,IREY2,TYPE,SIZE) *** Clean up memory. 1000 CONTINUE ISIZ(1)=N IMOD=2 CALL MATADM('DELETE',IRX,1,ISIZ,IMOD,IFAIL1) CALL MATADM('DELETE',IRY,1,ISIZ,IMOD,IFAIL2) CALL MATADM('DELETE',IREX1,1,ISIZ,IMOD,IFAIL3) CALL MATADM('DELETE',IREX2,1,ISIZ,IMOD,IFAIL4) CALL MATADM('DELETE',IREY1,1,ISIZ,IMOD,IFAIL5) CALL MATADM('DELETE',IREY2,1,ISIZ,IMOD,IFAIL6) END +DECK,GREBA2. SUBROUTINE GREBA2(N,X,Y,EX1,EX2,EY1,EY2,TYPE,SIZE) *----------------------------------------------------------------------- * GREBA2 - Plots error bars. * (Last changed on 15/ 7/09.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,MATDATA. INTEGER N,ISIZ(1),IMOD,I,MATSLT, - IFAIL1,IFAIL2,IFAIL3,IFAIL4,IFAIL5,IFAIL6, - IRX,IRY,IREX1,IREX2,IREY1,IREY2, - ISX,ISY,ISEX1,ISEX2,ISEY1,ISEY2 C REAL X(N),Y(N),EX1(N),EX2(N),EY1(N),EY2(N),SIZE DOUBLE PRECISION X(N),Y(N),EX1(N),EX2(N),EY1(N),EY2(N),SIZE CHARACTER*(*) TYPE EXTERNAL MATSLT *** Allocate matrix space ISIZ(1)=N IMOD=2 CALL MATADM('ALLOCATE',IRX,1,ISIZ,IMOD,IFAIL1) CALL MATADM('ALLOCATE',IRY,1,ISIZ,IMOD,IFAIL2) CALL MATADM('ALLOCATE',IREX1,1,ISIZ,IMOD,IFAIL3) CALL MATADM('ALLOCATE',IREX2,1,ISIZ,IMOD,IFAIL4) CALL MATADM('ALLOCATE',IREY1,1,ISIZ,IMOD,IFAIL5) CALL MATADM('ALLOCATE',IREY2,1,ISIZ,IMOD,IFAIL6) IF(IFAIL1+IFAIL2+IFAIL3+IFAIL4+IFAIL5+IFAIL6.NE.0)THEN PRINT *,' !!!!!! GREBA2 WARNING : Allocating memory'// - ' failed; error bars not plotted.' GOTO 1000 ENDIF *** Locate the matrices. ISX=MATSLT(IRX) ISY=MATSLT(IRY) ISEX1=MATSLT(IREX1) ISEY1=MATSLT(IREY1) ISEX2=MATSLT(IREX2) ISEY2=MATSLT(IREY2) IF(ISX*ISY*ISEX1*ISEX2*ISEY1*ISEY2.EQ.0)THEN PRINT *,' !!!!!! GREBA2 WARNING : Locating memory'// - ' failed; error bars not plotted.' GOTO 1000 ENDIF *** Copy the data. DO 10 I=1,N MVEC(MORG(ISX)+I)=X(I) MVEC(MORG(ISY)+I)=Y(I) MVEC(MORG(ISEX1)+I)=EX1(I) MVEC(MORG(ISEX2)+I)=EX2(I) MVEC(MORG(ISEY1)+I)=EY1(I) MVEC(MORG(ISEY2)+I)=EY2(I) 10 CONTINUE *** Plot the error bars. CALL MATERR(IRX,IRY,IREX1,IREY1,IREX2,IREY2,TYPE,REAL(SIZE)) *** Clean up memory. 1000 CONTINUE ISIZ(1)=N IMOD=2 CALL MATADM('DELETE',IRX,1,ISIZ,IMOD,IFAIL1) CALL MATADM('DELETE',IRY,1,ISIZ,IMOD,IFAIL2) CALL MATADM('DELETE',IREX1,1,ISIZ,IMOD,IFAIL3) CALL MATADM('DELETE',IREX2,1,ISIZ,IMOD,IFAIL4) CALL MATADM('DELETE',IREY1,1,ISIZ,IMOD,IFAIL5) CALL MATADM('DELETE',IREY2,1,ISIZ,IMOD,IFAIL6) END +DECK,GREBND. SUBROUTINE GREBND(N,X,Y1,Y2) *----------------------------------------------------------------------- * GREBND - Plots error bars. * (Last changed on 14/12/09.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,MATDATA. INTEGER N,ISIZ(1),IMOD,I,MATSLT, - IFAIL1,IFAIL2,IFAIL3, - IRX,IRY1,IRY2, - ISX,ISY1,ISY2 REAL X(N),Y1(N),Y2(N) EXTERNAL MATSLT *** Allocate matrix space ISIZ(1)=N IMOD=2 CALL MATADM('ALLOCATE',IRX,1,ISIZ,IMOD,IFAIL1) CALL MATADM('ALLOCATE',IRY1,1,ISIZ,IMOD,IFAIL2) CALL MATADM('ALLOCATE',IRY2,1,ISIZ,IMOD,IFAIL3) IF(IFAIL1+IFAIL2+IFAIL3.NE.0)THEN PRINT *,' !!!!!! GREBND WARNING : Allocating memory'// - ' failed; error band not plotted.' GOTO 1000 ENDIF *** Locate the matrices. ISX=MATSLT(IRX) ISY1=MATSLT(IRY1) ISY2=MATSLT(IRY2) IF(ISX*ISY1*ISY2.EQ.0)THEN PRINT *,' !!!!!! GREBND WARNING : Locating memory'// - ' failed; error band not plotted.' GOTO 1000 ENDIF *** Copy the data. DO 10 I=1,N MVEC(MORG(ISX)+I)=X(I) MVEC(MORG(ISY1)+I)=Y1(I) MVEC(MORG(ISY2)+I)=Y2(I) 10 CONTINUE *** Plot the error bars. CALL MATBND(IRX,IRY1,IRY2) *** Clean up memory. 1000 CONTINUE ISIZ(1)=N IMOD=2 CALL MATADM('DELETE',IRX,1,ISIZ,IMOD,IFAIL1) CALL MATADM('DELETE',IRY1,1,ISIZ,IMOD,IFAIL2) CALL MATADM('DELETE',IRY2,1,ISIZ,IMOD,IFAIL3) END +DECK,GREBN2. SUBROUTINE GREBN2(N,X,Y1,Y2) *----------------------------------------------------------------------- * GREBN2 - Plots error bars. * (Last changed on 25/ 5/11.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,MATDATA. INTEGER N,ISIZ(1),IMOD,I,MATSLT, - IFAIL1,IFAIL2,IFAIL3, - IRX,IRY1,IRY2, - ISX,ISY1,ISY2 DOUBLE PRECISION X(N),Y1(N),Y2(N) EXTERNAL MATSLT *** Allocate matrix space ISIZ(1)=N IMOD=2 CALL MATADM('ALLOCATE',IRX,1,ISIZ,IMOD,IFAIL1) CALL MATADM('ALLOCATE',IRY1,1,ISIZ,IMOD,IFAIL2) CALL MATADM('ALLOCATE',IRY2,1,ISIZ,IMOD,IFAIL3) IF(IFAIL1+IFAIL2+IFAIL3.NE.0)THEN PRINT *,' !!!!!! GREBN2 WARNING : Allocating memory'// - ' failed; error band not plotted.' GOTO 1000 ENDIF *** Locate the matrices. ISX=MATSLT(IRX) ISY1=MATSLT(IRY1) ISY2=MATSLT(IRY2) IF(ISX*ISY1*ISY2.EQ.0)THEN PRINT *,' !!!!!! GREBN2 WARNING : Locating memory'// - ' failed; error band not plotted.' GOTO 1000 ENDIF *** Copy the data. DO 10 I=1,N MVEC(MORG(ISX)+I)=REAL(X(I)) MVEC(MORG(ISY1)+I)=REAL(Y1(I)) MVEC(MORG(ISY2)+I)=REAL(Y2(I)) 10 CONTINUE *** Plot the error bars. CALL MATBND(IRX,IRY1,IRY2) *** Clean up memory. 1000 CONTINUE ISIZ(1)=N IMOD=2 CALL MATADM('DELETE',IRX,1,ISIZ,IMOD,IFAIL1) CALL MATADM('DELETE',IRY1,1,ISIZ,IMOD,IFAIL2) CALL MATADM('DELETE',IRY2,1,ISIZ,IMOD,IFAIL3) END +DECK,GRGRPH. SUBROUTINE GRGRPH(X,Y,N,XTEXT,YTEXT,TITLE) *----------------------------------------------------------------------- * GRGRPH - Routine plotting a graph of the points (X,Y). * GRGRSC - Sets the scale of the next graph to be plotted. * VARIABLES : X : x-coordinates of plot points. * Y : y-coordinates of plot points. * N : Number of plot points. * XTEXT : Text along the x-axis. * YTEXT : Text along the y-axis. * (Last changed on 5/ 4/95.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,GRAPHICS. CHARACTER*(*) XTEXT,YTEXT,TITLE REAL X(*),Y(*),XMIN,YMIN,XMAX,YMAX,XMINR,YMINR,XMAXR,YMAXR, - SCMIN,SCMAX,SCMINI,SCMAXI LOGICAL FORCE,XSET,YSET,XFLAG,YFLAG INTEGER I,N +SELF,IF=SAVE. SAVE FORCE,SCMIN,SCMAX +SELF. DATA FORCE/.FALSE./ DATA SCMIN/0.0/,SCMAX/0.0/ *** Determine boundaries of plots. XSET=.FALSE. YSET=.FALSE. XFLAG=.FALSE. YFLAG=.FALSE. DO 10 I=1,N IF((LOGX.AND.X(I).GT.0).OR..NOT.LOGX)THEN IF(XSET)THEN XMIN=MIN(XMIN,X(I)) XMAX=MAX(XMAX,X(I)) ELSE XMIN=X(I) XMAX=X(I) XSET=.TRUE. ENDIF ELSE XFLAG=.TRUE. ENDIF IF((LOGY.AND.Y(I).GT.0).OR..NOT.LOGY)THEN IF(YSET)THEN YMIN=MIN(YMIN,Y(I)) YMAX=MAX(YMAX,Y(I)) ELSE YMIN=Y(I) YMAX=Y(I) YSET=.TRUE. ENDIF ELSE YFLAG=.TRUE. ENDIF 10 CONTINUE *** Make the scale a bit bigger so that the curve fits nicely. IF(LOGX)THEN IF(XFLAG)WRITE(10,'('' !!!!!! GRGRPH WARNING : Non-pos'', - ''itive x-values found on an x-log plot; ignored.'')') IF(.NOT.XSET)THEN PRINT *,' !!!!!! GRGRPH WARNING : x-Range is'// - ' entirely non-positive although logarithmic' PRINT *,' x-scaling'// - ' has been requested; range set to [1,10].' XMIN=1 XMAX=10 ENDIF XMINR=10.0**(LOG10(XMIN)-LOG10(XMAX/XMIN)/20.0) XMAXR=10.0**(LOG10(XMAX)+LOG10(XMAX/XMIN)/20.0) ELSE XMINR=XMIN-(XMAX-XMIN)/20.0 XMAXR=XMAX+(XMAX-XMIN)/20.0 ENDIF *** Verify the automatic scaling request. IF(FORCE.AND.LOGY.AND.(SCMIN.LE.0.OR.SCMAX.LE.0))THEN PRINT *,' !!!!!! GRGRPH WARNING : The specified y-scale'// - ' is not valid as a log scale; using default.' FORCE=.FALSE. ENDIF IF(FORCE.AND.SCMIN.EQ.SCMAX)THEN PRINT *,' !!!!!! GRGRPH WARNING : The specified y-scale'// - ' has zero range; using default.' FORCE=.FALSE. ENDIF *** Override default scale by forced scale if applicable. IF(FORCE)THEN YMINR=SCMIN YMAXR=SCMAX FORCE=.FALSE. * And handle the y range the same way as the x range ELSEIF(LOGY)THEN IF(YFLAG)WRITE(10,'('' !!!!!! GRGRPH WARNING : Non-pos'', - ''itive y-values found on a y-log plot; ignored.'')') IF(.NOT.YSET)THEN PRINT *,' !!!!!! GRGRPH WARNING : y-Range is'// - ' entirely non-positive although logarithmic' PRINT *,' y-scaling'// - ' has been requested; range set to [1,10].' YMIN=1 YMAX=10 ENDIF YMINR=10.0**(LOG10(YMIN)-LOG10(YMAX/YMIN)/20.0) YMAXR=10.0**(LOG10(YMAX)+LOG10(YMAX/YMIN)/20.0) ELSE YMINR=YMIN-(YMAX-YMIN)/20.0 YMAXR=YMAX+(YMAX-YMIN)/20.0 ENDIF *** Plot the coordinate axes. CALL GRCART(XMINR,YMINR,XMAXR,YMAXR,XTEXT,YTEXT,TITLE) *** Plot the line. CALL GRATTS('FUNCTION-1','POLYLINE') IF(N.GT.1)CALL GRLINE(N,X,Y) RETURN *** Entry point to force a scale. ENTRY GRGRSC(SCMINI,SCMAXI) FORCE=.TRUE. SCMIN=MIN(SCMINI,SCMAXI) SCMAX=MAX(SCMINI,SCMAXI) END +DECK,GRGRP2. SUBROUTINE GRGRP2(X,Y,N,XTEXT,YTEXT,TITLE) *----------------------------------------------------------------------- * GRGRP2 - Routine plotting a graph of the points (X,Y). * GRGRS2 - Sets the scale of the next graph to be plotted. * VARIABLES : X : x-coordinates of plot points. * Y : y-coordinates of plot points. * N : Number of plot points. * XTEXT : Text along the x-axis. * YTEXT : Text along the y-axis. * (Last changed on 4/10/99.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,GRAPHICS. CHARACTER*(*) XTEXT,YTEXT,TITLE DOUBLE PRECISION X(*),Y(*),XMIN,YMIN,XMAX,YMAX, - SCMIN,SCMAX,SCMINI,SCMAXI REAL XMINR,YMINR,XMAXR,YMAXR LOGICAL FORCE,XSET,YSET,XFLAG,YFLAG INTEGER I,N +SELF,IF=SAVE. SAVE FORCE,SCMIN,SCMAX +SELF. DATA FORCE/.FALSE./ DATA SCMIN/0.0D0/,SCMAX/0.0D0/ *** Determine boundaries of plots. XSET=.FALSE. YSET=.FALSE. XFLAG=.FALSE. YFLAG=.FALSE. DO 10 I=1,N IF((LOGX.AND.X(I).GT.0).OR..NOT.LOGX)THEN IF(XSET)THEN XMIN=MIN(XMIN,X(I)) XMAX=MAX(XMAX,X(I)) ELSE XMIN=X(I) XMAX=X(I) XSET=.TRUE. ENDIF ELSE XFLAG=.TRUE. ENDIF IF((LOGY.AND.Y(I).GT.0).OR..NOT.LOGY)THEN IF(YSET)THEN YMIN=MIN(YMIN,Y(I)) YMAX=MAX(YMAX,Y(I)) ELSE YMIN=Y(I) YMAX=Y(I) YSET=.TRUE. ENDIF ELSE YFLAG=.TRUE. ENDIF 10 CONTINUE *** Make the scale a bit bigger so that the curve fits nicely. IF(LOGX)THEN IF(XFLAG)WRITE(10,'('' !!!!!! GRGRP2 WARNING : Non-pos'', - ''itive x-values found on an x-log plot; ignored.'')') IF(.NOT.XSET)THEN PRINT *,' !!!!!! GRGRP2 WARNING : x-Range is'// - ' entirely non-positive although logarithmic' PRINT *,' x-scaling'// - ' has been requested; range set to [1,10].' XMIN=1 XMAX=10 ENDIF XMINR=REAL(10.0D0**(LOG10(XMIN)-LOG10(XMAX/XMIN)/20.0D0)) XMAXR=REAL(10.0D0**(LOG10(XMAX)+LOG10(XMAX/XMIN)/20.0D0)) ELSE XMINR=REAL(XMIN-(XMAX-XMIN)/20.0D0) XMAXR=REAL(XMAX+(XMAX-XMIN)/20.0D0) ENDIF *** Verify the automatic scaling request. IF(FORCE.AND.LOGY.AND.(SCMIN.LE.0.OR.SCMAX.LE.0))THEN PRINT *,' !!!!!! GRGRP2 WARNING : The specified y-scale'// - ' is not valid as a log scale; using default.' FORCE=.FALSE. ENDIF IF(FORCE.AND.SCMIN.EQ.SCMAX)THEN PRINT *,' !!!!!! GRGRP2 WARNING : The specified y-scale'// - ' has zero range; using default.' FORCE=.FALSE. ENDIF *** Override default scale by forced scale if applicable. IF(FORCE)THEN YMINR=SCMIN YMAXR=SCMAX FORCE=.FALSE. * And handle the y range the same way as the x range ELSEIF(LOGY)THEN IF(YFLAG)WRITE(10,'('' !!!!!! GRGRP2 WARNING : Non-pos'', - ''itive y-values found on a y-log plot; ignored.'')') IF(.NOT.YSET)THEN PRINT *,' !!!!!! GRGRP2 WARNING : y-Range is'// - ' entirely non-positive although logarithmic' PRINT *,' y-scaling'// - ' has been requested; range set to [1,10].' YMIN=1 YMAX=10 ENDIF YMINR=REAL(10.0D0**(LOG10(YMIN)-LOG10(YMAX/YMIN)/20.0D0)) YMAXR=REAL(10.0D0**(LOG10(YMAX)+LOG10(YMAX/YMIN)/20.0D0)) ELSE YMINR=REAL(YMIN-(YMAX-YMIN)/20.0) YMAXR=REAL(YMAX+(YMAX-YMIN)/20.0) ENDIF *** Plot the coordinate axes. CALL GRCART(XMINR,YMINR,XMAXR,YMAXR,XTEXT,YTEXT,TITLE) *** Plot the line. CALL GRATTS('FUNCTION-1','POLYLINE') IF(N.GT.1)CALL GRLIN2(N,X,Y) RETURN *** Entry point to force a scale. ENTRY GRGRS2(SCMINI,SCMAXI) FORCE=.TRUE. SCMIN=MIN(SCMINI,SCMAXI) SCMAX=MAX(SCMINI,SCMAXI) END +DECK,GRGRAF. SUBROUTINE GRGRAF(WAIT) *----------------------------------------------------------------------- * GRGRAF - Clears the screen, preparing it for graphics. * (Last changed on 6/ 3/04.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. +SEQ,GRAPHICS. +SEQ,GLOBALS. EXTERNAL STDSTR CHARACTER*80 DUMMY LOGICAL STDSTR,WAIT INTEGER IOPSTA,IWKREQ,IERR,NACT,IWK,I,IDUM,IERR1,ICONID,IWKTYP, - IERR2,IWKCAT *** Bring the workstation table up to date. IF(WAIT)THEN * Increment the frame counter. IF(GLBMOD(9).NE.2)THEN PRINT *,' !!!!!! GRGRAF WARNING : Global variable'// - ' FRAME has changed type; reset to Number 1.' GLBMOD(9)=0 GLBMOD(9)=2 ENDIF GLBVAL(9)=GLBVAL(9)+1 * Loop over the workstations. DO 30 IWK=1,NWK * Skip non-file and multiple frame workstations. IF(WKFREF(IWK).EQ.0.OR.WKMULT(IWK))GOTO 30 * Open if the station should be open but isn't. IF(WKSTAT(IWK).LT.2.AND.WKSREQ(IWK).GE.2) - CALL GROPWK(WKNAME(IWK)(1:NCWKNM(IWK)),'IMMEDIATE') * Activate if the station should be active but isn't. IF(WKSTAT(IWK).LT.3.AND.WKSREQ(IWK).GE.3) - CALL GRACWK(WKNAME(IWK)(1:NCWKNM(IWK)),'IMMEDIATE') 30 CONTINUE ENDIF *** See whether there is a workstation with input facilities. CALL GQOPS(IOPSTA) IF(IOPSTA.LT.3)THEN IF(LDEBUG)WRITE(10,'('' ++++++ GRGRAF DEBUG :'', - '' No active workstations.'')') RETURN ENDIF *** Try to find a workstation with input facilities. CALL GQACWK(0,IERR,NACT,IWK) IWKREQ=-1 DO 20 I=1,NACT CALL GQACWK(I,IERR,IDUM,IWK) * Locate one that has input facilities. CALL GQWKC(IWK,IERR1,ICONID,IWKTYP) CALL GQWKCA(IWKTYP,IERR2,IWKCAT) IF(IWKCAT.EQ.2)IWKREQ=IWK 20 CONTINUE *** Only debugging output if there isn't one. IF(IWKREQ.EQ.-1)THEN IF(LDEBUG)WRITE(10,'('' ++++++ GRGRAF DEBUG :'', - '' No active in-out workstation found.'')') *** Warn if there is one while running in batch. ELSEIF(.NOT.STDSTR('INPUT'))THEN WRITE(10,'('' ###### GRGRAF ERROR : Workstation with'', - '' input found in a batch job; please report.'')') *** Otherwise wait for user response. ELSE IF(WAIT.AND.LWAITB)THEN PRINT *,' ' PRINT *,' ----------------------------------' PRINT *,' Graphics output - waiting for (CR)' PRINT *,' ----------------------------------' PRINT *,' ' +SELF,IF=-CMS. READ(5,'(A80)',END=10) DUMMY +SELF,IF=CMS. READ(5,END=2000,NUM=NDUMMY) DUMMY GOTO 10 2000 CONTINUE REWIND(UNIT=5) +SELF. 10 CONTINUE ENDIF +SELF,IF=HIGZ. IF(IWKREQ.NE.-1)CALL IGSG(IWKREQ) +SELF,IF=VAX,CMS,IF=GTSGRAL,IF=-HIGZ. IF(IWKREQ.NE.-1)CALL GCATOG(IWKREQ) +SELF,IF=VAX,IF=ATCGKS,IF=-HIGZ. CALL GUESC001(IWKREQ,1) +SELF. ENDIF *** Clear screen if requested. IF(LGCLRB.AND.WAIT)THEN * Determine Operating State value. CALL GQOPS(IOPSTA) IF(LDEBUG)WRITE(10,'('' ++++++ GRGRAF DEBUG : Current'', - '' GKS operating state: '',I1,''.'')') IOPSTA * Close current segment if open. IF(IOPSTA.EQ.4)CALL GCLSG * Do a clear on all active workstations, if there are any open. IF(IOPSTA.GE.3)THEN CALL GQACWK(0,IERR,NACT,IWK) IF(LDEBUG)WRITE(10,'('' ++++++ GRGRAF DEBUG :'', - '' Number of active WS: '',I3,'', inq err: '', - I3,''.'')') NACT,IERR DO 40 I=1,NACT CALL GQACWK(I,IERR,IDUM,IWK) CALL GCLRWK(IWK,1) IF(LDEBUG)WRITE(10,'('' ++++++ GRGRAF DEBUG :'', - '' Clear sent to WS '',I3,'', inq err: '', - I3,''.'')') IWK,IERR 40 CONTINUE ENDIF * Debugging information ? ELSEIF(LDEBUG)THEN WRITE(10,'('' ++++++ GRGRAF DEBUG : No clear'', - '' of WS done because LGCLRB & WAIT=F.'')') ENDIF END +DECK,GRHIST. SUBROUTINE GRHIST(CONTEN,NCHA,XMIN,XMAX,XTXT,TITLE,FRAME) *---------------------------------------------------------------------- * GRHIST - Subroutine plotting a histogram using the vector CONTEN * as contents and XMIN and XMAX as lower and upper x-bounds. * (Last changed on 22/ 3/07.) *---------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PARAMETERS. +SEQ,GRAPHICS. CHARACTER*(*) XTXT,TITLE CHARACTER*20 AUX1,AUX2,AUX3,STR INTEGER NCHA,I,IOUT,NC1,NC2,NC3,NCSTR REAL XPL(MXLIST),YPL(MXLIST),CONTEN(0:NCHA+1),SUM,XMIN,XMAX, - YMIN,YMAX,FACT LOGICAL FRAME,SETRAN *** Determine maximum and minimum y and compute the total contents. SETRAN=.FALSE. SUM=0 DO 10 I=1,NCHA IF((.NOT.LOGY).OR.CONTEN(I).GT.0)THEN IF(.NOT.SETRAN)THEN YMIN=CONTEN(I) YMAX=CONTEN(I) SETRAN=.TRUE. ELSE IF(YMIN.GT.CONTEN(I))YMIN=CONTEN(I) IF(YMAX.LT.CONTEN(I))YMAX=CONTEN(I) ENDIF ENDIF SUM=SUM+CONTEN(I) 10 CONTINUE *** Check that a range has been set. IF(.NOT.SETRAN)THEN PRINT *,' !!!!!! GRHIST WARNING : No range can be set'// - ' for the histogram plot.' IF(LOGY)THEN YMIN=1 YMAX=10 ELSE YMIN=-1 YMAX=+1 ENDIF ENDIF *** Make the range look a bit nicer. IF(LOGY)THEN IF(YMIN.LE.0.AND.YMAX.GT.0)YMIN=1.0E-3*YMAX IF(YMIN.LE.0)YMIN=1.0 IF(YMAX.LE.YMIN)YMAX=YMIN*10.0 FACT=EXP(0.1*LOG(YMAX/YMIN)) YMIN=YMIN/FACT YMAX=YMAX*FACT ELSE IF(YMIN.GT.0.0)YMIN=0.0 IF(YMAX.LE.YMIN)YMAX=YMIN+1.0 YMAX=1.1*YMAX ENDIF *** Plot a frame using GRCART. IF(FRAME)CALL GRCART(XMIN,YMIN,XMAX,YMAX,XTXT, - 'Entries or probability',TITLE) *** Set the correct graphics representation for the histogram. IGHIST=IGHIST+1 IF(IGHIST.GT.7)IGHIST=1 CALL OUTFMT(REAL(IGHIST),2,STR,NCSTR,'LEFT') CALL GRATTS('HISTOGRAM-'//STR(1:NCSTR),'POLYLINE') *** Plot the histogram. IOUT=0 DO 20 I=1,NCHA * Draw the horizontal segment of the bin. XPL(IOUT+1)=XMIN+REAL(I-1)*(XMAX-XMIN)/REAL(NCHA) XPL(IOUT+2)=XMIN+REAL(I )*(XMAX-XMIN)/REAL(NCHA) YPL(IOUT+1)=CONTEN(I) YPL(IOUT+2)=CONTEN(I) * Check for 0 entries. IF(LOGX.AND.XPL(IOUT+1).LE.0)XPL(IOUT+1)=10.0**FRXMIN IF(LOGX.AND.XPL(IOUT+2).LE.0)XPL(IOUT+2)=10.0**FRXMIN IF(LOGY.AND.YPL(IOUT+1).LE.0)YPL(IOUT+1)=10.0**FRYMIN IF(LOGY.AND.YPL(IOUT+2).LE.0)YPL(IOUT+2)=10.0**FRYMIN * Increment the count. IOUT=IOUT+2 * Check against buffer overflow. IF(IOUT.GE.MXLIST-1)THEN CALL GRLINE(IOUT,XPL,YPL) XPL(1)=XPL(IOUT) YPL(1)=YPL(IOUT) IOUT=1 ENDIF 20 CONTINUE * Plot the remainder of the line. IF(IOUT.GE.2)CALL GRLINE(IOUT,XPL,YPL) *** Indicate over- and underflow. IF(FRAME)THEN CALL OUTFMT(CONTEN(0) ,2,AUX1,NC1,'LEFT') CALL OUTFMT(SUM ,2,AUX2,NC2,'LEFT') CALL OUTFMT(CONTEN(NCHA+1),2,AUX3,NC3,'LEFT') CALL GRCOMM(3,'Under: '//AUX1(1:NC1)//', in: '// - AUX2(1:NC2)//', over: '//AUX3(1:NC3)) ENDIF END +DECK,GRINIT. SUBROUTINE GRINIT *----------------------------------------------------------------------- * GRINIT - Initialises the graphics system. * (Last changed on 15/ 9/08.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,GRAPHICS. +SEQ,PRINTPLOT. +SEQ,CONSTANTS. CHARACTER*8 DATE,TIME CHARACTER*(MXNAME) FILE +SELF,IF=-APOLLO,IF=-LINUX,IF=-MACOSX,IF=-BOINC,IF=-CMS,IF=-VAX. CHARACTER*1 STRING +SELF,IF=APOLLO. CHARACTER*1 STRING +SELF,IF=CMS. INTEGER IFAIL +SELF,IF=HIGZ. INTEGER NWORDS REAL RPAW PARAMETER (NWORDS=50000) COMMON /PAWC/ RPAW(NWORDS) +SELF,IF=BOINC. INTEGER I +SELF,IF=VAX. INTEGER IERR,IRMS,ISTV,IUNIT,ICOND +SELF. EXTERNAL STDSTR LOGICAL STDSTR INTEGER IASF(13),IFAIL1,IFAIL2,IFAIL3,NCFILE,IOS DATA IASF /13*1/ *** Identify the routine. IF(LIDENT)PRINT *,' /// ROUTINE GRINIT ///' *** Fetch date and time. CALL DATTIM(DATE,TIME) +SELF,IF=APOLLO. *** Open a file for GKS error messages. OPEN(UNIT=10,FILE=GKSLOG(1:NCGKS),STATUS='UNKNOWN',IOSTAT=IOS, - ERR=2020) CALL DSNLOG(GKSLOG(1:NCGKS),'GKS errors','Sequential', - 'Append ') 10 CONTINUE READ(10,'(A1)',END=20) STRING GOTO 10 20 CONTINUE WRITE(10,'('' ========== New run on '',A8,'' at '',A8, - '' ========== '')',ERR=2010,IOSTAT=IOS) DATE,TIME +SELF,IF=LINUX,MACOSX. *** Open a file for GKS error messages. OPEN(UNIT=10,FILE=GKSLOG(1:NCGKS),STATUS='UNKNOWN', - ACCESS='APPEND',IOSTAT=IOS,ERR=2020) CALL DSNLOG(GKSLOG(1:NCGKS),'GKS errors','Sequential', - 'Append ') WRITE(10,'('' ========== New run on '',A8,'' at '',A8, - '' ========== '')',ERR=2010,IOSTAT=IOS) DATE,TIME +SELF,IF=BOINC. *** Resolve the file name for BOINC. call boincrf(gkslog(1:ncgks),gkslog) do i=len(gkslog),1,-1 if(gkslog(i:i).ne.' ')then ncgks=i goto 1234 endif enddo 1234 continue *** Open a file for GKS error messages. OPEN(UNIT=10,FILE=GKSLOG(1:NCGKS),STATUS='UNKNOWN', - ACCESS='APPEND',IOSTAT=IOS,ERR=2020) CALL DSNLOG(GKSLOG(1:NCGKS),'GKS errors','Sequential', - 'Append ') WRITE(10,'('' ========== New run on '',A8,'' at '',A8, - '' ========== '')',ERR=2010,IOSTAT=IOS) DATE,TIME +SELF,IF=CMS. *** Open a file for GKS error messages. CALL DSNOPN('GKSERROR LOG A',14,10,'RW-FILE',IFAIL) CALL DSNLOG('GKSERROR LOG','GKS errors','Sequential', - 'Write ') IF(IFAIL.NE.0)THEN IOS=0 GOTO 2020 ENDIF WRITE(10,'('' ========== New run on '',A8,'' at '',A8, - '' ========== '')',ERR=2010,IOSTAT=IOS) DATE,TIME +SELF,IF=VAX. *** Open a file for GKS error messages, first attempt APPEND mode. OPEN(UNIT=10,FILE='GKS_ERROR.LOG',STATUS='UNKNOWN', - ACCESS='APPEND',ERR=201) GOTO 202 * If that failed, check error code for lock state and try NEW. 201 CONTINUE CALL ERRSNS(IERR,IRMS,ISTV,IUNIT,ICOND) IF(IRMS.EQ.98954)THEN PRINT *,' ------ GRINIT MESSAGE : Error logging file is'// - ' already open; opening a new file.' OPEN(UNIT=10,FILE='GKS_ERROR.LOG',STATUS='NEW',ERR=203) GOTO 202 ELSE PRINT *,' ###### GRINIT ERROR : Error logging file can'// - ' not be opened for unknown reason; please report.' CALL QUIT RETURN ENDIF * If that too fails, report and quit. 203 CONTINUE PRINT *,' ###### GRINIT ERROR : Opening the new file fails'// - ' also; terminating program execution.' CALL QUIT RETURN * Things seem to have worked one way or other. 202 CONTINUE CALL DSNLOG('GKS_ERROR.LOG','GKS errors','Sequential', - 'Append ') WRITE(10,'('' ========== New run on '',A8,'' at '',A8, - '' ========== '')',ERR=2010,IOSTAT=IOS) DATE,TIME +SELF,IF=-APOLLO,IF=-LINUX,IF=-MACOSX,IF=-BOINC,IF=-CMS,IF=-VAX. *** Open a file for GKS error messages. OPEN(UNIT=10,FILE=GKSLOG(1:NCGKS),STATUS='UNKNOWN',IOSTAT=IOS, - ERR=2020) CALL DSNLOG(GKSLOG(1:NCGKS),'GKS errors','Sequential', - 'Append ') 10 CONTINUE READ(10,'(A1)',END=20) STRING GOTO 10 20 CONTINUE BACKSPACE(10) WRITE(10,'('' ========== New run on '',A8,'' at '',A8, - '' ========== '')',ERR=2010,IOSTAT=IOS) DATE,TIME +SELF,IF=HIGZ. *** Initialise HIGZ. CALL HLIMIT(NWORDS) CALL HPLINT(0) C CALL MZEBRA(-3) C CALL MZPAW(NWORDS,' ') C CALL IGINIT(0) C CALL IOPKS(10) CALL IGSET('PASS',1.0) +SELF,IF=-HIGZ. *** Open GKS. CALL GOPKS(10,0) +SELF. *** Set aspect-source flags. CALL GSASF(IASF) *** Initialise the workstation table. NWK=0 * First the terminal. IF(STDSTR('INPUT'))THEN NWK=NWK+1 WKNAME(NWK)='TERMINAL' NCWKNM(NWK)=8 CALL GRTERM(WKID(NWK),WKCON(NWK),WKSTAT(NWK),IFAIL1) WKFREF(NWK)=0 WKLUN(NWK)=-1 WKMULT(NWK)=.TRUE. * Open and activate. IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! GRINIT WARNING : Terminal graphics'// - ' graphics is currently disabled because of the'// - ' above error.' NWK=NWK-1 ELSEIF(WKSTAT(NWK).GT.0.OR.WKSTAT(NWK).EQ.0)THEN CALL GROPWK(WKNAME(NWK)(1:NCWKNM(NWK)), - 'IMMEDIATE') CALL GRACWK(WKNAME(NWK)(1:NCWKNM(NWK)), - 'IMMEDIATE') CALL GSDS(NWK,1,1) ELSE IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GRINIT DEBUG :'', - '' TERMINAL not defined at your request.'')') NWK=NWK-1 ENDIF ENDIF * Then the metafile. NWK=NWK+1 WKNAME(NWK)='METAFILE' NCWKNM(NWK)=8 CALL GRMETA(WKID(NWK),WKCON(NWK),FILE,NCFILE,WKSTAT(NWK), - WKMULT(NWK),IFAIL2) CALL STRBUF('STORE',WKFREF(NWK),FILE,NCFILE,IFAIL3) WKLUN(2)=0 * Open and activate. IF(IFAIL2.NE.0.OR.IFAIL3.NE.0)THEN PRINT *,' !!!!!! GRINIT WARNING : Metafile output'// - ' is currently disabled because of the above error.' NWK=NWK-1 ELSEIF(WKSTAT(NWK).GT.0.OR. - (WKSTAT(NWK).EQ.0.AND..NOT.STDSTR('INPUT')))THEN CALL GROPWK(WKNAME(NWK)(1:NCWKNM(NWK)), - 'DELAY') CALL GRACWK(WKNAME(NWK)(1:NCWKNM(NWK)), - 'DELAY') CALL GSDS(NWK,3,1) ELSE IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GRINIT DEBUG :'', - '' METAFILE not defined at your request.'')') NWK=NWK-1 ENDIF *** Switch terminal to alpha-numeric mode. CALL GRALPH *** Graphics options. LGRID=.FALSE. LGRALL=.TRUE. LOGX=.FALSE. LOGY=.FALSE. LSTAMP=.TRUE. LWAITA=.TRUE. +SELF,IF=HIGZ. LWAITB=.FALSE. +SELF,IF=-HIGZ. LWAITB=.TRUE. +SELF. LGCLRB=.TRUE. LGCLRA=.FALSE. LXCCH=.FALSE. LGLCLP=.TRUE. LGMCLP=.TRUE. LGACLP=.TRUE. LGTCLP=.TRUE. STAMP=' with Garfield version 7.44.' NCSTMP=28 *** Display size. DISPX0=0.0 DISPX1=1.0 DISPY0=0.0 DISPY1=1.0 *** Window layout. GPXN =0.007 GPXN10=0.015 GPYN =0.007 GPYN10=0.015 GPXL =0.01 GPYL =0.01 GPXT =0.01 *** Arrow top angle. ARRANG=30.0*PI/180.0 ARRLEN=0.3 *** Bar chart width BARFRC=0.9 *** Histogram and bar chart sequence number IGHIST=0 IGBAR =0 *** Handle problems when opening various files RETURN +SELF,IF=APOLLO,CMS,CRAY,UNIX,VAX,CYGWIN. 2010 CONTINUE PRINT *,' ###### GRINIT ERROR : Unable to write the graphics'// - ' error logging file ; end of program execution.' CALL INPIOS(IOS) STOP +SELF,IF=APOLLO,CMS,CRAY,UNIX,CYGWIN. 2020 CONTINUE PRINT *,' ###### GRINIT ERROR : Unable to open the graphics'// - ' error logging file ; end of program execution.' CALL INPIOS(IOS) STOP +SELF. END +DECK,GRLINE. SUBROUTINE GRLINE(NU,XU,YU) *----------------------------------------------------------------------- * GRLINE - Draws a line in either log or linear coordinates. * (Last changed on 6/ 8/02.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,GRAPHICS. +SEQ,PRINTPLOT. REAL XU(*),YU(*),XPL(MXLIST),YPL(MXLIST),XCUR,YCUR,XLAST,YLAST, - X0,Y0,X1,Y1 INTEGER NPL,IFAIL,NU,I LOGICAL CURIN,LASTIN *** Check number of points. IF(NU.LE.1)RETURN *** Initial settings. LASTIN=.FALSE. NPL=0 *** Loop over the input array. DO 10 I=1,NU * Transform x-coordinate if requested. IF(LOGX)THEN IF(XU(I).LE.0.0)THEN XCUR=FRXMIN-2*ABS(FRXMAX-FRXMIN) ELSE XCUR=LOG10(XU(I)) ENDIF ELSE XCUR=XU(I) ENDIF * Transform y-coordinate if requested. IF(LOGY)THEN IF(YU(I).LE.0.0)THEN YCUR=FRYMIN-2*ABS(FRYMAX-FRYMIN) ELSE YCUR=LOG10(YU(I)) ENDIF ELSE YCUR=YU(I) ENDIF * If no clipping is to be performed, then this is all. IF(.NOT.LGLCLP)THEN IF(NPL.GE.MXLIST)THEN CALL GPL(NPL,XPL,YPL) XPL(1)=XPL(NPL) YPL(1)=YPL(NPL) NPL=1 ENDIF NPL=NPL+1 XPL(NPL)=XCUR YPL(NPL)=YCUR GOTO 10 ENDIF * See whether this point is located is inside the frame. IF(XCUR.GE.FRXMIN.AND.XCUR.LE.FRXMAX.AND. - YCUR.GE.FRYMIN.AND.YCUR.LE.FRYMAX)THEN CURIN=.TRUE. ELSE CURIN=.FALSE. ENDIF * If this is the first point, add to the list and skip the rest. IF(I.EQ.1)THEN IF(CURIN)THEN NPL=1 XPL(NPL)=XCUR YPL(NPL)=YCUR ENDIF GOTO 20 ENDIF * Compute fragment of this that fits in the frame. X0=XLAST Y0=YLAST X1=XCUR Y1=YCUR CALL CLIP(X0,Y0,X1,Y1,FRXMIN,FRYMIN,FRXMAX,FRYMAX,IFAIL) * If fully out (IFAIL=1) then skip the rest. IF(IFAIL.NE.0)THEN GOTO 20 * If both current and last point are 'in', add the point. ELSEIF(LASTIN.AND.CURIN)THEN IF(NPL.GE.MXLIST)THEN CALL GPL(NPL,XPL,YPL) XPL(1)=XPL(NPL) YPL(1)=YPL(NPL) NPL=1 ENDIF NPL=NPL+1 XPL(NPL)=X1 YPL(NPL)=Y1 * If the last point was 'in' and current 'out', add and plot. ELSEIF(LASTIN.AND.(.NOT.CURIN))THEN IF(NPL.GE.MXLIST)THEN CALL GPL(NPL,XPL,YPL) XPL(1)=XPL(NPL) YPL(1)=YPL(NPL) NPL=1 ENDIF NPL=NPL+1 XPL(NPL)=X1 YPL(NPL)=Y1 IF(NPL.GT.1)CALL GPL(NPL,XPL,YPL) NPL=0 * If the last point was 'out' and the current 'in', start a new line. ELSEIF(CURIN.AND.(.NOT.LASTIN))THEN IF(NPL.GT.1)CALL GPL(NPL,XPL,YPL) XPL(1)=X0 YPL(1)=Y0 XPL(2)=X1 YPL(2)=Y1 NPL=2 * If both this point and the last are out, draw this line. ELSE IF(NPL.GT.1)CALL GPL(NPL,XPL,YPL) XPL(1)=X0 YPL(1)=Y0 XPL(2)=X1 YPL(2)=Y1 CALL GPL(2,XPL,YPL) NPL=0 ENDIF * Move 'current' point to 'last' point. 20 CONTINUE XLAST=XCUR YLAST=YCUR LASTIN=CURIN 10 CONTINUE *** Plot what remains in the buffer. IF(NPL.GE.2)CALL GPL(NPL,XPL,YPL) END +DECK,GRLIN2. SUBROUTINE GRLIN2(N,XPL2,YPL2) *----------------------------------------------------------------------- * GRLIN2 - Routine plotting an array of double precision points. * (Last changed on 5/ 2/97.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. DOUBLE PRECISION XPL2(*),YPL2(*) REAL XPL(MXLIST),YPL(MXLIST) INTEGER N,II,I,NPL *** Loop over blocks of length MXLIST (with overlap by 1). DO 20 II=0,N-2,MXLIST-1 *** Transfer XPL2 and YPL2 (double) to XPL and YPL (single precision). DO 10 I=1,MIN(N-II,MXLIST) XPL(I)=REAL(XPL2(II+I)) YPL(I)=REAL(YPL2(II+I)) 10 CONTINUE NPL=MIN(N-II,MXLIST) *** Plot the line. IF(NPL.GE.2)CALL GRLINE(NPL,XPL,YPL) 20 CONTINUE END +DECK,GRMAR2. SUBROUTINE GRMAR2(N,XPL2,YPL2) *----------------------------------------------------------------------- * GRMAR2 - Routine plotting an array of double precision points. * (Last changed on 15/ 9/09.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. DOUBLE PRECISION XPL2(*),YPL2(*) REAL XPL(MXLIST),YPL(MXLIST) INTEGER N,II,I,NPL *** Loop over blocks of length MXLIST (without overlap). DO 20 II=0,N-1,MXLIST *** Transfer XPL2 and YPL2 (double) to XPL and YPL (single precision). DO 10 I=1,MIN(N-II,MXLIST) XPL(I)=REAL(XPL2(II+I)) YPL(I)=REAL(YPL2(II+I)) 10 CONTINUE NPL=MIN(N-II,MXLIST) *** Plot the line. IF(NPL.GE.2)CALL GRMARK(NPL,XPL,YPL) 20 CONTINUE END +DECK,GRARE2. SUBROUTINE GRARE2(N,XPL2,YPL2) *----------------------------------------------------------------------- * GRARE2 - Routine plotting an array of double precision points. * (Last changed on 5/ 2/97.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. DOUBLE PRECISION XPL2(*),YPL2(*) REAL XPL(MXLIST),YPL(MXLIST) INTEGER N,II,I,NPL *** Loop over blocks of length MXLIST. DO 20 II=0,N-2,MXLIST-1 *** Transfer XPL2 and YPL2 (double) to XPL and YPL (single precision). DO 10 I=1,MIN(N-II,MXLIST) XPL(I)=REAL(XPL2(II+I)) YPL(I)=REAL(YPL2(II+I)) 10 CONTINUE NPL=MIN(N-II,MXLIST) *** Plot the line. IF(NPL.GE.3)CALL GRAREA(NPL,XPL,YPL) 20 CONTINUE END +DECK,GFA2. SUBROUTINE GFA2(N,XPL2,YPL2) *----------------------------------------------------------------------- * GFA2 - Routine plotting an array of double precision points. * (Last changed on 6/10/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. DOUBLE PRECISION XPL2(*),YPL2(*) REAL XPL(MXLIST),YPL(MXLIST) INTEGER N,I *** Can only work if the total length isn't exceeding MXLIST. IF(N.GT.MXLIST)THEN PRINT *,' !!!!!! GFA2 WARNING : Input array length'// - ' exceeds compilation limits ; area not plotted.' RETURN ENDIF *** Loop over the points. DO 10 I=1,N XPL(I)=REAL(XPL2(I)) YPL(I)=REAL(YPL2(I)) 10 CONTINUE *** Plot the line. IF(N.GE.3)CALL GFA(N,XPL,YPL) 20 CONTINUE END +DECK,GPM2. SUBROUTINE GPM2(N,XPL2,YPL2) *----------------------------------------------------------------------- * GPM2 - Routine plotting an array of double precision points. * (Last changed on 6/10/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. DOUBLE PRECISION XPL2(*),YPL2(*) REAL XPL(MXLIST),YPL(MXLIST) INTEGER N,II,I,NPL *** Loop over blocks of length MXLIST. DO 20 II=0,N-1,MXLIST *** Transfer XPL2 and YPL2 (double) to XPL and YPL (single precision). DO 10 I=1,MIN(N-II,MXLIST) XPL(I)=REAL(XPL2(II+I)) YPL(I)=REAL(YPL2(II+I)) 10 CONTINUE NPL=MIN(N-II,MXLIST) *** Plot the line. IF(NPL.GE.1)CALL GPM(NPL,XPL,YPL) 20 CONTINUE END +DECK,GRMARK. SUBROUTINE GRMARK(NU,XU,YU) *----------------------------------------------------------------------- * GRMARK - Draws a polymarker in either log or linear coordinates. * (Last changed on 18/10/06.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,GRAPHICS. +SEQ,PRINTPLOT. INTEGER NU,I,NOUT REAL XU(NU),YU(NU),XPL(MXLIST),YPL(MXLIST),XMRK,YMRK *** Check number of points. IF(LDEBUG)WRITE(10,'('' ++++++ GRMARK DEBUG : Line has '',I3, - '' points, scales: '',2L1)') NU,LOGX,LOGY *** Copy, transforming if needed. NOUT=0 DO 10 I=1,NU IF(LOGX)THEN IF(XU(I).LE.0.0)THEN WRITE(10,'('' !!!!!! GRMARK WARNING : Negative'', - '' value x='',E12.5,'' received.'')') XU(I) XMRK=FRXMIN-2*ABS(FRXMAX-FRXMIN) ELSE XMRK=LOG10(XU(I)) ENDIF ELSE XMRK=XU(I) ENDIF IF(LOGY)THEN IF(YU(I).LE.0.0)THEN WRITE(10,'('' !!!!!! GRMARK WARNING : Negative'', - '' value y='',E12.5,'' received.'')') YU(I) YMRK=FRYMIN-2*ABS(FRYMAX-FRYMIN) ELSE YMRK=LOG10(YU(I)) ENDIF ELSE YMRK=YU(I) ENDIF * Always store if there is no clipping. IF(.NOT.LGMCLP)THEN IF(NOUT.GE.MXLIST)THEN CALL GPM(NOUT,XPL,YPL) NOUT=0 ENDIF NOUT=NOUT+1 XPL(NOUT)=XMRK YPL(NOUT)=YMRK * Store if in frame. ELSEIF(XMRK.GE.FRXMIN.AND.XMRK.LE.FRXMAX.AND. - YMRK.GE.FRYMIN.AND.YMRK.LE.FRYMAX)THEN IF(NOUT.GE.MXLIST)THEN CALL GPM(NOUT,XPL,YPL) NOUT=0 ENDIF NOUT=NOUT+1 XPL(NOUT)=XMRK YPL(NOUT)=YMRK IF(LDEBUG)WRITE(10,'(26X,2E12.5,'' -> '',2E12.5)') - XU(I),YU(I),XPL(NOUT),YPL(NOUT) * Otherwise simply skip. ELSE IF(LDEBUG)WRITE(10,'(26X,2E12.5,'' not plotted'')') - XU(I),YU(I) ENDIF 10 CONTINUE *** Plot the selected markers. IF(NOUT.GE.1)CALL GPM(NOUT,XPL,YPL) END +DECK,GRMENUNW,IF=-GTS26. SUBROUTINE GRMENU(STRING,SEPAR,XCMIN,YCMIN,XCMAX,YCMAX, - IWKCH,IDEVCH,ICPET,ICHOIC,IFAIL) *----------------------------------------------------------------------- * GRMENU - Builds a menu from the input string. Version for use with * any GKS conforming to the final standard. *----------------------------------------------------------------------- PARAMETER(MXITEM=10) CHARACTER*(*) STRING CHARACTER SEPAR CHARACTER*20 ITEM(MXITEM) CHARACTER*500 RECORD INTEGER NITEM,LENGTH(MXITEM),IARRAY(1) REAL RARRAY(1) *** Assume we won't fail. IFAIL=0 *** Scan for separator. NITEM=0 I0=1 DO 10 I=1,LEN(STRING) IF(STRING(I:I).EQ.SEPAR.OR.I.EQ.LEN(STRING))THEN IF(NITEM.LT.MXITEM)THEN NITEM=NITEM+1 IF(I.EQ.LEN(STRING).AND.STRING(I:I).NE.SEPAR.AND. - I0.LE.I)THEN ITEM(NITEM)=STRING(I0:I) LENGTH(NITEM)=I-I0+1 ELSEIF(I0.LE.I-1)THEN ITEM(NITEM)=STRING(I0:I-1) LENGTH(NITEM)=I-I0 ELSE ITEM(NITEM)='< not labelled >' LENGTH(NITEM)=16 ENDIF ELSE IFAIL=1 RETURN ENDIF I0=I+1 ENDIF 10 CONTINUE *** Pack the record. CALL GPREC(0,IARRAY,0,RARRAY,NITEM,LENGTH,ITEM,LEN(RECORD), - IERR,NCREC,RECORD) IF(IERR.NE.0)THEN CALL GMSG(IWKCH,'Unable to prepare the menu.') IFAIL=1 RETURN ENDIF *** Check initial default for the choice. IF(ICHOIC.LE.0.OR.ICHOIC.GT.NITEM)ICHOIC=1 *** Initialise the CHOICE. CALL GINCH(IWKCH,IDEVCH,1,ICHOIC,ICPET, - XCMIN,XCMAX,YCMIN,YCMAX,NCREC,RECORD) *** Request a choice. CALL GMSG(IWKCH,'Please choose an item from the menu.') 100 CONTINUE CALL GRQCH(IWKCH,IDEVCH,IERR,ICHOIC) IF(IERR.NE.1.OR.ICHOIC.LE.0.OR.ICHOIC.GT.NITEM)THEN CALL GMSG(IWKCH,'Not a valid choice, please try again.') GOTO 100 ENDIF END +DECK,GRMENUOL,IF=GTS26. SUBROUTINE GRMENU(STRING,SEPAR,XCMIN,YCMIN,XCMAX,YCMAX, - IWKCH,IDEVCH,ICPET,ICHOIC,IFAIL) *----------------------------------------------------------------------- * GRMENU - Builds a menu from the input string. Version for use with * the old GTS-GRAL, having a non-standard call for GPREC. *----------------------------------------------------------------------- PARAMETER(MXITEM=10) CHARACTER*(*) STRING CHARACTER SEPAR CHARACTER*200 ITEM CHARACTER*80 RECORD(10) INTEGER NITEM,LENGTH(MXITEM),IARRAY(1) REAL RARRAY(1) *** First few returns are all on failure. IFAIL=1 *** Scan for separator. NITEM=0 I0=1 NCITEM=1 DO 10 I=1,LEN(STRING) IF(STRING(I:I).EQ.SEPAR.OR.I.EQ.LEN(STRING))THEN IF(NITEM.LT.MXITEM)THEN NITEM=NITEM+1 IF(I.EQ.LEN(STRING).AND.STRING(I:I).NE.SEPAR.AND. - I.GE.I0)THEN IF(NCITEM+I-I0.GT.LEN(ITEM))RETURN ITEM(NCITEM:NCITEM+I-I0)=STRING(I0:MIN(I0+19,I)) LENGTH(NITEM)=MIN(20,I-I0+1) NCITEM=NCITEM+MIN(20,I-I0+1) ELSEIF(I-1.GE.I0)THEN IF(NCITEM+I-I0-1.GT.LEN(ITEM))RETURN ITEM(NCITEM:NCITEM+I-I0-1)= - STRING(I0:MIN(I0+19,I-1)) LENGTH(NITEM)=MIN(20,I-I0) NCITEM=NCITEM+MIN(20,I-I0) ELSE IF(NCITEM+16.GT.LEN(ITEM))RETURN ITEM(NCITEM:NCITEM+15)='< not labelled >' LENGTH(NITEM)=16 NCITEM=NCITEM+16 ENDIF ELSE RETURN ENDIF I0=I+1 ENDIF 10 CONTINUE *** Pack the record. CALL GPREC(NITEM,LENGTH,0,RARRAY,NCITEM,ITEM,10, - IERR,NCREC,RECORD) IF(IERR.NE.0)THEN CALL GMSG(IWKCH,'Unable to prepare the menu.') RETURN ENDIF *** Check initial default for the choice. IF(ICHOIC.LE.0.OR.ICHOIC.GT.NITEM)ICHOIC=1 *** Initialise the CHOICE. CALL GINCH(IWKCH,IDEVCH,1,ICHOIC,ICPET, - XCMIN,XCMAX,YCMIN,YCMAX,NCREC,RECORD) *** Request a choice. CALL GMSG(IWKCH,'Please choose an item from the menu.') 100 CONTINUE CALL GRQCH(IWKCH,IDEVCH,IERR,ICHOIC) IF(IERR.NE.1.OR.ICHOIC.LE.0.OR.ICHOIC.GT.NITEM)THEN CALL GMSG(IWKCH,'Not a valid choice, please try again.') GOTO 100 ENDIF *** Now it has worked. IFAIL=0 END +DECK,GRMETAA,IF=APOLLO,UNIX,CYGWIN. SUBROUTINE GRMETA(IWKTYP,IOFF,FILE,NCFILE,IFLAG,LMULT,IFAIL) *----------------------------------------------------------------------- * GRMETA - Returns the workstation identifier from the command line. * (Last changed on 19/12/10.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. +SELF,IF=APOLLO. %include '/sys/ins/base.ins.ftn' %include '/sys/ins/pgm.ins.ftn' integer*2 iarg,nargs,istat integer pointer(128) +SELF,IF=-APOLLO,IF=G77. integer iargc,nargs,iarg external iargc +SELF,IF=APOLLO,-G77. integer nargs,iarg +SELF. character*(*) file character*128 args integer iwktyp,ioff,ncfile,iflag,ifail,arg_length,inpcmx,istart, - iend,ionoff,icat,idum,inext,iwkr,ioffr,ifail1,ierr,kmult logical lmult external inpcmx *** Default settings. call grwkid('*batch_default',iwktyp,ioff,icat,idum) file='garfield.metafile' ncfile=17 ifail=1 kmult=0 lmult=.true. *** Pick up the value from the command line, count arguments. +SELF,IF=APOLLO. call pgm_$get_args(nargs,pointer) nargs=nargs-1 +SELF,IF=-APOLLO. nargs=iargc() +SELF. *** Find the area devoted to the -metafile option. istart=0 iend=nargs ionoff=0 iflag=0 do iarg=1,nargs +SELF,IF=APOLLO. arg_length=pgm_$get_arg(iarg,args,istat) if(istat.ne.status_$ok)then print *,' !!!!!! GRMETA WARNING : Error fetching an'// - ' argument; default metafile type returned.' ifail=1 return endif +SELF,IF=-APOLLO. call argget(iarg,args,arg_length) +SELF. if(args(1:1).eq.'-'.and.arg_length.gt.1.and.istart.ne.0)then iend=iarg-1 goto 10 elseif(inpcmx(args(1:arg_length),'-meta#file').ne.0)then istart=iarg+1 ionoff=1 elseif(inpcmx(args(1:arg_length),'-nometa#file').ne.0)then ionoff=-1 endif enddo 10 continue *** Return here if there is a -nometafile or no -metafile. if(ionoff.eq.0)then ifail=0 if(ldebug)write(lunout,'('' ++++++ GRMETA DEBUG :'', - '' No -metafile qualifier present.'')') iflag=0 return elseif(ionoff.eq.-1)then ifail=0 iflag=-1 if(ldebug)write(lunout,'('' ++++++ GRMETA DEBUG :'', - '' Request not to produce a metafile.'')') return else iflag=+1 endif *** Decode the part about the metafile. inext=istart do 20 iarg=istart,iend if(iarg.lt.inext)goto 20 ** Retrieve the sub-keyword. +SELF,IF=APOLLO. arg_length=pgm_$get_arg(iarg,args,istat) +SELF,IF=-APOLLO. call argget(iarg,args,arg_length) +SELF. ** Metafile type. if(inpcmx(args(1:arg_length),'t#ype').ne.0)then * Check there indeed is an argument. if(iarg.eq.iend)then PRINT *,' !!!!!! GRMETA WARNING : The argument'// - ' for "type" is missing.' ifail=1 return endif * Retrieve the argument. +SELF,IF=APOLLO. arg_length=pgm_$get_arg(iarg+1,args,istat) +SELF,IF=-APOLLO. call argget(iarg+1,args,arg_length) +SELF. * Compare with standard lists. call grwkid(args(1:arg_length),iwkr,ioffr,icat,ifail1) if((icat.ne.0.and.icat.ne.4).or.ifail1.ne.0)then PRINT *,' !!!!!! GRMETA WARNING : Metafile type '// - args(1:arg_length)//' not valid or only for'// - ' interactive use.' ifail=1 return endif iwktyp=iwkr ioff=ioffr * Debugging output. if(ldebug)write(lunout,'('' ++++++ GRMETA DEBUG :'', - '' Metafile type '',A,'', GKS id '',I5,''.'')') - args(1:arg_length),iwktyp inext=iarg+2 ** Metafile type via GKS identifier. elseif(inpcmx(args(1:arg_length),'GKS#_identifier').ne.0)then * Check there indeed is an argument. if(iarg.eq.iend)then PRINT *,' !!!!!! GRMETA WARNING : The argument'// - ' for "GKS_identifier" is missing.' ifail=1 return endif * Retrieve the argument. +SELF,IF=APOLLO. arg_length=pgm_$get_arg(iarg+1,args,istat) +SELF,IF=-APOLLO. call argget(iarg+1,args,arg_length) +SELF. * Attempt to read the integer. call inpric(args(1:arg_length),iwkr,0,ifail1) if(ifail1.ne.0)then print *,' !!!!!! GRMETA WARNING : The metafile'// - ' GKS identifier is not a valid integer.' ifail=1 return endif * Check workstation category. call gqwkca(iwkr,ierr,icat) if((icat.ne.0.and.icat.ne.4).or.ierr.ne.0)then PRINT *,' !!!!!! GRMETA WARNING : Metafile type '// - args(1:arg_length)//' not valid or only for'// - ' interactive use.' ifail=1 return endif * Store the workstation type. iwktyp=iwkr * Debugging output. if(ldebug)write(lunout,'('' ++++++ GRMETA DEBUG :'', - '' GKS identifier '',I5,'' given for metafile'', - '' type.'')') iwktyp inext=iarg+2 ** Connection offset. elseif(inpcmx(args(1:arg_length),'o#ffset').ne.0)then * Check there indeed is an argument. if(iarg.eq.iend)then PRINT *,' !!!!!! GRMETA WARNING : The argument'// - ' for "offset" is missing.' ifail=1 return endif * Retrieve the argument. +SELF,IF=APOLLO. arg_length=pgm_$get_arg(iarg+1,args,istat) +SELF,IF=-APOLLO. call argget(iarg+1,args,arg_length) +SELF. * Attempt to read the number. call inpric(args(1:arg_length),ioffr,0,ifail1) if(ifail1.ne.0)then print *,' !!!!!! GRMETA WARNING : The metafile'// - ' connection offset is not a valid integer.' ifail=1 return endif ioff=ioffr * Debugging output. if(ldebug)write(lunout,'('' ++++++ GRMETA DEBUG :'', - '' Metafile connection offset '',I3,''.'')') - ioff inext=iarg+2 ** Metafile file-name. elseif(inpcmx(args(1:arg_length),'n#ame').ne.0)then * Check there indeed is an argument. if(iarg.eq.iend)then PRINT *,' !!!!!! GRMETA WARNING : The argument'// - ' for "name" is missing.' ifail=1 return endif * Retrieve the argument. +SELF,IF=APOLLO. arg_length=pgm_$get_arg(iarg+1,args,istat) +SELF,IF=-APOLLO. call argget(iarg+1,args,arg_length) +SELF. * Check the length. if(arg_length.gt.mxname)then print *,' !!!!!! GRMETA WARNING : The file name'// - ' of the metafile is too long.' ifail=1 return else file=args ncfile=arg_length endif * Debugging output. if(ldebug)write(lunout,'('' ++++++ GRMETA DEBUG :'', - '' Metafile file-name '',A,''.'')') FILE(1:NCFILE) inext=iarg+2 ** Single or multiple frame. elseif(inpcmx(args(1:arg_length), - 's#ingle-fr#ame-#file').ne.0)then kmult=-1 elseif(inpcmx(args(1:arg_length), - 'm#ultiple-fr#ame-#file').ne.0)then kmult=+1 ** Anything else is not valid. else print *,' !!!!!! GRMETA WARNING : The keyword '// - args(1:arg_length)//' is not valid within'// - ' -metafile; is ignored.' endif 20 continue *** Set to single-frame-file if there are { } in the file name. if(kmult.eq.-1)then lmult=.false. elseif(kmult.eq.+1)then lmult=.true. elseif(index(file(1:ncfile),'{').ne.0.and. - index(file(1:ncfile),'}').ne.0)then lmult=.false. else lmult=.true. endif *** Things worked fine. ifail=0 end +DECK,GRMETAV,IF=VAX. SUBROUTINE GRMETA(IWKTYP,IOFF,FILE,NCFILE,IFLAG,LMULT,IFAIL) *----------------------------------------------------------------------- * GRMETA - Returns metafile information from the command line. * (Last changed on 21/ 3/92.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. EXTERNAL CLI$GET_VALUE,CLI$PRESENT,CLI$_PRESENT,CLI$_ABSENT, - CLI$_NEGATED,CLI$_DEFAULTED INTEGER STATUS,CLI$GET_VALUE,CLI$PRESENT INTEGER*2 NC CHARACTER*255 META CHARACTER*(MXNAME) FILRES CHARACTER*(*) FILE LOGICAL LMULT INCLUDE '($FORDEF)' INCLUDE '($SSDEF)' +SELF,IF=SAVE. SAVE INIT,IWKRES,IOFRES,FILRES,NCRES,IFRES,IFLAGR +SELF. *** First and subsequent calls. DATA INIT/0/,IWKRES/0/,IOFRES/0/,IFRES/1/,IFLAGR/0/ DATA FILRES/'GARFIELD.METAFILE'/,NCRES/17/ IF(INIT.NE.0)THEN IWKTYP=IWKRES IOFF=IOFRES FILE=FILRES NCFILE=NCRES IFLAG=IFLAGR IFAIL=IFRES RETURN ELSE CALL GRWKID('*batch_default',IWKTYP,IOFF,ICAT,IDUM) FILE='GARFIELD.METAFILE' NCFILE=17 IFAIL=1 IFLAG=0 INIT=1 ENDIF *** Metafile qualifier at all present ? IF(CLI$PRESENT('METAFILE').EQ.%LOC(CLI$_NEGATED))THEN IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GRMETA DEBUG :'', - '' Request not to produce metafile graphics'', - '' output.'')') IFLAG=-1 IFAIL=0 GOTO 100 ENDIF *** Is this a private metafile type ? IF(CLI$PRESENT('META_GKSID'))THEN STATUS=CLI$GET_VALUE('META_GKSID',META,NC) IFLAG=+1 IF(STATUS.NE.SS$_NORMAL)THEN PRINT *,' !!!!!! GRMETA WARNING : Unable to get'// - ' the metafile GKS identifier.' GOTO 100 ENDIF * Attempt to read as integer. CALL INPRIC(META(1:NC),IWKR,0,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! GRMETA WARNING : The metafile'// - ' GKS identifier is not a valid integer.' GOTO 100 ENDIF * Check workstation category. CALL GQWKCA(IWKR,IERR,ICAT) IF((ICAT.NE.0.AND.ICAT.NE.4).OR.IERR.NE.0)THEN PRINT *,' !!!!!! GRMETA WARNING : Metafile type '// - META(1:NC)//' not valid or only for'// - ' interactive use.' GOTO 100 ENDIF * Store workstation type. IWKTYP=IWKR * Debugging output. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GRMETA DEBUG :'', - '' GKS identifier '',I5,'' given for metafile'', - '' type.'')') IWKTYP *** Or a standard metafile type ? ELSEIF(CLI$PRESENT('META_TYPE'))THEN STATUS=CLI$GET_VALUE('META_TYPE',META,NC) IFLAG=+1 IF(STATUS.NE.SS$_NORMAL)THEN PRINT *,' !!!!!! GRMETA WARNING : Unable to get'// - ' the metafile type.' GOTO 100 ENDIF CALL GRWKID(META(1:NC),IWKR,LUNOFF,ICAT,IFAIL1) IF((ICAT.NE.0.AND.ICAT.NE.4).OR.IFAIL1.NE.0)THEN PRINT *,' !!!!!! GRMETA WARNING : Metafile type '// - META(1:NC)//' not valid or only for'// - ' interactive use.' GOTO 100 ENDIF IWKTYP=IWKR IOFF=LUNOFF IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GRMETA DEBUG :'', - '' Metafile type '',A,'', GKS id '',I5,''.'')') - META(1:NC),IWKTYP ENDIF *** Logical unit offset. IF(CLI$PRESENT('META_OFFSET'))THEN STATUS=CLI$GET_VALUE('META_OFFSET',META,NC) IF(STATUS.NE.SS$_NORMAL)THEN PRINT *,' !!!!!! GRMETA WARNING : Unable to get'// - ' the metafile logical unit offset.' GOTO 100 ENDIF CALL INPRIC(META(1:NC),IOFFR,0,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! GRMETA WARNING : The metafile'// - ' logical unit offset is not a valid integer.' GOTO 100 ENDIF IOFF=IOFFR IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GRMETA DEBUG :'', - '' Metafile logical unit offset '',I3,''.'')') - IOFF ENDIF *** Metafile name. IF(CLI$PRESENT('META_NAME'))THEN STATUS=CLI$GET_VALUE('META_NAME',META,NCMETA) IF(STATUS.NE.SS$_NORMAL)THEN PRINT *,' !!!!!! GRMETA WARNING : Unable to get'// - ' the metafile file-name.' GOTO 100 ENDIF IF(NCMETA.GT.MXNAME)THEN PRINT *,' !!!!!! GRMETA WARNING : The file name'// - ' of the metafile is too long.' GOTO 100 ELSE FILE=META NCFILE=NCMETA ENDIF IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GRMETA DEBUG :'', - '' Metafile file-name '',A,''.'')') FILE(1:NCFILE) ENDIF *** Error handling and default storing. IFAIL=0 100 CONTINUE IWKRES=IWKTYP IFRES=IFAIL IOFRES=IOFF FILRES=FILE NCRES=NCFILE IFLAGR=IFLAG END +DECK,GRMETAC,IF=CMS. SUBROUTINE GRMETA(IWKTYP,IOFF,FILE,NCFILE,IFLAG,LMULT,IFAIL) *----------------------------------------------------------------------- * GRMETA - Reads the command string to determine the metafile type. * (Last changed on 4/ 4/94.) *----------------------------------------------------------------------- +SEQ,PRINTPLOT. INTEGER IRC CHARACTER*255 META CHARACTER*(*) FILE LOGICAL LMULT *** Default settings. CALL GRWKID('*batch_default',IWKTYP,IOFF,ICAT,IDUM) FILE='GARFIELD.METAFILE' NCFILE=17 IFLAG=0 IFAIL=1 *** Check whether the metafile has to be active at all. CALL VMREXX('F','META_YN',META,IRC) * Handle errors picking up the value. IF(IRC.NE.0)THEN PRINT *,' !!!!!! GRMETA WARNING : Unable to pick up'// - ' the command line yes/no flag for metafiles.' IFAIL=1 RETURN ENDIF * Check value. IF(META(1:2).EQ.'NO')THEN IFLAG=-1 IF(LDEBUG)PRINT *,' ++++++ GRMETA DEBUG : Requested not'// - ' to produce metafile output.' IFAIL=0 RETURN ELSEIF(META(1:3).NE.'YES')THEN IFLAG=0 PRINT *,' !!!!!! GRMETA WARNING : Invalid metafile yes/no'// - ' flag on the command line; default returned.' IFAIL=1 RETURN ELSE IFLAG=+1 ENDIF *** Read the metafile type. CALL VMREXX('F','META_TYPE',META,IRC) * Handle errors picking up the value. IF(IRC.NE.0)THEN PRINT *,' !!!!!! GRMETA WARNING : Unable to pick up'// - ' the metafile type from the command line.' IFAIL=1 RETURN ENDIF ** Try to identify if it really is a type. IF(META(1:1).NE.'-')THEN * Determine the length. DO I=LEN(META),1,-1 IF(META(I:I).NE.' ')THEN NC=I GOTO 10 ENDIF ENDDO NC=0 10 CONTINUE IF(NC.GT.20)NC=20 * Look in table. CALL GRWKID(META(1:NC),IWKR,LUNOFF,ICAT,IFAIL1) * Check the entry exists and is for batch use. IF((ICAT.NE.0.AND.ICAT.NE.4).OR.IFAIL1.NE.0)THEN PRINT *,' !!!!!! GRMETA WARNING : Metafile type '// - META(1:NC)//' not valid or only for'// - ' interactive use.' IFAIL=1 RETURN ENDIF * Store if OK. IWKTYP=IWKR IOFF=LUNOFF * Debugging output. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GRMETA DEBUG :'', - '' Metafile type '',A,'', GKS id '',I5,''.'')') - META(1:NC),IWKTYP ** Otherwise read the GKS identifier. ELSE CALL VMREXX('F','META_GKSID',META,IRC) * Handle errors picking up the value. IF(IRC.NE.0)THEN PRINT *,' !!!!!! GRMETA WARNING : Unable to pick up'// - ' the metafile GKS identifier from the command line.' IFAIL=1 RETURN ENDIF * Determine the length. DO I=LEN(META),1,-1 IF(META(I:I).NE.' ')THEN NC=I GOTO 20 ENDIF ENDDO NC=0 20 CONTINUE * Interpret as a number. CALL INPRIC(META(1:NC),IWKR,0,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! GRMETA WARNING : The metafile'// - ' GKS identifier is not a valid integer.' IFAIL=1 RETURN ENDIF * Check workstation category. CALL GQWKCA(IWKR,IERR,ICAT) IF((ICAT.NE.0.AND.ICAT.NE.4).OR.IERR.NE.0)THEN PRINT *,' !!!!!! GRMETA WARNING : Metafile type '// - META(1:NC)//' not valid or only for'// - ' interactive use.' IFAIL=1 RETURN ENDIF * Store workstation type. IWKTYP=IWKR * Debugging output. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GRMETA DEBUG :'', - '' Metafile GKS identifier is '',I5,''.'')') - IWKTYP ** And the logical unit offset. CALL VMREXX('F','META_OFFSET',META,IRC) * Handle errors picking up the value. IF(IRC.NE.0)THEN PRINT *,' !!!!!! GRMETA WARNING : Unable to get the'// - ' metafile logical unit offset.' IFAIL=1 RETURN ENDIF * Determine the length. DO I=LEN(META),1,-1 IF(META(I:I).NE.' ')THEN NC=I GOTO 30 ENDIF ENDDO NC=0 30 CONTINUE * Interpret as a number. CALL INPRIC(META(1:NC),IOFFR,0,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! GRMETA WARNING : The metafile'// - ' logical unit offset is not a valid integer.' IFAIL=1 RETURN ENDIF IOFF=IOFFR IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GRMETA DEBUG :'', - '' Metafile logical unit offset '',I3,''.'')') - IOFF ENDIF *** And also get the file name. CALL VMREXX('F','META_NAME',META,IRC) * Handle errors picking up the value. IF(IRC.NE.0)THEN PRINT *,' !!!!!! GRMETA WARNING : Unable to get the'// - ' metafile file name.' IFAIL=1 RETURN ENDIF * Determine the length. DO I=LEN(META),1,-1 IF(META(I:I).NE.' ')THEN NC=I GOTO 40 ENDIF ENDDO NC=0 40 CONTINUE * Verify the format. CALL VMNAME(META,NC,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! GRMETA WARNING : File name format is'// - ' not valid.' IFAIL=1 RETURN ENDIF * Store the result. IF(NC.NE.0)THEN FILE=META(1:NC) NCFILE=NC ELSE FILE=' ' NCFILE=1 ENDIF * Debugging output. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GRMETA DEBUG :'', - '' Metafile file name: '',A,''.'')') FILE(1:NCFILE) *** Things went OK. IFAIL=0 END +DECK,GRNEXT. SUBROUTINE GRNEXT *----------------------------------------------------------------------- * GRNEXT - Routine clearing the screen. * (Last changed on 6/ 3/04.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PARAMETERS. +SEQ,GRAPHICS. +SEQ,PRINTPLOT. CHARACTER*120 STRING CHARACTER*8 DATE,TIME INTEGER NCSTR,IFAIL,IWK EXTERNAL STDSTR LOGICAL STDSTR +SELF,IF=CMS,CRAY,VAX,IF=-HIGZ. INTEGER IOPSTA,IERR,NACT,IWK,IWKREQ,I,IDUM,IERR1,IERR2, - ICONID,IWKTYP,IWKCAT,ISTAT +SELF,IF=APOLLO,UNIX,CYGWIN,IF=-HIGZ. INTEGER IOPSTA,IERR,NACT,IWK,IWKREQ,I,IDUM,IERR +SELF,IF=HIGZ,IF=-CMS. INTEGER IFLAG,IOS +SELF,IF=HIGZ,IF=CMS. INTEGER IFLAG,NDUMMY +SELF. *** Plot the time stamp if requested. IF(LSTAMP)THEN * GKS settings. CALL GSELNT(0) CALL GSTXP(0) CALL GRATTS('MESSAGE','TEXT') CALL GSTXAL(1,5) CALL GSCHUP(1.0,0.0) * Text itself. CALL DATTIM(DATE,TIME) STRING=STAMP NCSTR=NCSTMP CALL INPSUB(STRING,NCSTR,IFAIL) CALL GRTX(DISPX1-0.04,DISPY1-0.04, - 'Plotted at '//TIME//' on '//DATE//STRING(1:NCSTR)) * Restore the normal environment. CALL GSTXAL(0,0) CALL GRTX(DISPX0+0.03,DISPY0+0.03,' ') CALL GSELNT(1) ENDIF +SELF,IF=CMS,CRAY,VAX,IF=-HIGZ. *** Clear screen, first get Operating State value. CALL GQOPS(IOPSTA) IF(LDEBUG)WRITE(10,'('' ++++++ GRNEXT DEBUG : Current'', - '' GKS operating state: '',I1)') IOPSTA * Close current segment if open. IF(IOPSTA.EQ.4)CALL GCLSG * Active workstations, update, wait and clear as appropriate. IF(IOPSTA.GE.3)THEN * Determine number of active workstations. CALL GQACWK(0,IERR,NACT,IWK) IF(LDEBUG)WRITE(10,'('' ++++++ GRNEXT DEBUG : Number'', - '' of active WS: '',I3,'', inq err: '', - I3,''.'')') NACT,IERR IWKREQ=-1 DO 20 I=1,NACT CALL GQACWK(I,IERR,IDUM,IWK) * Update those that are active. CALL GUWK(IWK,0) * Locate one that has input facilities. CALL GQWKC(IWK,IERR1,ICONID,IWKTYP) CALL GQWKCA(IWKTYP,IERR2,IWKCAT) IF(IWKCAT.EQ.1.OR.IWKCAT.EQ.2)IWKREQ=IWK IF(LDEBUG)WRITE(10,'('' ++++++ GRNEXT DEBUG : WS '',I3, - '', type: '',I5,'', conid: '',I4,'' cat: '',I1, - '', GQWKC err: '',I3,'', GQWKCA err: '',I3,''.'')') - IWK,IWKTYP,ICONID,IWKCAT,IERR1,IERR2 20 CONTINUE * Issue an string request to an input workstation. IF(IWKREQ.NE.-1)THEN IF(LWAITA)THEN IF(LDEBUG)WRITE(10,'('' ++++++ GRNEXT DEBUG '', - '': Waiting for return on WS: '',I3,''.'')') - IWKREQ CALL GMSG(IWKREQ, - 'Plot completed, hit RETURN to continue.') CALL GRQST(IWKREQ,1,ISTAT,L,STRING) ELSE IF(LDEBUG)WRITE(10,'('' ++++++ GRNEXT DEBUG '', - '': Waiting has not been requested.'')') ENDIF ELSEIF(LDEBUG)THEN WRITE(10,'('' ++++++ GRNEXT DEBUG : No WS with'', - '' input facilities found.'')') ENDIF * Clear all workstations, if that has been requested by the user. IF(LGCLRA)THEN DO 30 I=1,NACT CALL GQACWK(I,IERR,IDUM,IWK) CALL GCLRWK(IWK,1) IF(LDEBUG)WRITE(10,'('' ++++++ GRNEXT DEBUG :'', - '' Clear sent to WS '',I3,'', inq err: '', - I3,''.'')') IWK,IERR 30 CONTINUE ELSEIF(LDEBUG)THEN WRITE(10,'('' ++++++ GRNEXT DEBUG : No clear'', - '' of WS done because LGCLRA=F.'')') ENDIF ENDIF * And switch to alpha mode. CALL GRALPH +SELF,IF=APOLLO,UNIX,CYGWIN,IF=-HIGZ. *** Clear screen, first get Operating State value. CALL GQOPS(IOPSTA) IF(LDEBUG)WRITE(10,'('' ++++++ GRNEXT DEBUG : Current'', - '' GKS operating state: '',I1,''.'')') IOPSTA * Close current segment if open. IF(IOPSTA.EQ.4)CALL GCLSG * Active workstations, update, wait and clear as appropriate. IF(IOPSTA.GE.3)THEN * Determine number of active workstations. CALL GQACWK(0,IERR,NACT,IWK) IF(LDEBUG)WRITE(10,'('' ++++++ GRNEXT DEBUG : Number'', - '' of active WS: '',I3,'', inq err: '', - I3,''.'')') NACT,IERR DO 40 I=1,NACT CALL GQACWK(I,IERR,IDUM,IWK) * Update those that are active. CALL GUWK(IWK,0) 40 CONTINUE * Wait for user response. IF(LWAITA.AND.STDSTR('INPUT'))THEN PRINT *,' Plot completed, hit RETURN to continue.' READ(5,'(A80)',END=10,IOSTAT=IOS,ERR=10) STRING 10 CONTINUE ENDIF * Clear all workstations, if that has been requested by the user. IF(LGCLRA)THEN DO 50 I=1,NACT CALL GQACWK(I,IERR,IDUM,IWK) CALL GCLRWK(IWK,1) IF(LDEBUG)WRITE(10,'('' ++++++ GRNEXT DEBUG :'', - '' Clear sent to WS '',I3,''.'')') IWK 50 CONTINUE ELSEIF(LDEBUG)THEN WRITE(10,'('' ++++++ GRNEXT DEBUG : No clear'', - '' of WS done because LGCLRA=F.'')') ENDIF ENDIF +SELF,IF=HIGZ,IF=-CMS. CALL IUWK(0,1) IF(LWAITA.AND.STDSTR('INPUT'))THEN IF(LSYNCH)THEN PRINT *,' >>>>>> graphics' ELSE PRINT *,' Plot completed, hit RETURN to proceed.' ENDIF READ(5,'(A80)',END=10,IOSTAT=IOS,ERR=10) STRING 10 CONTINUE ENDIF IF(LGCLRA)CALL ICLRWK(0,IFLAG) +SELF,IF=HIGZ,IF=CMS. CALL IUWK(0,1) IF(LWAITA.AND.STDSTR('INPUT'))THEN IF(LSYNCH)THEN PRINT *,' >>>>>> graphics' ELSE PRINT *,' Plot completed, hit RETURN to proceed.' ENDIF READ(5,END=2000,NUM=NDUMMY) STRING GOTO 10 2000 CONTINUE REWIND(UNIT=5) 10 CONTINUE ENDIF IF(LGCLRA)CALL ICLRWK(0,IFLAG) +SELF. *** Bring the workstation table up to date DO 60 IWK=1,NWK * Skip non-file and multiple frame workstations. IF(WKFREF(IWK).EQ.0.OR.WKMULT(IWK))GOTO 60 * De-activate single frame stations. IF(WKSTAT(IWK).GE.3) - CALL GRDAWK(WKNAME(IWK)(1:NCWKNM(IWK)),'IMMEDIATE') * Close single frame stations. IF(WKSTAT(IWK).GE.2) - CALL GRCLWK(WKNAME(IWK)(1:NCWKNM(IWK)),'IMMEDIATE') 60 CONTINUE END +DECK,GRAOPT. SUBROUTINE GRAOPT(OPT) *----------------------------------------------------------------------- * GRAOPT - Log/linear scales and other options. * (Last changed on 17/ 5/08.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,GRAPHICS. +SEQ,PRINTPLOT. CHARACTER*(*) OPT INTEGER INPCMX,I,J,INEXT,ILAST,LENOPT EXTERNAL INPCMX *** Store the length of the string for later reference. DO 50 I=LEN(OPT),1,-1 IF(OPT(I:I).NE.' ')THEN LENOPT=I GOTO 60 ENDIF 50 CONTINUE RETURN 60 CONTINUE *** Look for starting character of next word. INEXT=1 DO 10 I=1,LENOPT IF(I.LT.INEXT)GOTO 10 * Skip separators. IF(INDEX(' ,',OPT(I:I)).NE.0)GOTO 10 * Word starts, look for the end. DO 20 J=I+1,LENOPT IF(INDEX(' ,',OPT(J:J)).EQ.0)GOTO 20 ILAST=J-1 GOTO 30 20 CONTINUE ILAST=LENOPT 30 CONTINUE INEXT=ILAST+1 * Check the various options. IF(INPCMX(OPT(I:ILAST),'LIN#EAR-X').NE.0)THEN LOGX=.FALSE. ELSEIF(INPCMX(OPT(I:ILAST),'LOG#ARITHMIC-X').NE.0)THEN LOGX=.TRUE. ELSEIF(INPCMX(OPT(I:ILAST),'LIN#EAR-Y').NE.0)THEN LOGY=.FALSE. ELSEIF(INPCMX(OPT(I:ILAST),'LOG#ARITHMIC-Y').NE.0)THEN LOGY=.TRUE. ELSEIF(INPCMX(OPT(I:ILAST),'LOG#ARITHMIC-Y').NE.0)THEN LOGY=.FALSE. ELSEIF(INPCMX(OPT(I:ILAST),'GR#ID-DEC#ADES-#ONLY')+ - INPCMX(OPT(I:ILAST),'DEC#ADES-#ONLY-#GRID').NE.0)THEN LGRALL=.FALSE. ELSEIF(INPCMX(OPT(I:ILAST),'COMP#LETE-GR#ID')+ - INPCMX(OPT(I:ILAST),'GR#ID-COMP#LETE').NE.0)THEN LGRALL=.TRUE. ELSEIF(INPCMX(OPT(I:ILAST),'GR#ID').NE.0)THEN LGRID=.TRUE. ELSEIF(INPCMX(OPT(I:ILAST),'NOGR#ID').NE.0)THEN LGRID=.FALSE. ELSEIF(INPCMX(OPT(I:ILAST),'T#IME-S#TAMP').NE.0)THEN LSTAMP=.TRUE. ELSEIF(INPCMX(OPT(I:ILAST),'NOT#IME-S#TAMP').NE.0)THEN LSTAMP=.FALSE. ELSEIF(INPCMX(OPT(I:ILAST),'CL#EAR-BEF#ORE-#PLOT').NE.0)THEN LGCLRB=.TRUE. ELSEIF(INPCMX(OPT(I:ILAST),'NOCL#EAR-BEF#ORE-#PLOT').NE.0)THEN LGCLRB=.FALSE. ELSEIF(INPCMX(OPT(I:ILAST),'CL#EAR-AFT#ER-#PLOT').NE.0)THEN LGCLRA=.TRUE. ELSEIF(INPCMX(OPT(I:ILAST),'NOCL#EAR-AFT#ER-#PLOT').NE.0)THEN LGCLRA=.FALSE. ELSEIF(INPCMX(OPT(I:ILAST),'WAIT-AFT#ER-#PLOT').NE.0)THEN LWAITA=.TRUE. ELSEIF(INPCMX(OPT(I:ILAST),'NOWAIT-AFT#ER-#PLOT').NE.0)THEN LWAITA=.FALSE. ELSEIF(INPCMX(OPT(I:ILAST),'WAIT-BEF#ORE-#PLOT').NE.0)THEN LWAITB=.TRUE. ELSEIF(INPCMX(OPT(I:ILAST),'NOWAIT-BEF#ORE-#PLOT').NE.0)THEN LWAITB=.FALSE. ELSEIF(INPCMX(OPT(I:ILAST),'CLIP-L#INES').NE.0)THEN LGLCLP=.TRUE. ELSEIF(INPCMX(OPT(I:ILAST),'NOCLIP-L#INES').NE.0)THEN LGLCLP=.FALSE. ELSEIF(INPCMX(OPT(I:ILAST),'CLIP-M#ARKERS').NE.0)THEN LGMCLP=.TRUE. ELSEIF(INPCMX(OPT(I:ILAST),'NOCLIP-M#ARKERS').NE.0)THEN LGMCLP=.FALSE. ELSEIF(INPCMX(OPT(I:ILAST),'CLIP-A#REAS').NE.0)THEN LGACLP=.TRUE. ELSEIF(INPCMX(OPT(I:ILAST),'NOCLIP-A#REAS').NE.0)THEN LGACLP=.FALSE. ELSEIF(INPCMX(OPT(I:ILAST),'CLIP-T#EXT').NE.0)THEN LGTCLP=.TRUE. ELSEIF(INPCMX(OPT(I:ILAST),'NOCLIP-T#EXT').NE.0)THEN LGTCLP=.FALSE. ELSEIF(INPCMX(OPT(I:ILAST),'EX#ECUTE-CONTR#OL-#CHARACTERS').NE. - 0)THEN LXCCH=.TRUE. ELSEIF(INPCMX(OPT(I:ILAST),'DISP#LAY-CONTR#OL-#CHARACTERS').NE. - 0)THEN LXCCH=.FALSE. ELSE PRINT *,' !!!!!! GRAOPT WARNING : The option ', - OPT(I:ILAST),' is not valid ; is ignored.' ENDIF * Position for next word. INEXT=ILAST+1 IF(INEXT.GT.LENOPT)THEN IF(LDEBUG)WRITE(LUNOUT, - '('' ++++++ GRAOPT DEBUG : Current options:''/ - 26X,''Logarithmic-x= '',L1,'', Logarithmic-y='',L1/ - 26X,''Grid overlay = '',L1,'', Time stamp ='',L1/ - 26X,''Clear Before = '',L1,'', Clear After ='',L1/ - 26X,''Wait Before = '',L1,'', Wait After ='',L1/ - 26X,''Execute CC = '',L1,'', Clip lines ='',L1/ - 26X,''Clip markers = '',L1,'', Clip areas ='',L1/ - 26X,''Clip text = '',L1,'', Full grid ='',L1)') - LOGX,LOGY,LGRID,LSTAMP,LGCLRB,LGCLRA,LWAITB,LWAITA, - LXCCH,LGLCLP,LGMCLP,LGACLP,LGTCLP,LGRALL RETURN ENDIF 10 CONTINUE END +DECK,GRARRO. SUBROUTINE GRARRO(X0,Y0,X1,Y1) *----------------------------------------------------------------------- * GRARRO - Plots an arrow. * (Last changed on 2/ 8/09.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. +SEQ,PARAMETERS. +SEQ,GRAPHICS. REAL X0,Y0,X1,Y1,X0NDC,Y0NDC,X1NDC,Y1NDC,XPL(3),YPL(3),XAUX,YAUX, - PHIARR,ALEN,WINDOW(4),VIEWP(4) INTEGER IERR,NT *** Inquire current NT. CALL GQCNTN(IERR,NT) IF(IERR.NE.0)THEN IF(LDEBUG)PRINT *,' ++++++ GRARRO DEBUG : Error from'// - ' GQCNTN, code=',IERR,'; text not plotted.' RETURN ENDIF *** Find out how big the screen is. CALL GQNT(NT,IERR,WINDOW,VIEWP) IF(IERR.NE.0)THEN IF(LDEBUG)PRINT *,' ++++++ GRARRO DEBUG : Error from'// - ' GQNT, code=',IERR,'; text not plotted.' RETURN ENDIF *** Transform points to NDC. IF(LOGX.AND.X0.GT.0)THEN X0NDC=VIEWP(1)+(VIEWP(2)-VIEWP(1))*(LOG10(X0)-WINDOW(1))/ - (WINDOW(2)-WINDOW(1)) ELSEIF(LOGX)THEN X0NDC=-1 ELSE X0NDC=VIEWP(1)+(VIEWP(2)-VIEWP(1))*(X0-WINDOW(1))/ - (WINDOW(2)-WINDOW(1)) ENDIF IF(LOGX.AND.X1.GT.0)THEN X1NDC=VIEWP(1)+(VIEWP(2)-VIEWP(1))*(LOG10(X1)-WINDOW(1))/ - (WINDOW(2)-WINDOW(1)) ELSEIF(LOGX)THEN X1NDC=-1 ELSE X1NDC=VIEWP(1)+(VIEWP(2)-VIEWP(1))*(X1-WINDOW(1))/ - (WINDOW(2)-WINDOW(1)) ENDIF IF(LOGY.AND.Y0.GT.0)THEN Y0NDC=VIEWP(3)+(VIEWP(4)-VIEWP(3))*(LOG10(Y0)-WINDOW(3))/ - (WINDOW(4)-WINDOW(3)) ELSEIF(LOGY)THEN Y0NDC=-1 ELSE Y0NDC=VIEWP(3)+(VIEWP(4)-VIEWP(3))*(Y0-WINDOW(3))/ - (WINDOW(4)-WINDOW(3)) ENDIF IF(LOGY.AND.Y1.GT.0)THEN Y1NDC=VIEWP(3)+(VIEWP(4)-VIEWP(3))*(LOG10(Y1)-WINDOW(3))/ - (WINDOW(4)-WINDOW(3)) ELSEIF(LOGY)THEN Y1NDC=-1 ELSE Y1NDC=VIEWP(3)+(VIEWP(4)-VIEWP(3))*(Y1-WINDOW(3))/ - (WINDOW(4)-WINDOW(3)) ENDIF *** Switch to NDC coordinates. CALL GSELNT(0) *** Straight line of the arrow. XPL(1)=X0NDC YPL(1)=Y0NDC XPL(2)=X1NDC YPL(2)=Y1NDC * Plot in polar coordinates. IF(PRVIEW.EQ.'R-PHI')THEN CALL CFMRTC(XPL,YPL,XAUX,YAUX,2) CALL GPL(2,XAUX,YAUX) * Or in Cartesian coordinates. ELSE CALL GPL(2,XPL,YPL) ENDIF *** Make the arrow top. PHIARR=ATAN2(Y1NDC-Y0NDC,X1NDC-X0NDC) IF(ARRLEN.LT.0)THEN ALEN=ABS(ARRLEN) ELSE ALEN=ARRLEN*SQRT((X1NDC-X0NDC)**2+(Y1NDC-Y0NDC)**2) ENDIF XPL(1)=X1NDC-ALEN*COS(DBLE(PHIARR)+ARRANG) YPL(1)=Y1NDC-ALEN*SIN(DBLE(PHIARR)+ARRANG) XPL(2)=X1NDC YPL(2)=Y1NDC XPL(3)=X1NDC-ALEN*COS(DBLE(PHIARR)-ARRANG) YPL(3)=Y1NDC-ALEN*SIN(DBLE(PHIARR)-ARRANG) * Plot in polar coordinates. IF(PRVIEW.EQ.'R-PHI')THEN CALL CFMRTC(XPL,YPL,XAUX,YAUX,3) CALL GPL(3,XAUX,YAUX) * Or in Cartesian coordinates. ELSE CALL GPL(3,XPL,YPL) ENDIF *** Restore coordinate system. CALL GSELNT(NT) END +DECK,GRTEXT. SUBROUTINE GRTEXT(XTXT,YTXT,TEXT) *----------------------------------------------------------------------- * GRTEXT - Plots a text in NT=0 at WC coordinates (XTXT,YTXT). * (Last changed on 2/ 8/09.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. +SEQ,PARAMETERS. +SEQ,GRAPHICS. REAL XTXT,YTXT,XNDC,YNDC,WINDOW(4),VIEWP(4) INTEGER IERR,NT CHARACTER*(*) TEXT *** Inquire current NT. CALL GQCNTN(IERR,NT) IF(IERR.NE.0)THEN IF(LDEBUG)PRINT *,' ++++++ GRTEXT DEBUG : Error from'// - ' GQCNTN, code=',IERR,'; text not plotted.' RETURN ENDIF *** Find out how big the screen is. CALL GQNT(NT,IERR,WINDOW,VIEWP) IF(IERR.NE.0)THEN IF(LDEBUG)PRINT *,' ++++++ GRTEXT DEBUG : Error from'// - ' GQNT, code=',IERR,'; text not plotted.' RETURN ENDIF *** Translate the (XTXT,YTXT) pair into NDC. IF(LOGX.AND.XTXT.GT.0)THEN XNDC=VIEWP(1)+(VIEWP(2)-VIEWP(1))*(LOG10(XTXT)-WINDOW(1))/ - (WINDOW(2)-WINDOW(1)) ELSEIF(LOGX)THEN XNDC=-1 ELSE XNDC=VIEWP(1)+(VIEWP(2)-VIEWP(1))*(XTXT-WINDOW(1))/ - (WINDOW(2)-WINDOW(1)) ENDIF IF(LOGY.AND.YTXT.GT.0)THEN YNDC=VIEWP(3)+(VIEWP(4)-VIEWP(3))*(LOG10(YTXT)-WINDOW(3))/ - (WINDOW(4)-WINDOW(3)) ELSEIF(LOGY)THEN YNDC=-1 ELSE YNDC=VIEWP(3)+(VIEWP(4)-VIEWP(3))*(YTXT-WINDOW(3))/ - (WINDOW(4)-WINDOW(3)) ENDIF *** Plot the text. CALL GSELNT(0) CALL GRTX(XNDC,YNDC,TEXT) CALL GSELNT(NT) END +DECK,GRTXGKS,IF=-HIGZ. SUBROUTINE GRTX(X,Y,TEXT) *----------------------------------------------------------------------- * GRTX - Calls GTX, version for GKS. * (Last changed on 19/ 5/95.) *----------------------------------------------------------------------- implicit none REAL X,Y CHARACTER*(*) TEXT CALL GTX(X,Y,TEXT) END +DECK,GRTXHIGZ,IF=HIGZ. SUBROUTINE GRTX(X,Y,STRING) *----------------------------------------------------------------------- * GRTX - Calls ITX, version for HIGZ. * (Last changed on 24/ 1/12.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. +SEQ,GRAPHICS. CHARACTER*(*) STRING CHARACTER*256 STROUT LOGICAL UNIT INTEGER NOUT,INEXT,I REAL X,Y *** Identify the routine if requested. IF(LIDENT)PRINT *,' /// ROUTINE GRTX (HIGZ version) ///' *** Debugging output. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GRTX DEBUG : In: "'',A, - ''",'')') STRING *** Do not process empty strings. IF(LEN(STRING).LT.1)RETURN *** Simply copy the string if control characters are to be executed. IF(LXCCH)THEN NOUT=MIN(256,LEN(STRING)) STROUT=STRING *** Convert the control characters in the string if requested. ELSE NOUT=0 UNIT=.FALSE. * Loop over the string. INEXT=1 DO 10 I=1,LEN(STRING) * Skip a few characters. IF(I.LT.INEXT)GOTO 10 * Check for excessive length. IF(NOUT+9.GT.256)GOTO 20 * Fix SGML controls. IF(I+4.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+4)).EQ.''.OR. - STRING(I:MIN(LEN(STRING),I+4)).EQ.'')THEN STROUT(NOUT+1:NOUT+1)='?' INEXT=I+5 NOUT=NOUT+1 ELSEIF(I+4.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+4)).EQ.''.OR. - STRING(I:MIN(LEN(STRING),I+4)).EQ.'')THEN STROUT(NOUT+1:NOUT+1)='^' INEXT=I+5 NOUT=NOUT+1 ELSEIF(I+5.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+5)).EQ.''.OR. - STRING(I:MIN(LEN(STRING),I+5)).EQ.'')THEN STROUT(NOUT+1:NOUT+1)='!' INEXT=I+6 NOUT=NOUT+1 ELSEIF(I+5.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+5)).EQ.''.OR. - STRING(I:MIN(LEN(STRING),I+5)).EQ.'')THEN STROUT(NOUT+1:NOUT+1)='!' INEXT=I+6 NOUT=NOUT+1 ELSEIF(I+5.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+5)).EQ.''.OR. - STRING(I:MIN(LEN(STRING),I+5)).EQ.'')THEN STROUT(NOUT+1:NOUT+1)='&' INEXT=I+6 NOUT=NOUT+1 * Fix a series of control characters. ELSEIF(STRING(I:I).EQ.'|')THEN STROUT(NOUT+1:NOUT+3)='"B#' NOUT=NOUT+3 ELSEIF(STRING(I:I).EQ.'$')THEN STROUT(NOUT+1:NOUT+3)='"D#' NOUT=NOUT+3 ELSEIF(STRING(I:I).EQ.'!')THEN STROUT(NOUT+1:NOUT+3)='"E#' NOUT=NOUT+3 ELSEIF(STRING(I:I).EQ.'#')THEN STROUT(NOUT+1:NOUT+3)='"F#' NOUT=NOUT+3 ELSEIF(STRING(I:I).EQ.'>')THEN STROUT(NOUT+1:NOUT+3)='"G#' NOUT=NOUT+3 ELSEIF(STRING(I:I).EQ.'?')THEN STROUT(NOUT+1:NOUT+3)='"H#' NOUT=NOUT+3 ELSEIF(STRING(I:I).EQ.':')THEN STROUT(NOUT+1:NOUT+3)='"J#' NOUT=NOUT+3 ELSEIF(STRING(I:I).EQ.'<')THEN STROUT(NOUT+1:NOUT+3)='"L#' NOUT=NOUT+3 ELSEIF(STRING(I:I).EQ.'[')THEN STROUT(NOUT+1:NOUT+3)='"M#' UNIT=.TRUE. NOUT=NOUT+3 ELSEIF(STRING(I:I).EQ.']')THEN STROUT(NOUT+1:NOUT+3)='"N#' UNIT=.FALSE. NOUT=NOUT+3 ELSEIF(STRING(I:I).EQ.'{')THEN STROUT(NOUT+1:NOUT+3)='"P#' NOUT=NOUT+3 ELSEIF(STRING(I:I).EQ.'}')THEN STROUT(NOUT+1:NOUT+3)='"Q#' NOUT=NOUT+3 ELSEIF(STRING(I:I).EQ.'%')THEN STROUT(NOUT+1:NOUT+3)='"Y#' NOUT=NOUT+3 ELSEIF(STRING(I:I).EQ.'''')THEN STROUT(NOUT+1:NOUT+5)='"<9>#' NOUT=NOUT+5 ELSEIF(STRING(I:I).EQ.'"')THEN STROUT(NOUT+1:NOUT+6)='"<99>#' NOUT=NOUT+6 * SGML entities, first accented letters "a" and "A". ELSEIF(I+7.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+7)).EQ.'á')THEN STROUT(NOUT+1:NOUT+4)='\\366' INEXT=I+8 NOUT=NOUT+4 ELSEIF(I+7.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+7)).EQ.'Á')THEN STROUT(NOUT+1:NOUT+4)='\\367' INEXT=I+8 NOUT=NOUT+4 ELSEIF(I+6.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+6)).EQ.'â')THEN STROUT(NOUT+1:NOUT+4)='\\276' INEXT=I+7 NOUT=NOUT+4 ELSEIF(I+6.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+6)).EQ.'Â')THEN STROUT(NOUT+1:NOUT+4)='\\300' INEXT=I+7 NOUT=NOUT+4 ELSEIF(I+7.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+7)).EQ.'à')THEN STROUT(NOUT+1:NOUT+4)='\\260' INEXT=I+8 NOUT=NOUT+4 ELSEIF(I+7.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+7)).EQ.'À')THEN STROUT(NOUT+1:NOUT+4)='\\265' INEXT=I+8 NOUT=NOUT+4 ELSEIF(I+6.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+6)).EQ.'å')THEN STROUT(NOUT+1:NOUT+4)='\\357' INEXT=I+7 NOUT=NOUT+4 ELSEIF(I+6.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+6)).EQ.'Å')THEN STROUT(NOUT+1:NOUT+4)='\\362' INEXT=I+7 NOUT=NOUT+4 ELSEIF(I+5.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+5)).EQ.'ä')THEN STROUT(NOUT+1:NOUT+4)='\\311' INEXT=I+6 NOUT=NOUT+4 ELSEIF(I+5.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+5)).EQ.'Ä')THEN STROUT(NOUT+1:NOUT+4)='\\314' INEXT=I+6 NOUT=NOUT+4 * Accented letters "c" and "C". ELSEIF(I+7.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+7)).EQ.'ç')THEN STROUT(NOUT+1:NOUT+4)='\\321' INEXT=I+8 NOUT=NOUT+4 ELSEIF(I+7.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+7)).EQ.'Ç')THEN STROUT(NOUT+1:NOUT+4)='\\322' INEXT=I+8 NOUT=NOUT+4 * Accented letters "e" and "E". ELSEIF(I+7.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+7)).EQ.'é')THEN STROUT(NOUT+1:NOUT+4)='\\323' INEXT=I+8 NOUT=NOUT+4 ELSEIF(I+7.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+7)).EQ.'É')THEN STROUT(NOUT+1:NOUT+4)='\\324' INEXT=I+8 NOUT=NOUT+4 ELSEIF(I+6.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+6)).EQ.'ê')THEN STROUT(NOUT+1:NOUT+4)='\\327' INEXT=I+7 NOUT=NOUT+4 ELSEIF(I+6.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+6)).EQ.'Ê')THEN STROUT(NOUT+1:NOUT+4)='\\330' INEXT=I+7 NOUT=NOUT+4 ELSEIF(I+7.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+7)).EQ.'è')THEN STROUT(NOUT+1:NOUT+4)='\\325' INEXT=I+8 NOUT=NOUT+4 ELSEIF(I+7.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+7)).EQ.'È')THEN STROUT(NOUT+1:NOUT+4)='\\326' INEXT=I+8 NOUT=NOUT+4 ELSEIF(I+5.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+5)).EQ.'ë')THEN STROUT(NOUT+1:NOUT+4)='\\331' INEXT=I+6 NOUT=NOUT+4 ELSEIF(I+5.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+5)).EQ.'Ë')THEN STROUT(NOUT+1:NOUT+4)='\\332' INEXT=I+6 NOUT=NOUT+4 * Accented letters "i" and "I". ELSEIF(I+6.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+6)).EQ.'î')THEN STROUT(NOUT+1:NOUT+4)='\\333' INEXT=I+7 NOUT=NOUT+4 ELSEIF(I+6.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+6)).EQ.'Î')THEN STROUT(NOUT+1:NOUT+4)='\\334' INEXT=I+7 NOUT=NOUT+4 ELSEIF(I+5.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+5)).EQ.'ï')THEN STROUT(NOUT+1:NOUT+4)='\\335' INEXT=I+6 NOUT=NOUT+4 ELSEIF(I+5.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+5)).EQ.'Ï')THEN STROUT(NOUT+1:NOUT+4)='\\336' INEXT=I+6 NOUT=NOUT+4 * Accented letters "l" and "L". ELSEIF(I+7.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+7)).EQ.'ł')THEN STROUT(NOUT+1:NOUT+4)='\\370' INEXT=I+8 NOUT=NOUT+4 ELSEIF(I+7.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+7)).EQ.'Ł')THEN STROUT(NOUT+1:NOUT+4)='\\350' INEXT=I+8 NOUT=NOUT+4 * Accented letters "n" and "N". ELSEIF(I+7.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+7)).EQ.'ñ')THEN STROUT(NOUT+1:NOUT+4)='\\337' INEXT=I+8 NOUT=NOUT+4 ELSEIF(I+7.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+7)).EQ.'Ñ')THEN STROUT(NOUT+1:NOUT+4)='\\340' INEXT=I+8 NOUT=NOUT+4 * Accented letters "o" and "O". ELSEIF(I+6.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+6)).EQ.'ô')THEN STROUT(NOUT+1:NOUT+4)='\\342' INEXT=I+7 NOUT=NOUT+4 ELSEIF(I+6.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+6)).EQ.'Ô')THEN STROUT(NOUT+1:NOUT+4)='\\344' INEXT=I+7 NOUT=NOUT+4 ELSEIF(I+7.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+7)).EQ.'ø')THEN STROUT(NOUT+1:NOUT+4)='\\371' INEXT=I+8 NOUT=NOUT+4 ELSEIF(I+7.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+7)).EQ.'Ø')THEN STROUT(NOUT+1:NOUT+4)='\\351' INEXT=I+8 NOUT=NOUT+4 ELSEIF(I+5.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+5)).EQ.'ö')THEN STROUT(NOUT+1:NOUT+4)='\\345' INEXT=I+6 NOUT=NOUT+4 ELSEIF(I+5.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+5)).EQ.'Ö')THEN STROUT(NOUT+1:NOUT+4)='\\346' INEXT=I+6 NOUT=NOUT+4 * Accented letters "u" and "U". ELSEIF(I+6.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+6)).EQ.'û')THEN STROUT(NOUT+1:NOUT+4)='\\347' INEXT=I+7 NOUT=NOUT+4 ELSEIF(I+6.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+6)).EQ.'Û')THEN STROUT(NOUT+1:NOUT+4)='\\354' INEXT=I+7 NOUT=NOUT+4 ELSEIF(I+7.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+7)).EQ.'ù')THEN STROUT(NOUT+1:NOUT+4)='\\374' INEXT=I+8 NOUT=NOUT+4 ELSEIF(I+7.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+7)).EQ.'Ù')THEN STROUT(NOUT+1:NOUT+4)='\\375' INEXT=I+8 NOUT=NOUT+4 ELSEIF(I+5.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+5)).EQ.'ü')THEN STROUT(NOUT+1:NOUT+4)='\\355' INEXT=I+6 NOUT=NOUT+4 ELSEIF(I+5.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+5)).EQ.'Ü')THEN STROUT(NOUT+1:NOUT+4)='\\356' INEXT=I+6 NOUT=NOUT+4 * Ligatures. ELSEIF(I+6.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+6)).EQ.'æ')THEN STROUT(NOUT+1:NOUT+4)='\\361' INEXT=I+7 NOUT=NOUT+4 ELSEIF(I+6.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+6)).EQ.'Æ')THEN STROUT(NOUT+1:NOUT+4)='\\341' INEXT=I+7 NOUT=NOUT+4 ELSEIF(I+6.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+6)).EQ.'fi')THEN STROUT(NOUT+1:NOUT+4)='\\256' INEXT=I+7 NOUT=NOUT+4 ELSEIF(I+6.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+6)).EQ.'fl')THEN STROUT(NOUT+1:NOUT+4)='\\257' INEXT=I+7 NOUT=NOUT+4 ELSEIF(I+6.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+6)).EQ.'œ')THEN STROUT(NOUT+1:NOUT+4)='\\372' INEXT=I+7 NOUT=NOUT+4 ELSEIF(I+6.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+6)).EQ.'Œ')THEN STROUT(NOUT+1:NOUT+4)='\\352' INEXT=I+7 NOUT=NOUT+4 ELSEIF(I+6.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+6)).EQ.'ß')THEN STROUT(NOUT+1:NOUT+4)='\\373' INEXT=I+7 NOUT=NOUT+4 * Lower case Greek characters. ELSEIF(I+6.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+6)).EQ.'α')THEN STROUT(NOUT+1:NOUT+3)='[a]' INEXT=I+7 NOUT=NOUT+3 ELSEIF(I+5.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+5)).EQ.'β')THEN STROUT(NOUT+1:NOUT+3)='[b]' INEXT=I+6 NOUT=NOUT+3 ELSEIF(I+4.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+4)).EQ.'η')THEN STROUT(NOUT+1:NOUT+3)='[c]' INEXT=I+5 NOUT=NOUT+3 ELSEIF(I+6.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+6)).EQ.'δ')THEN STROUT(NOUT+1:NOUT+3)='[d]' INEXT=I+7 NOUT=NOUT+3 ELSEIF(I+8.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+8)).EQ.'ε')THEN STROUT(NOUT+1:NOUT+3)='[e]' INEXT=I+9 NOUT=NOUT+3 ELSEIF(I+4.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+4)).EQ.'φ')THEN STROUT(NOUT+1:NOUT+3)='[f]' INEXT=I+5 NOUT=NOUT+3 ELSEIF(I+6.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+6)).EQ.'γ')THEN STROUT(NOUT+1:NOUT+3)='[g]' INEXT=I+7 NOUT=NOUT+3 ELSEIF(I+4.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+4)).EQ.'χ')THEN STROUT(NOUT+1:NOUT+3)='[h]' INEXT=I+5 NOUT=NOUT+3 ELSEIF(I+5.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+5)).EQ.'ι')THEN STROUT(NOUT+1:NOUT+3)='[i]' INEXT=I+6 NOUT=NOUT+3 ELSEIF(I+6.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+6)).EQ.'κ')THEN STROUT(NOUT+1:NOUT+3)='[k]' INEXT=I+7 NOUT=NOUT+3 ELSEIF(I+7.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+7)).EQ.'λ')THEN STROUT(NOUT+1:NOUT+3)='[l]' INEXT=I+8 NOUT=NOUT+3 ELSEIF(I+3.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+3)).EQ.'μ')THEN STROUT(NOUT+1:NOUT+3)='[m]' INEXT=I+4 NOUT=NOUT+3 ELSEIF(I+3.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+3)).EQ.'ν')THEN STROUT(NOUT+1:NOUT+3)='[n]' INEXT=I+4 NOUT=NOUT+3 ELSEIF(I+8.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+8)).EQ.'ο')THEN STROUT(NOUT+1:NOUT+3)='[o]' INEXT=I+9 NOUT=NOUT+3 ELSEIF(I+3.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+3)).EQ.'π')THEN STROUT(NOUT+1:NOUT+3)='[p]' INEXT=I+4 NOUT=NOUT+3 ELSEIF(I+6.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+6)).EQ.'θ')THEN STROUT(NOUT+1:NOUT+3)='[q]' INEXT=I+7 NOUT=NOUT+3 ELSEIF(I+9.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+9)).EQ.'ϑ')THEN STROUT(NOUT+1:NOUT+6)='[\\112]' INEXT=I+10 NOUT=NOUT+6 ELSEIF(I+4.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+4)).EQ.'ρ')THEN STROUT(NOUT+1:NOUT+3)='[r]' INEXT=I+5 NOUT=NOUT+3 ELSEIF(I+6.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+6)).EQ.'σ')THEN STROUT(NOUT+1:NOUT+3)='[s]' INEXT=I+7 NOUT=NOUT+3 ELSEIF(I+7.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+7)).EQ.'ς')THEN STROUT(NOUT+1:NOUT+6)='[\\126]' INEXT=I+8 NOUT=NOUT+6 ELSEIF(I+4.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+4)).EQ.'τ')THEN STROUT(NOUT+1:NOUT+3)='[t]' INEXT=I+5 NOUT=NOUT+3 ELSEIF(I+8.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+8)).EQ.'υ')THEN STROUT(NOUT+1:NOUT+3)='[u]' INEXT=I+9 NOUT=NOUT+3 ELSEIF(I+6.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+6)).EQ.'ω')THEN STROUT(NOUT+1:NOUT+3)='[w]' INEXT=I+7 NOUT=NOUT+3 ELSEIF(I+4.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+4)).EQ.'&ksi;')THEN STROUT(NOUT+1:NOUT+3)='[x]' INEXT=I+5 NOUT=NOUT+3 ELSEIF(I+3.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+3)).EQ.'ξ')THEN STROUT(NOUT+1:NOUT+3)='[x]' INEXT=I+4 NOUT=NOUT+3 ELSEIF(I+4.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+4)).EQ.'ψ')THEN STROUT(NOUT+1:NOUT+3)='[y]' INEXT=I+5 NOUT=NOUT+3 ELSEIF(I+5.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+5)).EQ.'ζ')THEN STROUT(NOUT+1:NOUT+3)='[z]' INEXT=I+6 NOUT=NOUT+3 * Upper case Greek characters. ELSEIF(I+6.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+6)).EQ.'Α')THEN STROUT(NOUT+1:NOUT+3)='[A]' INEXT=I+7 NOUT=NOUT+3 ELSEIF(I+5.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+5)).EQ.'Β')THEN STROUT(NOUT+1:NOUT+3)='[B]' INEXT=I+6 NOUT=NOUT+3 ELSEIF(I+4.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+4)).EQ.'Η')THEN STROUT(NOUT+1:NOUT+3)='[E]' INEXT=I+5 NOUT=NOUT+3 ELSEIF(I+6.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+6)).EQ.'Δ')THEN STROUT(NOUT+1:NOUT+3)='[D]' INEXT=I+7 NOUT=NOUT+3 ELSEIF(I+8.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+8)).EQ.'Ε')THEN STROUT(NOUT+1:NOUT+3)='[E]' INEXT=I+9 NOUT=NOUT+3 ELSEIF(I+4.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+4)).EQ.'Φ')THEN STROUT(NOUT+1:NOUT+3)='[F]' INEXT=I+5 NOUT=NOUT+3 ELSEIF(I+6.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+6)).EQ.'Γ')THEN STROUT(NOUT+1:NOUT+3)='[G]' INEXT=I+7 NOUT=NOUT+3 ELSEIF(I+4.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+4)).EQ.'Χ')THEN STROUT(NOUT+1:NOUT+3)='[H]' INEXT=I+5 NOUT=NOUT+3 ELSEIF(I+5.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+5)).EQ.'Ι')THEN STROUT(NOUT+1:NOUT+3)='[I]' INEXT=I+6 NOUT=NOUT+3 ELSEIF(I+6.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+6)).EQ.'Κ')THEN STROUT(NOUT+1:NOUT+3)='[K]' INEXT=I+7 NOUT=NOUT+3 ELSEIF(I+7.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+7)).EQ.'Λ')THEN STROUT(NOUT+1:NOUT+3)='[L]' INEXT=I+8 NOUT=NOUT+3 ELSEIF(I+3.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+3)).EQ.'Μ')THEN STROUT(NOUT+1:NOUT+3)='[M]' INEXT=I+4 NOUT=NOUT+3 ELSEIF(I+3.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+3)).EQ.'Ν')THEN STROUT(NOUT+1:NOUT+3)='[N]' INEXT=I+4 NOUT=NOUT+3 ELSEIF(I+8.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+8)).EQ.'Ο')THEN STROUT(NOUT+1:NOUT+3)='[O]' INEXT=I+9 NOUT=NOUT+3 ELSEIF(I+3.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+3)).EQ.'Π')THEN STROUT(NOUT+1:NOUT+3)='[P]' INEXT=I+4 NOUT=NOUT+3 ELSEIF(I+6.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+6)).EQ.'Θ')THEN STROUT(NOUT+1:NOUT+3)='[Q]' INEXT=I+7 NOUT=NOUT+3 ELSEIF(I+4.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+4)).EQ.'Ρ')THEN STROUT(NOUT+1:NOUT+3)='[R]' INEXT=I+5 NOUT=NOUT+3 ELSEIF(I+6.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+6)).EQ.'Σ')THEN STROUT(NOUT+1:NOUT+3)='[S]' INEXT=I+7 NOUT=NOUT+3 ELSEIF(I+4.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+4)).EQ.'Τ')THEN STROUT(NOUT+1:NOUT+3)='[T]' INEXT=I+5 NOUT=NOUT+3 ELSEIF(I+8.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+8)).EQ.'Υ')THEN STROUT(NOUT+1:NOUT+3)='[U]' INEXT=I+9 NOUT=NOUT+3 ELSEIF(I+6.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+6)).EQ.'Ω')THEN STROUT(NOUT+1:NOUT+3)='[W]' INEXT=I+7 NOUT=NOUT+3 ELSEIF(I+4.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+4)).EQ.'&Ksi;')THEN STROUT(NOUT+1:NOUT+3)='[X]' INEXT=I+5 NOUT=NOUT+3 ELSEIF(I+3.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+3)).EQ.'Ξ')THEN STROUT(NOUT+1:NOUT+3)='[X]' INEXT=I+4 NOUT=NOUT+3 ELSEIF(I+4.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+4)).EQ.'Ψ')THEN STROUT(NOUT+1:NOUT+3)='[Y]' INEXT=I+5 NOUT=NOUT+3 ELSEIF(I+5.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+5)).EQ.'Ζ')THEN STROUT(NOUT+1:NOUT+3)='[Z]' INEXT=I+6 NOUT=NOUT+3 * Some special symbols. ELSEIF(I+4.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+4)).EQ.'&')THEN STROUT(NOUT+1:NOUT+4)='\\046' INEXT=I+5 NOUT=NOUT+4 ELSEIF(I+7.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+7)).EQ.'@')THEN STROUT(NOUT+1:NOUT+4)='\\100' INEXT=I+8 NOUT=NOUT+4 ELSEIF(I+5.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+5)).EQ.'©')THEN STROUT(NOUT+1:NOUT+6)='[\\323]' INEXT=I+6 NOUT=NOUT+6 ELSEIF(I+5.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+5)).EQ.'↓')THEN STROUT(NOUT+1:NOUT+6)='"\\257#' INEXT=I+6 NOUT=NOUT+6 ELSEIF(I+4.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+4)).EQ.'°')THEN STROUT(NOUT+1:NOUT+4)='\\312' INEXT=I+5 NOUT=NOUT+4 ELSEIF(I+7.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+7)).EQ.'$')THEN STROUT(NOUT+1:NOUT+4)='\\044' INEXT=I+8 NOUT=NOUT+4 ELSEIF(I+5.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+5)).EQ.'€')THEN STROUT(NOUT+1:NOUT+6)='[\\360]' INEXT=I+6 NOUT=NOUT+6 ELSEIF(I+1.LE.LEN(STRING).AND. - (STRING(I:MIN(LEN(STRING),I+1)).EQ.'>='.OR. - STRING(I:MIN(LEN(STRING),I+1)).EQ.'=>'))THEN STROUT(NOUT+1:NOUT+3)='"O#' INEXT=I+2 NOUT=NOUT+3 ELSEIF(I+3.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+3)).EQ.'≥')THEN STROUT(NOUT+1:NOUT+6)='"\\263#' INEXT=I+4 NOUT=NOUT+6 ELSEIF(I+3.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+3)).EQ.'>')THEN STROUT(NOUT+1:NOUT+6)='"\\076#' INEXT=I+4 NOUT=NOUT+6 ELSEIF(I+5.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+5)).EQ.'↔')THEN STROUT(NOUT+1:NOUT+6)='"\\071#' INEXT=I+6 NOUT=NOUT+6 ELSEIF(I+8.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+8)).EQ.'_integral')THEN STROUT(NOUT+1:NOUT+3)='"I#' INEXT=I+9 NOUT=NOUT+3 ELSEIF(I+4.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+4)).EQ.'∫')THEN STROUT(NOUT+1:NOUT+6)='"\\111#' INEXT=I+5 NOUT=NOUT+6 ELSEIF(I+5.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+5)).EQ.'←')THEN STROUT(NOUT+1:NOUT+6)='"\\067#' INEXT=I+6 NOUT=NOUT+6 ELSEIF(I+1.LE.LEN(STRING).AND. - (STRING(I:MIN(LEN(STRING),I+1)).EQ.'<='.OR. - STRING(I:MIN(LEN(STRING),I+1)).EQ.'=<'))THEN STROUT(NOUT+1:NOUT+3)='"o#' INEXT=I+2 NOUT=NOUT+3 ELSEIF(I+3.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+3)).EQ.'≤')THEN STROUT(NOUT+1:NOUT+6)='"\\243#' INEXT=I+4 NOUT=NOUT+6 ELSEIF(I+5.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+5)).EQ.'[')THEN STROUT(NOUT+1:NOUT+4)='\\133' INEXT=I+6 NOUT=NOUT+4 ELSEIF(I+3.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+3)).EQ.'<')THEN STROUT(NOUT+1:NOUT+6)='"\\074#' INEXT=I+4 NOUT=NOUT+6 ELSEIF(I+4.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+4)).EQ.'#')THEN STROUT(NOUT+1:NOUT+4)='\\043' INEXT=I+5 NOUT=NOUT+4 ELSEIF(I+7.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+7)).EQ.'%')THEN STROUT(NOUT+1:NOUT+4)='\\045' INEXT=I+8 NOUT=NOUT+4 ELSEIF(I+7.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+7)).EQ.'‰')THEN STROUT(NOUT+1:NOUT+4)='\\275' INEXT=I+8 NOUT=NOUT+4 ELSEIF(I+2.LE.LEN(STRING).AND. - (STRING(I:MIN(LEN(STRING),I+2)).EQ.'_+-'.OR. - STRING(I:MIN(LEN(STRING),I+2)).EQ.'_pm'))THEN STROUT(NOUT+1:NOUT+3)='"A#' INEXT=I+3 NOUT=NOUT+3 ELSEIF(I+7.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+7)).EQ.'±')THEN STROUT(NOUT+1:NOUT+6)='"\\261#' INEXT=I+8 NOUT=NOUT+6 ELSEIF(I+5.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+5)).EQ.'→')THEN STROUT(NOUT+1:NOUT+6)='"\\065#' INEXT=I+6 NOUT=NOUT+6 ELSEIF(I+4.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+4)).EQ.'®')THEN STROUT(NOUT+1:NOUT+8)='^[\\322]!' INEXT=I+5 NOUT=NOUT+8 ELSEIF(I+5.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+5)).EQ.']')THEN STROUT(NOUT+1:NOUT+4)='\\135' INEXT=I+6 NOUT=NOUT+4 ELSEIF(I+6.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+6)).EQ.'√')THEN STROUT(NOUT+1:NOUT+6)='"\\122#' INEXT=I+7 NOUT=NOUT+6 ELSEIF(I+5.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+5)).EQ.'&sqrt;')THEN STROUT(NOUT+1:NOUT+6)='"\\122#' INEXT=I+6 NOUT=NOUT+6 ELSEIF(I+6.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+6)).EQ.'™')THEN STROUT(NOUT+1:NOUT+8)='^[\\324]!' INEXT=I+7 NOUT=NOUT+8 ELSEIF(I+5.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+8)).EQ.'&partial;')THEN STROUT(NOUT+1:NOUT+6)='"\\144#' INEXT=I+9 NOUT=NOUT+6 ELSEIF(I+5.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+5)).EQ.'∂')THEN STROUT(NOUT+1:NOUT+6)='"\\144#' INEXT=I+6 NOUT=NOUT+6 ELSEIF(I+5.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+7)).EQ.'≈')THEN STROUT(NOUT+1:NOUT+6)='"\\145#' INEXT=I+8 NOUT=NOUT+6 ELSEIF(I+5.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+6)).EQ.'≈')THEN STROUT(NOUT+1:NOUT+6)='"\\145#' INEXT=I+7 NOUT=NOUT+6 ELSEIF(I+3.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+3)).EQ.'_sum')THEN STROUT(NOUT+1:NOUT+3)='[S]' INEXT=I+4 NOUT=NOUT+3 ELSEIF(I+6.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+6)).EQ.'×')THEN STROUT(NOUT+1:NOUT+6)='"\\264#' INEXT=I+7 NOUT=NOUT+6 ELSEIF(I+5.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+5)).EQ.'↑')THEN STROUT(NOUT+1:NOUT+6)='"\\255#' INEXT=I+6 NOUT=NOUT+6 * Punctuation and accents. ELSEIF(I+5.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+5)).EQ.'!')THEN STROUT(NOUT+1:NOUT+4)='\\041' INEXT=I+6 NOUT=NOUT+4 ELSEIF(I+5.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+5)).EQ.''')THEN STROUT(NOUT+1:NOUT+4)='\\047' INEXT=I+6 NOUT=NOUT+4 ELSEIF(I+6.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+6)).EQ.'`')THEN STROUT(NOUT+1:NOUT+4)='\\301' INEXT=I+7 NOUT=NOUT+4 ELSEIF(I+6.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+6)).EQ.'´')THEN STROUT(NOUT+1:NOUT+4)='\\302' INEXT=I+7 NOUT=NOUT+4 * Particle names. ELSEIF(I+8.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+8)).EQ.'electron-')THEN STROUT(NOUT+1:NOUT+4)='e^-!' INEXT=I+9 NOUT=NOUT+4 ELSEIF(I+8.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+8)).EQ.'electron+')THEN STROUT(NOUT+1:NOUT+4)='e^+!' INEXT=I+9 NOUT=NOUT+4 ELSEIF(I+2.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+2)).EQ.'mu-')THEN STROUT(NOUT+1:NOUT+6)='[m]^-!' INEXT=I+3 NOUT=NOUT+6 ELSEIF(I+2.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+2)).EQ.'mu+')THEN STROUT(NOUT+1:NOUT+6)='[m]^+!' INEXT=I+3 NOUT=NOUT+6 ELSEIF(I+3.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+3)).EQ.'tau-')THEN STROUT(NOUT+1:NOUT+6)='[t]^-!' INEXT=I+4 NOUT=NOUT+6 ELSEIF(I+3.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+3)).EQ.'tau+')THEN STROUT(NOUT+1:NOUT+6)='[t]^+!' INEXT=I+4 NOUT=NOUT+6 ELSEIF(I+2.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+2)).EQ.'pi-')THEN STROUT(NOUT+1:NOUT+6)='[p]^-!' INEXT=I+3 NOUT=NOUT+6 ELSEIF(I+2.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+2)).EQ.'pi0')THEN STROUT(NOUT+1:NOUT+6)='[p]^0!' INEXT=I+3 NOUT=NOUT+6 ELSEIF(I+2.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+2)).EQ.'pi+')THEN STROUT(NOUT+1:NOUT+6)='[p]^+!' INEXT=I+3 NOUT=NOUT+6 ELSEIF(I+5.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+5)).EQ.'photon')THEN STROUT(NOUT+1:NOUT+3)='[g]' INEXT=I+7 NOUT=NOUT+3 * Names of chemical compounds. ELSEIF(I+3.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+3)).EQ.'He-3')THEN STROUT(NOUT+1:NOUT+5)='^3!He' INEXT=I+4 NOUT=NOUT+5 ELSEIF(I+3.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+3)).EQ.'He-4')THEN STROUT(NOUT+1:NOUT+5)='^4!He' INEXT=I+4 NOUT=NOUT+5 ELSEIF(I+2.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+2)).EQ.'CO2')THEN STROUT(NOUT+1:NOUT+5)='CO?2!' INEXT=I+3 NOUT=NOUT+5 ELSEIF(I+2.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+2)).EQ.'CS2')THEN STROUT(NOUT+1:NOUT+5)='CS?2!' INEXT=I+3 NOUT=NOUT+5 ELSEIF(I+2.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+2)).EQ.'CH4')THEN STROUT(NOUT+1:NOUT+5)='CH?4!' INEXT=I+3 NOUT=NOUT+5 ELSEIF(I+2.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+2)).EQ.'CD4')THEN STROUT(NOUT+1:NOUT+5)='CD?4!' INEXT=I+3 NOUT=NOUT+5 ELSEIF(I+4.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+4)).EQ.'CH3OH')THEN STROUT(NOUT+1:NOUT+7)='CH?3!OH' INEXT=I+5 NOUT=NOUT+7 ELSEIF(I+2.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+2)).EQ.'CF4')THEN STROUT(NOUT+1:NOUT+5)='CF?4!' INEXT=I+3 NOUT=NOUT+5 ELSEIF(I+4.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+4)).EQ.'CF3Br')THEN STROUT(NOUT+1:NOUT+7)='CF?3!Br' INEXT=I+5 NOUT=NOUT+7 ELSEIF(I+3.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+3)).EQ.'CHF3')THEN STROUT(NOUT+1:NOUT+6)='CHF?3!' INEXT=I+4 NOUT=NOUT+6 ELSEIF(I+2.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+2)).EQ.'BF3')THEN STROUT(NOUT+1:NOUT+5)='BF?3!' INEXT=I+3 NOUT=NOUT+5 ELSEIF(I+2.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+2)).EQ.'SF6')THEN STROUT(NOUT+1:NOUT+5)='SF?6!' INEXT=I+3 NOUT=NOUT+5 ELSEIF(I+2.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+2)).EQ.'H2O')THEN STROUT(NOUT+1:NOUT+5)='H?2!O' INEXT=I+3 NOUT=NOUT+5 ELSEIF(I+2.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+2)).EQ.'N2O')THEN STROUT(NOUT+1:NOUT+5)='N?2!O' INEXT=I+3 NOUT=NOUT+5 ELSEIF(I+3.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+3)).EQ.'C2H6')THEN STROUT(NOUT+1:NOUT+8)='C?2!H?6!' INEXT=I+4 NOUT=NOUT+8 ELSEIF(I+3.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+3)).EQ.'C2F6')THEN STROUT(NOUT+1:NOUT+8)='C?2!F?6!' INEXT=I+4 NOUT=NOUT+8 ELSEIF(I+5.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+5)).EQ.'C2F4H2')THEN STROUT(NOUT+1:NOUT+12)='C?2!F?4!H?2!' INEXT=I+6 NOUT=NOUT+12 ELSEIF(I+5.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+5)).EQ.'C2H2F4')THEN STROUT(NOUT+1:NOUT+12)='C?2!H?2!F?4!' INEXT=I+6 NOUT=NOUT+12 ELSEIF(I+4.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+4)).EQ.'C2F5H')THEN STROUT(NOUT+1:NOUT+9)='C?2!F?5!H' INEXT=I+5 NOUT=NOUT+9 ELSEIF(I+4.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+4)).EQ.'C2HF5')THEN STROUT(NOUT+1:NOUT+9)='C?2!HF?5!' INEXT=I+5 NOUT=NOUT+9 ELSEIF(I+5.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+5)).EQ.'C2H5OH')THEN STROUT(NOUT+1:NOUT+10)='C?2!H?5!OH' INEXT=I+6 NOUT=NOUT+10 ELSEIF(I+3.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+3)).EQ.'C2H4')THEN STROUT(NOUT+1:NOUT+8)='C?2!H?4!' INEXT=I+4 NOUT=NOUT+8 ELSEIF(I+3.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+3)).EQ.'C2H2')THEN STROUT(NOUT+1:NOUT+8)='C?2!H?2!' INEXT=I+4 NOUT=NOUT+8 ELSEIF(I+3.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+3)).EQ.'C3H8')THEN STROUT(NOUT+1:NOUT+8)='C?3!H?8!' INEXT=I+4 NOUT=NOUT+8 ELSEIF(I+5.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+5)).EQ.'C3H7OH')THEN STROUT(NOUT+1:NOUT+10)='C?3!H?7!OH' INEXT=I+6 NOUT=NOUT+10 ELSEIF(I+4.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+4)).EQ.'C4H10')THEN STROUT(NOUT+1:NOUT+9)='C?4!H?10!' INEXT=I+5 NOUT=NOUT+9 ELSEIF(I+4.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+4)).EQ.'C5H12')THEN STROUT(NOUT+1:NOUT+9)='C?5!H?12!' INEXT=I+5 NOUT=NOUT+9 ELSEIF(I+1.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+1)).EQ.'O2')THEN STROUT(NOUT+1:NOUT+4)='O?2!' INEXT=I+2 NOUT=NOUT+4 * Units which need special formatting. ELSEIF(UNIT.AND.I+2.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+2)).EQ.'cm2')THEN STROUT(NOUT+1:NOUT+5)='cm^2!' INEXT=I+3 NOUT=NOUT+5 ELSEIF(UNIT.AND.I+2.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+2)).EQ.'cm3')THEN STROUT(NOUT+1:NOUT+5)='cm^3!' INEXT=I+3 NOUT=NOUT+5 ELSEIF(UNIT.AND.I+7.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+7)).EQ.'microsec')THEN STROUT(NOUT+1:NOUT+6)='[m]sec' INEXT=I+8 NOUT=NOUT+6 ELSEIF(UNIT.AND.I+5.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+5)).EQ.'micron')THEN STROUT(NOUT+1:NOUT+4)='[m]m' INEXT=I+6 NOUT=NOUT+4 ELSEIF(UNIT.AND.I+7.LE.LEN(STRING).AND. - STRING(I:MIN(LEN(STRING),I+7)).EQ.'microamp')THEN STROUT(NOUT+1:NOUT+4)='[m]A' INEXT=I+8 NOUT=NOUT+4 * Now also replace underscores and ampersands that remain. ELSEIF(STRING(I:I).EQ.'_')THEN STROUT(NOUT+1:NOUT+3)='[-]' NOUT=NOUT+3 ELSEIF(STRING(I:I).EQ.'&')THEN STROUT(NOUT+1:NOUT+3)='"W#' NOUT=NOUT+3 * Copy all other characters as such. ELSE STROUT(NOUT+1:NOUT+1)=STRING(I:I) NOUT=NOUT+1 ENDIF 10 CONTINUE ENDIF *** Now plot the converted string. 20 CONTINUE * Debugging output. IF(LDEBUG)WRITE(LUNOUT,'(26X,''Out: "'',A,''"''/26X, - ''Plot location: '',2E10.3)') STROUT(1:NOUT),X,Y * Plot the string. CALL ITX(X,Y,STROUT(1:NOUT)) END +DECK,GPL2. SUBROUTINE GPL2(N,XPL2,YPL2) *----------------------------------------------------------------------- * GPL2 - Routine plotting an array of double precision points. * (Last changed on 28/ 5/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. DOUBLE PRECISION XPL2(*),YPL2(*) REAL XPL(MXLIST),YPL(MXLIST) INTEGER N,II,I,NPL *** Loop over blocks of length MXLIST. DO 20 II=0,N-2,MXLIST-1 *** Transfer XPL2 and YPL2 (double) to XPL and YPL (single precision). DO 10 I=1,MIN(N-II,MXLIST) XPL(I)=REAL(XPL2(II+I)) YPL(I)=REAL(YPL2(II+I)) 10 CONTINUE NPL=MIN(N-II,MXLIST) *** Plot the line. IF(NPL.GE.2)CALL GPL(NPL,XPL,YPL) 20 CONTINUE END +DECK,GRCBIS. SUBROUTINE GRCBIS(F,FC,X0,Y0,XL,YL,FL,IL,XR,YR,FR,IR,IFAIL) *----------------------------------------------------------------------- * GRCBIS - Computes a starting point (X0,Y0) for a contour at function * value FC using bisection between (XL,YL) and (XR,YR). * (Last changed on 18/ 6/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CONTDATA. +SEQ,PRINTPLOT. REAL FC,X0,Y0,F0,X1,Y1,F1,X2,Y2,F2,X3,Y3,F3,XL,YL,FL,XR,YR,FR, - SCALE,SCALE1,SCALE2,DISC,FTEST1,FTEST2,P1,P2,P3 INTEGER IFAIL,IL,IR,I1,I2,I3,ILOC0,ILOCT1,ILOCT2,IBITER EXTERNAL F *** Assume the procedure converges. IFAIL=0 IF(LDEBUG)WRITE(10,'(1X,A,3E15.8,I3/25X,A,3E15.8,I3,A,E15.8)') - ' ++++++ GRCBIS DEBUG : Bisection between ', - XL,YL,FL,IL,' and ',XR,YR,FR,IR,' for F=',FC *** Make sure that not both points have special ILOCs. IF(IL.NE.0.AND.IR.NE.0)THEN WRITE(10,'('' !!!!!! GRCBIS WARNING : Bisection called'', - '' between 2 ILOC#0 points, ILOC='',2I5)') IL,IR IFAIL=1 RETURN ENDIF *** Set up the bisection and search cycles. X1=XL Y1=YL F1=FL I1=IL X3=XR Y3=YR F3=FR I3=IR *** In case either of the end points has ILOC/=0, fix range. IF(I1.NE.0.AND.I3.EQ.0)THEN DO 20 IBITER=1,NBITER X2=(X1+X3)/2 Y2=(Y1+Y3)/2 CALL F(X2,Y2,F2,I2) NFC=NFC+1 IF(I2.EQ.0)THEN X3=X2 Y3=Y2 F3=F2 I3=I2 ELSE X1=X2 Y1=Y2 F1=F2 I1=I2 ENDIF IF((ABS(X3-X1)+ABS(Y3-Y1)).LT. - 1E-5*(ABS(X1+X3)+ABS(Y1+Y3)))GOTO 30 20 CONTINUE 30 CONTINUE X1=X3 Y1=Y3 F1=F3 I1=I3 X3=XR Y3=YR F3=FR I3=IR ELSEIF(I1.EQ.0.AND.I3.NE.0)THEN DO 40 IBITER=1,NBITER X2=(X1+X3)/2 Y2=(Y1+Y3)/2 CALL F(X2,Y2,F2,I2) NFC=NFC+1 IF(I2.EQ.0)THEN X1=X2 Y1=Y2 F1=F2 I1=I2 ELSE X3=X2 Y3=Y2 F3=F2 I3=I2 ENDIF IF((ABS(X3-X1)+ABS(Y3-Y1)).LT. - 1E-5*(ABS(X1+X3)+ABS(Y1+Y3)))GOTO 50 40 CONTINUE 50 CONTINUE X1=XL Y1=YL F1=FL I1=IL X3=X1 Y3=Y1 F3=F1 I3=I1 ENDIF *** Iterate the bisection steps. DO 10 IBITER=1,NBITER IF(LDEBUG)WRITE(10,'(1X,A,I2)') ' ++++++ GRCBIS DEBUG :'// - ' Bisection cycle ',IBITER ** Add one point in the middle, to be used for a parabolic fit. X2=(X1+X3)/2 Y2=(Y1+Y3)/2 CALL F(X2,Y2,F2,I2) NFC=NFC+1 IF(LDEBUG)WRITE(10,'(26X,''Middle point: '',2E15.8, - '', F='',E15.8,'', ILOC='',I5)') X2,Y2,F2,I2 SCALE=-1 ** First attempt to find the parabolic crossing point ... P1=2*(F1-2*F2+F3) P2=-3*F1+4*F2-F3 P3=F1-FC DISC=P2**2-4*P1*P3 * Immediate failure for zero discriminant and degenerate parabola's. IF(DISC.GE.0.AND.P1.NE.0)THEN SCALE1=(-P2+SQRT(DISC))/(2*P1) SCALE2=(-P2-SQRT(DISC))/(2*P1) IF(LDEBUG)WRITE(10,'(1X,A,2E15.8)') ' ++++++ GRCBIS'// - ' DEBUG : Parabolic scales: ',SCALE1,SCALE2 * Only the first point is within range. IF(SCALE1.GE.0.AND.SCALE1.LE.1.AND. - (SCALE2.LT.0.OR.SCALE2.GT.1))THEN SCALE=SCALE1 CALL F(X1+SCALE*(X3-X1),Y1+SCALE*(Y3-Y1),F0,ILOC0) NFC=NFC+1 IF(ILOC0.NE.0)THEN IFAIL=1 RETURN ENDIF IF(LDEBUG)WRITE(10,'(26X,A)') 'Only first satisfies.' * Only the second point is within range. ELSEIF(SCALE2.GE.0.0.AND.SCALE2.LE.1.0.AND. - (SCALE1.LT.0.0.OR.SCALE1.GT.1.0))THEN SCALE=SCALE2 CALL F(X1+SCALE*(X3-X1),Y1+SCALE*(Y3-Y1),F0,ILOC0) NFC=NFC+1 IF(ILOC0.NE.0)THEN IFAIL=1 RETURN ENDIF IF(LDEBUG)WRITE(10,'(26X,A)') 'Only second satisfies.' * Both are in range, select the one with the best function value. ELSEIF(SCALE1.GE.0.0.AND.SCALE1.LE.1.0.AND. - SCALE2.GE.0.0.AND.SCALE2.LE.1.0)THEN CALL F(X1+SCALE1*(X3-X1),Y1+SCALE1*(Y3-Y1), - FTEST1,ILOCT1) CALL F(X1+SCALE2*(X3-X1),Y1+SCALE2*(Y3-Y1), - FTEST2,ILOCT2) NFC=NFC+2 IF(ILOCT1.NE.0.OR.ILOCT2.NE.0)THEN IFAIL=1 RETURN ENDIF IF(ABS(FTEST1-FC).LT.ABS(FTEST2-FC))THEN SCALE=SCALE1 F0=FTEST1 IF(LDEBUG)WRITE(10,'(26X,A,E15.8)') 'First'// - ' scale gives closest function value: ',F0 ELSE SCALE=SCALE2 F0=FTEST2 IF(LDEBUG)WRITE(10,'(26X,A,E15.8)') 'Second'// - ' scale gives closest function value: ',F0 ENDIF ELSE SCALE=-1.0 IF(LDEBUG)WRITE(10,'(26X,A)') 'Neither satisfies.' ENDIF ENDIF ** Attempt a linear procedure if the parabolic method failed. IF((F1.NE.F3).AND.(SCALE.LT.0.0.OR.SCALE.GT.1.0))THEN SCALE=(FC-F1)/(F3-F1) CALL F(X1+(X3-X1)*SCALE,Y1+(Y3-Y1)*SCALE,F0,ILOC0) NFC=NFC+1 IF(ILOC0.NE.0)THEN IFAIL=1 RETURN ENDIF IF(LDEBUG)WRITE(10,'(1X,2(A,E15.8))') ' +++++++ GRCBIS'// - ' DEBUG : Linear scale = ',SCALE,' F=',F0 ENDIF ** Now try to insert the new point if it's there at the good place. IF(SCALE.GE.0.0.AND.SCALE.LE.1.0)THEN X0=X1+SCALE*(X3-X1) Y0=Y1+SCALE*(Y3-Y1) * Presumed crossing between point 1 and the 'optimum'. IF((F1-FC)*(FC-F0).GE.0.AND.SCALE.LE.0.5)THEN X3=X0 Y3=Y0 F3=F0 C IF(LDEBUG)WRITE(10,'(26X,A)') 'New edges: 1, opt.' * Presumed crossing between point 'optimum' and point 2. ELSEIF((F0-FC)*(FC-F2).GE.0.AND.SCALE.LE.0.5)THEN X1=X0 Y1=Y0 F1=F0 X3=X2 Y3=Y2 F3=F2 IF(LDEBUG)WRITE(10,'(26X,A)') 'New edges: opt, 2.' * Presumed crossing between point 2 and the 'optimum'. ELSEIF((F2-FC)*(FC-F0).GE.0.AND.SCALE.GT.0.5)THEN X1=X2 Y1=Y2 F1=F2 X3=X0 Y3=Y0 F3=F0 * Presumed crossing between point 'optimum' and point 3. ELSEIF((F0-FC)*(FC-F3).GE.0.AND.SCALE.GT.0.5)THEN X1=X0 Y1=Y0 F1=F0 * Elsewhere: failure, fall back on pure bisection. ELSE IF(LDEBUG)THEN WRITE(10,'(1X,A)') ' ++++++ GRCBIS DEBUG :'// - ' Pure bisection fallback forced'// - ' because of an unexpected case:' WRITE(10,'(25X,A,3E15.8)') ' point 1: ',X1,Y1,F1 WRITE(10,'(25X,A,3E15.8)') ' point 2: ',X2,Y2,F2 WRITE(10,'(25X,A,3E15.8)') ' point 3: ',X3,Y3,F3 WRITE(10,'(25X,A,E15.8,A,E15.8)') ' parabola:'// - ' SCALE=',SCALE,' F=',F0 ENDIF SCALE=-1.0 ENDIF ENDIF ** Pure bisection. IF(SCALE.LT.0.0.OR.SCALE.GT.1.0)THEN * Set the new edges. IF((F1-FC)*(FC-F2).GT.0)THEN X3=X2 Y3=Y2 F3=F2 ELSE X1=X2 Y1=Y2 F1=F2 ENDIF * Compute F0 as the value halfway the interval. X0=0.5*(X1+X3) Y0=0.5*(Y1+Y3) CALL F(X0,Y0,F0,ILOC0) NFC=NFC+1 IF(ILOC0.NE.0)THEN IFAIL=1 RETURN ENDIF ENDIF ** Check for convergence. IF(ABS(F0-FC).LT.EPSTRA*(1+ABS(FC)))THEN IF(LDEBUG)WRITE(10,'(1X,A)') ' ++++++ GRCBIS DEBUG :'// - ' Convergence achieved between F0 and FC at:' IF(LDEBUG)WRITE(10,'(26X,A,3E15.8)') '(x,y,f) = ',X0,Y0,F0 RETURN ENDIF 10 CONTINUE *** This point is only reached if no convergence ia achieved. WRITE(10,'(1X,A)') ' !!!!!! GRCBIS WARNING : Bisection'// - ' didn''t converge.' IFAIL=1 END +DECK,GRCONT. SUBROUTINE GRCONT(F,FMIN,FMAX,QXMIN,QYMIN,QXMAX,QYMAX, - NF,AUTO,TRANSF,LABEL) *----------------------------------------------------------------------- * GRCONT - Routine plotting contours of the function F in the window * (XNIN,YMIN) to (XMAX,YMAX) using a grid of NGRIDX+1 by * NGRIDY+1 points. * VARIABLES : AUTO : If .TRUE. the scale will be determined * automatically. * (Last changed on 28/ 5/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CONTDATA. +SEQ,PARAMETERS. +SEQ,PRINTPLOT. REAL FMIN,FMAX,GRMIN,GRMAX,STEP,X0,Y0,QXMIN,QYMIN,QXMAX,QYMAX, - XPL,YPL,FC INTEGER NF,INIT,IX,IY,IF,IFAIL LOGICAL AUTO,LOOP,TRANSF,LABEL EXTERNAL F *** Check the dimensions. IF(NGRIDX.LE.0.OR.NGRIDX.GT.MXGRID.OR. - NGRIDY.LE.0.OR.NGRIDY.GT.MXGRID)THEN WRITE(10,'(1X,A)') ' !!!!!! GRCONT WARNING : Grid'// - ' dimensions out of range ; contours not plotted.' RETURN ENDIF IF(NF.LT.1)THEN WRITE(10,'(1X,A)') ' !!!!!! GRCONT WARNING : Number of'// - ' contours is smaller than 1 ; no contours plotted.' RETURN ENDIF *** Copy the area etc to the local variables. CXMIN=QXMIN CXMAX=QXMAX CYMIN=QYMIN CYMAX=QYMAX TRANS=TRANSF CLAB =LABEL *** Set gradient step size. DXGRA=EPSGRA*ABS(CXMAX-CXMIN) DYGRA=EPSGRA*ABS(CYMAX-CYMIN) IF(DXGRA.LE.0.OR.DYGRA.LE.0)THEN WRITE(LUNOUT,'('' !!!!!! GRCONT WARNING : Gradient step'', - '' size is 0 ; check AREA and !CONTOUR-PARAMETERS.'')') RETURN ENDIF *** Fill the grid. INIT=0 DO 10 IX=0,NGRIDX DO 20 IY=0,NGRIDY CALL F(CXMIN+REAL(IX)*(CXMAX-CXMIN)/REAL(NGRIDX), - CYMIN+REAL(IY)*(CYMAX-CYMIN)/REAL(NGRIDY), - GRID(IX,IY),ILOCGR(IX,IY)) IF(INIT.EQ.0)THEN GRMAX=GRID(IX,IY) GRMIN=GRID(IX,IY) INIT=1 ELSE IF(GRMIN.GT.GRID(IX,IY))GRMIN=GRID(IX,IY) IF(GRMAX.LT.GRID(IX,IY))GRMAX=GRID(IX,IY) ENDIF 20 CONTINUE 10 CONTINUE NFC=(NGRIDX+1)*(NGRIDY+1) * Verify that a grid range has been set. IF(INIT.EQ.0)THEN WRITE(10,'('' !!!!!! GRCONT WARNING : No range found,'', - '' no contours plotted.'')') RETURN * Check the range makes sense if fixed. ELSEIF((.NOT.AUTO).AND. - (MAX(FMIN,FMAX).LT.MIN(GRMIN,GRMAX).OR. - MIN(FMIN,FMAX).GT.MAX(GRMIN,GRMAX)))THEN WRITE(10,'('' !!!!!! GRCONT WARNING : Specified range ('', - 2E12.5,'') does not overlap''/26X, - ''with effective range ('',2E12.5,'').''/ - 26X,''No contours will be drawn.'')') - FMIN,FMAX,GRMIN,GRMAX RETURN * Optionally fix the scale. ELSEIF(AUTO)THEN FMIN=GRMIN FMAX=GRMAX IF(GRMIN.EQ.GRMAX)THEN STEP=0.0 NF=0 ELSE CALL ROUND(FMIN,FMAX,NF,'SMALLER',STEP) NF=NINT((FMAX-FMIN)/STEP) ENDIF ELSEIF(NF.NE.0)THEN STEP=(FMAX-FMIN)/REAL(NF) ELSE WRITE(10,'('' !!!!!! GRCONT WARNING : Unable to find'', - '' a contour range ; no contours drawn.'')') RETURN ENDIF IF(LDEBUG)WRITE(10,'(1X,A,2E15.8/26X,A,2E15.8/26X,A,I3/ - 26X,A,E15.8)') - ' ++++++ GRCONT DEBUG : Grid function range: ', - GRMIN,GRMAX,'Contour height range: ',FMIN,FMAX, - 'Number of contours: ',NF, - 'Step size : ',STEP *** Set the attributes for contours. CALL GRATTS('CONTOUR-NORMAL','POLYLINE') *** Loop over the contour heights. DO 100 IF=0,NF FC=FMIN+REAL(IF)*STEP IF(FC.GT.FMAX)GOTO 100 IF(LDEBUG)WRITE(10,'(1X,A,E15.8)') ' ++++++ GRCONT DEBUG :'// - ' Contour height = ',FC *** Clear the buffers that remember whether a contour was done. DO 110 IX=0,NGRIDX DO 120 IY=0,NGRIDY XDONE(IX,IY)=.FALSE. YDONE(IX,IY)=.FALSE. 120 CONTINUE 110 CONTINUE *** Check point by point whether there is a contour crossing. DO 130 IX=0,NGRIDX DO 140 IY=0,NGRIDY ** Avoid addressing problems. IF(IX.GE.NGRIDX)GOTO 150 ** Check in x. IF((.NOT.XDONE(IX,IY)).AND. - (ILOCGR(IX,IY).EQ.0.OR.ILOCGR(IX+1,IY).EQ.0).AND. - (GRID(IX,IY)-FC)*(GRID(IX+1,IY)-FC).LT.0)THEN IF(LDEBUG)THEN CALL GSMK(4) XPL=CXMIN+REAL(IX)*(CXMAX-CXMIN)/REAL(NGRIDX) YPL=CYMIN+REAL(IY)*(CYMAX-CYMIN)/REAL(NGRIDY) IF(TRANS)CALL CFMRTC(XPL,YPL,XPL,YPL,1) CALL GPM(1,XPL,YPL) WRITE(10,'(1X,A,2E15.8)') ' ++++++ GRCONT DEBUG :'// - ' Start from an x-segment at ',XPL,YPL ENDIF CALL GRCBIS(F,FC,X0,Y0, - CXMIN+REAL(IX) *(CXMAX-CXMIN)/REAL(NGRIDX), - CYMIN+REAL(IY) *(CYMAX-CYMIN)/REAL(NGRIDY), - GRID(IX,IY),ILOCGR(IX,IY), - CXMIN+REAL(IX+1)*(CXMAX-CXMIN)/REAL(NGRIDX), - CYMIN+REAL(IY) *(CYMAX-CYMIN)/REAL(NGRIDY), - GRID(IX+1,IY),ILOCGR(IX+1,IY), - IFAIL) IF(IFAIL.EQ.0)THEN XDONE(IX,IY)=.TRUE. CALL GRCTRA(F,FC,X0,Y0,-1.0,LOOP) IF(.NOT.LOOP)CALL GRCTRA(F,FC,X0,Y0,+1.0,LOOP) ENDIF ENDIF ** Avoid addressing problems. 150 CONTINUE IF(IY.GE.NGRIDY)GOTO 140 ** And similarly in y. IF((.NOT.YDONE(IX,IY)).AND. - (ILOCGR(IX,IY).EQ.0.OR.ILOCGR(IX,IY+1).EQ.0).AND. - (GRID(IX,IY)-FC)*(GRID(IX,IY+1)-FC).LT.0)THEN IF(LDEBUG)THEN CALL GSMK(5) XPL=CXMIN+REAL(IX)*(CXMAX-CXMIN)/REAL(NGRIDX) YPL=CYMIN+REAL(IY)*(CYMAX-CYMIN)/REAL(NGRIDY) IF(TRANS)CALL CFMRTC(XPL,YPL,XPL,YPL,1) CALL GPM(1,XPL,YPL) WRITE(10,'(1X,A,2E15.8)') ' ++++++ GRCONT DEBUG :'// - ' Start from a y-segment at ',XPL,YPL ENDIF CALL GRCBIS(F,FC,X0,Y0, - CXMIN+REAL(IX) *(CXMAX-CXMIN)/REAL(NGRIDX), - CYMIN+REAL(IY) *(CYMAX-CYMIN)/REAL(NGRIDY), - GRID(IX,IY),ILOCGR(IX,IY), - CXMIN+REAL(IX) *(CXMAX-CXMIN)/REAL(NGRIDX), - CYMIN+REAL(IY+1)*(CYMAX-CYMIN)/REAL(NGRIDY), - GRID(IX,IY+1),ILOCGR(IX,IY+1), - IFAIL) IF(IFAIL.EQ.0)THEN YDONE(IX,IY)=.TRUE. CALL GRCTRA(F,FC,X0,Y0,-1.0,LOOP) IF(.NOT.LOOP)CALL GRCTRA(F,FC,X0,Y0,+1.0,LOOP) ENDIF ENDIF 140 CONTINUE 130 CONTINUE *** Next contour height. 100 CONTINUE END +DECK,GRCGRA. SUBROUTINE GRCGRA(F,XX,YY,DFDX,DFDY,IOPT1,IOPT2,IFLAG) *----------------------------------------------------------------------- * GRCGRA - Calculates the (normalised) gradient of F at (XX,YY). * VARIABLES : IOPT1 : If 0, the normal gradient is returned, * if 1, the orthognal gradient. * IOPT2 : If 0, no normalisation, if 1 normalisation * on one grid length along the gradient. * (Last changed on 22/ 6/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CONTDATA. +SEQ,PARAMETERS. REAL XX,YY,DFDX,DFDY,AUX,DFNORM,FXP,FXM,FYP,FYM,FM INTEGER IOPT1,IOPT2,ILOCXM,ILOCXP,ILOCYP,ILOCYM,ILOCM,IFLAG EXTERNAL F *** Preset flag to 0: free point, change to 1 if needed. IFLAG=0 *** Function evaluation for the symmetric gradient. CALL F(XX+DXGRA,YY,FXP,ILOCXP) CALL F(XX-DXGRA,YY,FXM,ILOCXM) CALL F(XX,YY+DYGRA,FYP,ILOCYP) CALL F(XX,YY-DYGRA,FYM,ILOCYM) NFC=NFC+4 * If one or more points are special, try asymmetric gradients. IF((ILOCXP.EQ.0.AND.ILOCXM.NE.0).OR. - (ILOCXP.NE.0.AND.ILOCXM.EQ.0).OR. - (ILOCYP.EQ.0.AND.ILOCYM.NE.0).OR. - (ILOCYP.NE.0.AND.ILOCYM.EQ.0))THEN CALL F(XX,YY,FM,ILOCM) NFC=NFC+1 ELSE FM=0 ILOCM=-1 ENDIF *** Compute the symmetric x-gradient if this is possible. IF(ILOCXP.EQ.0.AND.ILOCXM.EQ.0)THEN DFDX=(FXP-FXM)/(2*DXGRA) * Abandon if there is no hope. ELSEIF(ILOCM.NE.0)THEN DFDX=0 IFLAG=1 * Take the +assymetric gradient. ELSEIF(ILOCXP.EQ.0)THEN DFDX=(FXP-FM)/DXGRA * Take the -assymetric gradient. ELSEIF(ILOCXM.EQ.0)THEN DFDX=(FM-FXM)/DXGRA ELSE WRITE(10,'('' !!!!!! GRCGRA WARNING : Unexpected case'', - '' computing an x-gradient.'')') IFLAG=1 ENDIF *** Compute the symmetric y-gradient if this is possible. IF(ILOCYP.EQ.0.AND.ILOCYM.EQ.0)THEN DFDY=(FYP-FYM)/(2*DYGRA) * Abandon if there is no hope. ELSEIF(ILOCM.NE.0)THEN DFDY=0 IFLAG=1 * Take the +assymetric gradient. ELSEIF(ILOCYP.EQ.0)THEN DFDY=(FYP-FM)/DYGRA * Take the -assymetric gradient. ELSEIF(ILOCYM.EQ.0)THEN DFDY=(FM-FYM)/DYGRA ELSE WRITE(10,'('' !!!!!! GRCGRA WARNING : Unexpected case'', - '' computing a y-gradient.'')') IFLAG=1 ENDIF *** Check the flag. IF(IFLAG.NE.0)THEN DFDX=0 DFDY=0 RETURN ENDIF *** Check for a zero gradient for other reasons. IF(DFDX**2+DFDY**2.EQ.0)RETURN *** Reverse the gradient in case of IOPT1=1. IF(IOPT1.EQ.1)THEN AUX=DFDX DFDX=-DFDY DFDY=AUX ENDIF *** Normalise the gradient to one grid unit if IOPT2=1. IF(IOPT2.EQ.1)THEN DFNORM=SQRT(((DFDX*REAL(NGRIDX))/(CXMAX-CXMIN))**2+ - ((DFDY*REAL(NGRIDY))/(CYMAX-CYMIN))**2) DFDX=DFDX/DFNORM DFDY=DFDY/DFNORM ENDIF END +DECK,GRCLAB. SUBROUTINE GRCLAB(NPL,XPL,YPL,FC) *----------------------------------------------------------------------- * GRCLAB - Plots the contour and adds labels if requested. * (Last changed on 16/ 5/97.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CONTDATA. REAL XPL(*),YPL(*),WINDOW(4),VIEWPT(4),XBOX(5),YBOX(5),FC, - TXTLEN,CHH,CPX,CPY INTEGER NPL,IWK,NTOLD,ITXALH,ITXALV,IERR,IERR1,IERR2,I,NC, - IMID,ITXT CHARACTER*20 TEXT *** Skip label plotting if not requested. IF(.NOT.CLAB)THEN CALL GPL(NPL,XPL,YPL) RETURN ENDIF *** Label plotting, set workstation to 1 (only one workstation). IWK=1 NTOLD=-1 ITXALH=-1 ITXALV=-1 * Transform the curve to NT=0. CALL GQCNTN(IERR1,NTOLD) CALL GQNT(NTOLD,IERR2,WINDOW,VIEWPT) IF(IERR1.NE.0.OR.IERR2.NE.0.OR.WINDOW(1).EQ.WINDOW(2).OR. - WINDOW(3).EQ.WINDOW(4))THEN WRITE(10,'('' !!!!!! GRCLAB WARNING : Window/viewport/nt'', - '' inquiry failed, IERR='',2I3)') IERR1,IERR2 GOTO 1000 ENDIF DO 10 I=1,NPL XPL(I)=(XPL(I)-WINDOW(1))/(WINDOW(2)-WINDOW(1)) YPL(I)=(YPL(I)-WINDOW(3))/(WINDOW(4)-WINDOW(3)) 10 CONTINUE CALL GSELNT(0) * Set the attributes of the contour labels. CALL GRATTS('CONTOUR-LABELS','TEXT') * Format the label. CALL OUTFMT(FC,2,TEXT,NC,'LEFT') * Compute horizontal length of the text. CALL GSCHUP(0.0,1.0) CALL GQTXAL(IERR,ITXALH,ITXALV) IF(IERR.NE.0)THEN WRITE(10,'('' !!!!!! GRCLAB WARNING : Text alignments'', - '' inquiry failed, IERR='',I3)') IERR GOTO 1000 ENDIF CALL GSTXAL(2,3) CALL GQTXX(IWK,0.5,0.5,TEXT(1:NC),IERR,CPX,CPY,XBOX,YBOX) IF(IERR.EQ.0)THEN TXTLEN=MAX(MAX(XBOX(1),XBOX(2),XBOX(3),XBOX(4))- - MIN(XBOX(1),XBOX(2),XBOX(3),XBOX(4)), - MAX(YBOX(1),YBOX(2),YBOX(3),YBOX(4))- - MIN(YBOX(1),YBOX(2),YBOX(3),YBOX(4))) ELSE CALL GQCHW(IERR,CHH) IF(IERR.NE.0)CALL GQCHH(IERR,CHH) IF(IERR.NE.0)CHH=0.01 TXTLEN=NC*CHH ENDIF * Make the space a bit bigger to make the label more legible. TXTLEN=TXTLEN*1.1 * Determine a piece of the curve that will hold the text. IMID=NPL/2 DO 20 I=1,IMID IF(IMID-I.LE.0.OR.IMID+I.GT.NPL)GOTO 20 IF((XPL(IMID-I)-XPL(IMID+I))**2+ - (YPL(IMID-I)-YPL(IMID+I))**2.GT.TXTLEN**2)THEN ITXT=I GOTO 30 ENDIF 20 CONTINUE GOTO 1000 * Plot the text. 30 CONTINUE IF(XPL(IMID+ITXT)-XPL(IMID-ITXT).LT.0.0.AND. - YPL(IMID-ITXT)-YPL(IMID+ITXT).LT.0.0)THEN CALL GSCHUP(YPL(IMID+ITXT)-YPL(IMID-ITXT), - XPL(IMID-ITXT)-XPL(IMID+ITXT)) ELSE CALL GSCHUP(YPL(IMID-ITXT)-YPL(IMID+ITXT), - XPL(IMID+ITXT)-XPL(IMID-ITXT)) ENDIF CALL GRTX((XPL(IMID-ITXT)+XPL(IMID+ITXT))/2.0, - (YPL(IMID-ITXT)+YPL(IMID+ITXT))/2.0,TEXT(1:NC)) * Plot the two line segments. IF(IMID-ITXT.GE.2)CALL GPL(IMID-ITXT,XPL,YPL) IF(NPL-IMID-ITXT+1.GE.2)CALL GPL(NPL-IMID-ITXT+1, - XPL(IMID+ITXT),YPL(IMID+ITXT)) * Restore the old situation. IF(NTOLD.GE.0)CALL GSELNT(NTOLD) IF(ITXALH.GE.0.AND.ITXALV.GE.0)CALL GSTXAL(ITXALH,ITXALV) CALL GSCHUP(0.0,1.0) RETURN *** Simple line drawing. 1000 CONTINUE CALL GPL(NPL,XPL,YPL) * Restore the old situation. IF(NTOLD.GE.0)CALL GSELNT(NTOLD) IF(ITXALH.GE.0.AND.ITXALV.GE.0)CALL GSTXAL(ITXALH,ITXALV) CALL GSCHUP(0.0,1.0) END +DECK,GRCMIN. SUBROUTINE GRCMIN(IX,IY,XX0,YY0,XX1,YY1,DIST,IFLAG) *----------------------------------------------------------------------- * GRCMIN - Minimizes the distance between a line segment and a point. * VARIABLES: (IX,IY) : Coordinates of the grid point. * (X0,Y0)-(X1,Y1): The line segment. * IFLAG : -1 minimum is located before (X0,Y0), * 0 " " " at an interior point, * +1 " " " behind (X1,Y1). * XINP0,XINP1 : Inner products. *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,PARAMETERS. +SEQ,CONTDATA. INTEGER IFLAG *** Calculate the normalised positions. XW=REAL(IX) YW=REAL(IY) X0=(XX0-CXMIN)*REAL(NGRIDX)/(CXMAX-CXMIN) Y0=(YY0-CYMIN)*REAL(NGRIDY)/(CYMAX-CYMIN) X1=(XX1-CXMIN)*REAL(NGRIDX)/(CXMAX-CXMIN) Y1=(YY1-CYMIN)*REAL(NGRIDY)/(CYMAX-CYMIN) *** Compute the step length and check it is non-zero. STEP2=(X1-X0)**2+(Y1-Y0)**2 *** Check these two are non-zero. IF(STEP2.LE.0.0)THEN IFLAG=0 DIST=SQRT((XW-X0)**2+(YW-Y0)**2) RETURN ENDIF *** Find the precise location of the smallest distance. XINP0=((X1-X0)*(XW-X0)+(Y1-Y0)*(YW-Y0)) XINP1=((X0-X1)*(XW-X1)+(Y0-Y1)*(YW-Y1)) IF(XINP0.LT.0.0D0)THEN IFLAG=-1 DIST2=(XW-X0)**2+(YW-Y0)**2 ELSEIF(XINP1.LT.0.0D0)THEN IFLAG=+1 DIST2=(XW-X1)**2+(YW-Y1)**2 ELSEIF(XINP1**2*((XW-X0)**2+(YW-Y0)**2).GT. - XINP0**2*((XW-X1)**2+(YW-Y1)**2))THEN IFLAG=0 DIST2=(XW-X0)**2+(YW-Y0)**2-XINP0**2/STEP2 ELSE IFLAG=0 DIST2=(XW-X1)**2+(YW-Y1)**2-XINP1**2/STEP2 ENDIF *** Take the square root of the distance. DIST=SQRT(MAX(0.0,DIST2)) END +DECK,GRCPLT. SUBROUTINE GRCPLT(XX,YY,FC,OPTION) *----------------------------------------------------------------------- * GRCPLT - Buffers and plot contours. * VARIABLES : OPTION : If 'INIT' resets the buffer and stores, * if 'ADD' adds the point to the buffer * plotting the buffer if its is full, * if 'PLOT' empties the buffer. * (XX,YY) : New point, ignored if OPTION='PLOT' * (Last changed on 18/10/93.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,PARAMETERS. +SEQ,CONTDATA. PARAMETER (MXCBUF=100) CHARACTER*(*) OPTION REAL XPL(MXCBUF),YPL(MXCBUF) +SELF,IF=SAVE. SAVE INIT,NPL,XPL,YPL +SELF. DATA INIT/0/,NPL/0/ *** Initialisation. IF(OPTION.EQ.'INIT')THEN NPL=1 XPL(NPL)=XX YPL(NPL)=YY INIT=1 *** Add a new point. ELSEIF(OPTION.EQ.'ADD')THEN * Check buffer state. IF(INIT.NE.1)THEN WRITE(10,'(1X,A)') ' !!!!!! GRCPLT WARNING : Buffer'// - ' not in the proper state ; program bug.' RETURN ENDIF * Check whether further points can be added, plot if not. IF(NPL.GE.MXCBUF)THEN IF(NPL.GE.2)THEN XTEMP=XPL(NPL) YTEMP=YPL(NPL) IF(TRANS)CALL CFMRTC(XPL,YPL,XPL,YPL,NPL) CALL GRCLAB(NPL,XPL,YPL,FC) XPL(NPL)=XTEMP YPL(NPL)=YTEMP ENDIF XPL(1)=XPL(NPL) YPL(1)=YPL(NPL) NPL=1 ENDIF * Add the point top the buffer. NPL=NPL+1 XPL(NPL)=XX YPL(NPL)=YY *** Plot the buffer if the option is 'PLOT'. ELSEIF(OPTION.EQ.'PLOT')THEN IF(NPL.GE.2)THEN IF(TRANS)CALL CFMRTC(XPL,YPL,XPL,YPL,NPL) CALL GRCLAB(NPL,XPL,YPL,FC) ENDIF INIT=0 *** Only 'DUMP', used in case of irrecoverable errors. ELSEIF(OPTION.EQ.'DUMP')THEN IF(NPL.GE.2)THEN IF(TRANS)CALL CFMRTC(XPL,YPL,XPL,YPL,NPL) CALL GRCLAB(NPL,XPL,YPL,FC) ENDIF INIT=0 *** Unknown option. ELSE WRITE(10,'(1X,A)') ' !!!!!! GRCPLT WARNING : Unknown'// - ' option "',OPTION,'" ; nothing done - program bug.' ENDIF END +DECK,GRCTRA. SUBROUTINE GRCTRA(F,FC,XST,YST,DIR,LOOP) *----------------------------------------------------------------------- * GRCTRA - Traces a contour of F at function value FC starting from * (XST,YST). The tracing method iterates in two stages (1) a * side step orthogonal to the gradient (2) a Newton-Raphson * stepping back to the contour. Conditions that can cause * termination include (1) leaving the plotting area (2) the * contour is back at its origin ... * VARIABLES : LOOP : Is set to .TRUE. if a full loop is found. * (Last changed on 14/ 3/08.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CONTDATA. +SEQ,PRINTPLOT. REAL FC,XST,YST,DIR,X0,Y0,X1,Y1,X2,Y2,F2,DFDX,DFDY,XSEG1,YSEG1, - XSEG2,YSEG2,XL,YL,H,DFNORM INTEGER IFLAG,IFLGST,ISTEP,IFLG0,IFLG2,INITER,ILOC2,IFAIL LOGICAL CROSS,LOOP EXTERNAL F,CROSS *** Initialise plotting of this contour fragment. CALL GRCPLT(XST,YST,FC,'INIT') CALL GRCUPD(F,XST,YST,FC,'START',IFLAG) LOOP=.FALSE. *** Store a small segment that will be used to catch circular contours. CALL GRCGRA(F,XST,YST,DFDX,DFDY,0,1,IFLGST) * Check initial position. IF(IFLGST.NE.0)THEN IF(LDEBUG)WRITE(10,'('' ++++++ GRCTRA DEBUG : Initial'', - '' point has non-zero gradient flag: '',I3)') IFLGST RETURN ENDIF * Gradient calculated successfully, store the segment. XSEG1=XST-DFDX*STINIT YSEG1=YST-DFDY*STINIT XSEG2=XST+DFDX*STINIT YSEG2=YST+DFDY*STINIT *** Initialise the previous step, used from step 2 onwards. XL=XST YL=YST *** Initialise stepping. H=STINIT X0=XST Y0=YST *** Start of the stepping procedure. ISTEP=0 100 CONTINUE ISTEP=ISTEP+1 *** Step to the side orthogonal to the gradient. CALL GRCGRA(F,X0,Y0,DFDX,DFDY,1,1,IFLG0) IF(IFLG0.NE.0)GOTO 3010 IF(DFDX**2+DFDY**2.LE.0)GOTO 3000 X1=X0+DIR*DFDX*H Y1=Y0+DIR*DFDY*H *** Newton-Raphson step back to the contour following the gradient. X2=X1 Y2=Y1 CALL F(X2,Y2,F2,ILOC2) NFC=NFC+1 DO 10 INITER=1,NNITER CALL GRCGRA(F,X2,Y2,DFDX,DFDY,0,0,IFLG2) DFNORM=DFDX**2+DFDY**2 IF(IFLG2.NE.0)GOTO 3010 IF(DFNORM.LE.0.0)GOTO 3000 X2=X2+DFDX*(FC-F2)/DFNORM Y2=Y2+DFDY*(FC-F2)/DFNORM CALL F(X2,Y2,F2,ILOC2) NFC=NFC+1 IF(LDEBUG)WRITE(10,'(1X,A,I3,A,I2,A,3E15.8)') - ' ++++++ GRCTRA DEBUG : Step ',ISTEP,' Newton iteration ', - INITER,' leads to (x,y,f) = ',X2,Y2,F2 IF(ABS(F2-FC).LE.EPSTRA*(1.0+ABS(FC)))THEN IF(LDEBUG)WRITE(10,'(1X,A,I2,A)') - ' ++++++ GRCTRA DEBUG : Newton search converged'// - ' at step ',INITER,'.' GOTO 20 ENDIF 10 CONTINUE WRITE(10,'(1X,A)') ' !!!!!! GRCTRA WARNING : Newton search'// - ' didn''t converge ; tracing terminated.' CALL GRCPLT(X2,Y2,FC,'PLOT') RETURN 20 CONTINUE *** Update the stepsize. *** Check whether we are leaving the box. IF(X2.LE.CXMIN.OR.X2.GE.CXMAX.OR.Y2.LE.CYMIN.OR.Y2.GE.CYMAX)THEN CALL CLIP(X0,Y0,X2,Y2,CXMIN,CYMIN,CXMAX,CYMAX,IFAIL) CALL GRCPLT(X2,Y2,FC,'ADD') CALL GRCPLT(X2,Y2,FC,'PLOT') IFLAG=0 IF(X2.LE.CXMIN)IFLAG=IFLAG+1 IF(X2.GE.CXMAX)IFLAG=IFLAG+2 IF(Y2.LE.CYMIN)IFLAG=IFLAG+4 IF(Y2.GE.CYMAX)IFLAG=IFLAG+8 CALL GRCUPD(F,X2,Y2,FC,'EDGE,END',IFLAG) IF(LDEBUG)WRITE(10,'(1X,A,I3,A,2E15.8)') - ' ++++++ GRCTRA DEBUG : Contour leaves area, step ', - ISTEP,' tracing ended at ',X2,Y2 RETURN ENDIF *** Check whether we have a full circle. IF(ISTEP.GT.1.AND.CROSS(X0,Y0,X2,Y2,XSEG1,YSEG1,XSEG2,YSEG2))THEN CALL GRCPLT(X2,Y2,FC,'ADD') CALL GRCPLT(X2,Y2,FC,'PLOT') CALL GRCUPD(F,X2,Y2,FC,'LOOP,END',IFLAG) IF(LDEBUG)WRITE(10,'(1X,A,I3,A,2E15.8)') - ' ++++++ GRCTRA DEBUG : Full loop detected at step ', - ISTEP,' tracing ended at ',X2,Y2 LOOP=.TRUE. RETURN ENDIF *** Make sure to avoid going back and forth, e.g. on a saddle point. IF(ISTEP.GT.1.AND.(X2-X0)*(X0-XL)+(Y2-Y0)*(Y0-YL).LT.0)THEN CALL GRCPLT(X2,Y2,FC,'DUMP') CALL GRCUPD(F,X2,Y2,FC,'TURN,END',IFLAG) IF(LDEBUG)WRITE(10,'(1X,A,I3,A,2E15.8)') - ' ++++++ GRCTRA DEBUG : Attempt to turn at step ', - ISTEP,' tracing ended at ',X2,Y2 RETURN ENDIF *** Check the number of steps. IF(ISTEP.GT.NGCMAX)THEN WRITE(10,'(1X,A)') ' !!!!!! GRCTRA WARNING : Maximum'// - ' number of steps reached, contour abandoned.' CALL GRCPLT(X2,Y2,FC,'ADD') CALL GRCPLT(X2,Y2,FC,'PLOT') CALL GRCUPD(F,X2,Y2,FC,'MAX,END',IFLAG) RETURN ENDIF *** Check we didn't miss a grid point. *** Add the point to the plotting buffer. XL=X0 YL=Y0 X0=X2 Y0=Y2 CALL GRCPLT(X0,Y0,FC,'ADD') CALL GRCUPD(F,X0,Y0,FC,'AREA',IFLAG) IF(IFLAG.NE.0)THEN IF(LDEBUG)WRITE(10,'(1X,A)') ' ++++++ GRCTRA DEBUG :'// - ' GRCUPD has raised IFLAG ; tracing abandoned.' RETURN ENDIF *** New step. GOTO 100 *** Errors. 3000 CONTINUE CALL GRCPLT(X2,Y2,FC,'DUMP') WRITE(10,'(1X,A,I3,A)') ' !!!!!! GRCTRA WARNING : Zero'// - ' gradient at step ',ISTEP,'; tracing terminated.' RETURN 3010 CONTINUE CALL GRCPLT(X2,Y2,FC,'DUMP') WRITE(10,'(1X,A,2E12.5,A,I3,A)') ' !!!!!! GRCTRA WARNING :'// - ' Stepped into forbidden zone, at ',X2,Y2,' (step ',ISTEP, - '); tracing terminated.' END +DECK,GRCUPD. SUBROUTINE GRCUPD(F,X1,Y1,FC,STATUS,IFLAG) *----------------------------------------------------------------------- * GRCUPD - Updates the grid for the contour segment (XPL,YPL). *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,CONTDATA. +SEQ,PARAMETERS. +SEQ,PRINTPLOT. LOGICAL CROSS CHARACTER*(*) STATUS EXTERNAL CROSS,F INTEGER INIT +SELF,IF=SAVE. SAVE INIT,X0,Y0 +SELF. DATA INIT/0/ *** Check and set of the initialisation flag, first the start. IF(INDEX(STATUS,'START').NE.0)THEN X0=X1 Y0=Y1 IFLAG=0 INIT=1 RETURN * Last step on the contour: lock but do this one. ELSEIF(INDEX(STATUS,'END').NE.0)THEN INIT=0 * For other operations, INIT must be set properly. ELSEIF(INIT.EQ.0)THEN WRITE(10,'('' !!!!!! GRCUPD WARNING : This routine has'', - '' not been initialsed properly; program bug.'')') IFLAG=1 RETURN ENDIF *** In case the contour left the area, update the boundary. IF(INDEX(STATUS,'EDGE').NE.0)THEN * Update of the lower x border. IF(1+2*INT(0.001+IFLAG/2).EQ.IFLAG)THEN IUPD=INT((Y1-CYMIN)*REAL(NGRIDY)/(CYMAX-CYMIN)) IF(IUPD.GE.0.AND.IUPD.LE.NGRIDY)YDONE(0,IUPD)=.TRUE. ENDIF * Update of the higher x border. IF(1+2*INT(0.001+IFLAG/4).EQ.IFLAG/2)THEN IUPD=INT((Y1-CYMIN)*REAL(NGRIDY)/(CYMAX-CYMIN)) IF(IUPD.GE.0.AND.IUPD.LE.NGRIDY) - YDONE(NGRIDX,IUPD)=.TRUE. ENDIF * Update of the lower y border. IF(1+2*INT(0.001+IFLAG/8).EQ.IFLAG/4)THEN IUPD=INT((X1-CXMIN)*REAL(NGRIDX)/(CXMAX-CXMIN)) IF(IUPD.GE.0.AND.IUPD.LE.NGRIDX)XDONE(IUPD,0)=.TRUE. ENDIF * Update of the higher y border. IF(1+2*INT(0.001+IFLAG/16).EQ.IFLAG/8)THEN IUPD=INT((X1-CXMIN)*REAL(NGRIDX)/(CXMAX-CXMIN)) IF(IUPD.GE.0.AND.IUPD.LE.NGRIDX) - XDONE(IUPD,NGRIDY)=.TRUE. ENDIF ENDIF *** IFLAG has now been used, assume the routine will work. IFLAG=0 *** Determine other grid lines the contour may have crossed. IXMIN=MIN(INT((X0-CXMIN)*REAL(NGRIDX)/(CXMAX-CXMIN)), - INT((X1-CXMIN)*REAL(NGRIDX)/(CXMAX-CXMIN))) IXMAX=MAX(INT((X0-CXMIN)*REAL(NGRIDX)/(CXMAX-CXMIN)), - INT((X1-CXMIN)*REAL(NGRIDX)/(CXMAX-CXMIN))) IYMIN=MIN(INT((Y0-CYMIN)*REAL(NGRIDY)/(CYMAX-CYMIN)), - INT((Y1-CYMIN)*REAL(NGRIDY)/(CYMAX-CYMIN))) IYMAX=MAX(INT((Y0-CYMIN)*REAL(NGRIDY)/(CYMAX-CYMIN)), - INT((Y1-CYMIN)*REAL(NGRIDY)/(CYMAX-CYMIN))) IXMIN=MIN(MXGRID,NGRIDX,MAX(0,IXMIN)) IXMAX=MIN(MXGRID,NGRIDX,MAX(0,IXMAX)) IYMIN=MIN(MXGRID,NGRIDY,MAX(0,IYMIN)) IYMAX=MIN(MXGRID,NGRIDY,MAX(0,IYMAX)) ** Skip the case no line was crossed. IF(IXMIN.EQ.IXMAX.AND.IYMIN.EQ.IYMAX)THEN X0=X1 Y0=Y1 RETURN ENDIF if(ldebug)write(10,'('' x-range: '',2I3,'' y-range: '',2I3)') - ixmin,ixmax,iymin,iymax ** Loop over the subgrid. DO 20 IX=IXMIN,IXMAX DO 30 IY=IYMIN,IYMAX ** x-update, skipped if the grid point is on the boundary. IF((.NOT.XDONE(IX,IY)).AND.IX.LT.NGRIDX.AND.CROSS( - CXMIN+REAL(IX)*(CXMAX-CXMIN)/REAL(NGRIDX), - CYMIN+REAL(IY)*(CYMAX-CYMIN)/REAL(NGRIDY), - CXMIN+REAL(IX+1)*(CXMAX-CXMIN)/REAL(NGRIDX), - CYMIN+REAL(IY)*(CYMAX-CYMIN)/REAL(NGRIDY), - X0,Y0,X1,Y1))THEN * Assume no update occurs. IDONE=0 * Crossing point within bounds, update always if FC within bounds. IF((GRID(IX,IY)-FC)*(FC-GRID(IX+1,IY)).GE.0)THEN XDONE(IX,IY)=.TRUE. IDONE=1 ENDIF * Check whether the contour sneaked before the grid point. IF(IX.GT.0.AND.IDONE.EQ.0)THEN CALL GRCMIN(IX,IY,X0,Y0,X1,Y1,DNCR,ITYP) IF((GRID(IX-1,IY)-FC)*(FC-GRID(IX,IY)).GE.0.AND. - DNCR.LT.DNTHR)THEN XDONE(IX-1,IY)=.TRUE. IF(LDEBUG)WRITE(10,'('' ++++++ GRCUPD'', - '' DEBUG : Low-x update, d='',E15.8, - '' at '',2I3,''.'')') DNCR,IX-1,IY IDONE=1 ENDIF ENDIF * Check whether the contour sneaked past the grid segment. IF(IX.LT.NGRIDX-1.AND.IDONE.EQ.0)THEN CALL GRCMIN(IX+1,IY,X0,Y0,X1,Y1,DNCR,ITYP) IF((GRID(IX+1,IY)-FC)*(FC-GRID(IX+2,IY)).GE.0.AND. - DNCR.LT.DNTHR)THEN XDONE(IX+1,IY)=.TRUE. IF(LDEBUG)WRITE(10,'('' ++++++ GRCUPD'', - '' DEBUG : High-x update, d='',E15.8, - '' at '',2I3,''.'')') DNCR,IX+1,IY IDONE=1 ENDIF ENDIF * Make sure an update is found. IF(IDONE.EQ.0)THEN WRITE(10,'('' !!!!!! GRCUPD WARNING : No x-update'', - '' performed inspite of a segment crossing.'')') C CALL F(X0,Y0,F0,ILOC0) C CALL F(X1,Y1,F1,ILOC1) C NFC=NFC+2 C WRITE(10,'(26X,''Grid='',4E12.5/ C - 26X,''Step='',4E12.5/26X,''F Grid='',3E12.5/ C - 26X,''F step='',3E12.5/ C - 26X,''Loc ='',12X,2I12)') C - CXMIN+IX*(CXMAX-CXMIN)/REAL(NGRIDX), C - CYMIN+IY*(CYMAX-CYMIN)/REAL(NGRIDY), C - CXMIN+(IX+1)*(CXMAX-CXMIN)/REAL(NGRIDX), C - CYMIN+IY*(CYMAX-CYMIN)/REAL(NGRIDY), C - X0,Y0,X1,Y1, C - GRID(IX-1,IY),GRID(IX,IY),GRID(IX+1,IY), C - FC,F0,F1,ILOC0,ILOC1 XDONE(IX,IY)=.TRUE. ENDIF ENDIF ** y-update, skipped if the grid point is on the boundary. IF((.NOT.YDONE(IX,IY)).AND.IY.LT.NGRIDY.AND.CROSS( - CXMIN+REAL(IX)*(CXMAX-CXMIN)/REAL(NGRIDX), - CYMIN+REAL(IY)*(CYMAX-CYMIN)/REAL(NGRIDY), - CXMIN+REAL(IX)*(CXMAX-CXMIN)/REAL(NGRIDX), - CYMIN+REAL(IY+1)*(CYMAX-CYMIN)/REAL(NGRIDY), - X0,Y0,X1,Y1))THEN * Assume no update occurs. IDONE=0 * Crossing point within bounds, update always if FC within bounds. IF((GRID(IX,IY)-FC)*(FC-GRID(IX,IY+1)).GE.0)THEN YDONE(IX,IY)=.TRUE. IDONE=1 ENDIF * Check whether the contour sneaked before the grid point. IF(IY.GT.0.AND.IDONE.EQ.0)THEN CALL GRCMIN(IX,IY,X0,Y0,X1,Y1,DNCR,ITYP) IF((GRID(IX,IY-1)-FC)*(FC-GRID(IX,IY)).GE.0.AND. - DNCR.LT.DNTHR)THEN YDONE(IX,IY-1)=.TRUE. IF(LDEBUG)WRITE(10,'('' ++++++ GRCUPD'', - '' DEBUG : Low-y update, d='',E15.8, - '' at '',2I3,''.'')') DNCR,IX,IY-1 IDONE=1 ENDIF ENDIF * Check whether the contour sneaked past the grid segment. IF(IY.LT.NGRIDY-1.AND.IDONE.EQ.0)THEN CALL GRCMIN(IX,IY+1,X0,Y0,X1,Y1,DNCR,ITYP) IF((GRID(IX,IY+1)-FC)*(FC-GRID(IX,IY+2)).GE.0.AND. - DNCR.LT.DNTHR)THEN YDONE(IX,IY+1)=.TRUE. IF(LDEBUG)WRITE(10,'('' ++++++ GRCUPD'', - '' DEBUG : High y-update, d='',E15.8, - '' at '',2I3,''.'')') DNCR,IX,IY+1 IDONE=1 ENDIF ENDIF * Make sure an update is found. IF(IDONE.EQ.0)THEN WRITE(10,'('' !!!!!! GRCUPD WARNING : No y-update'', - '' performed inspite of a segment crossing.'')') C WRITE(10,'(26X,''IX,IY='',2I3/26X,''F='',3E15.8)') C - IX,IY,GRID(IX,IY),FC,GRID(IX,IY+1) YDONE(IX,IY)=.TRUE. ENDIF ENDIF 30 CONTINUE 20 CONTINUE *** Shift the positions. X0=X1 Y0=Y1 END +DECK,GRCONV. SUBROUTINE GRCONV(NPOL,XIN,YIN) *----------------------------------------------------------------------- * GRCONV - Plots a convex polygon inside a box. * (Last changed on 13/ 5/99.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,GRAPHICS. +SEQ,PRINTPLOT. +SEQ,CONSTANTS. +SEQ,PARAMETERS. REAL XIN(*),YIN(*),XPL(MXLIST),YPL(MXLIST),ZPL(MXLIST) DOUBLE PRECISION XPOL(MXLIST),YPOL(MXLIST),XAUX,YAUX INTEGER NPOL,I,J,NPL LOGICAL SKIP,INSIDE,EDGE,ADD,ONLIND EXTERNAL ONLIND *** Make sure there is at least 1 input point. IF(NPOL.LE.2)THEN RETURN * Check maximum length. ELSEIF(NPOL.GT.MXLIST)THEN PRINT *,' !!!!!! GRCONV WARNING : Input vector length'// - ' exceeds MXLIST ; area not plotted.' RETURN ENDIF *** Copy the input vector. DO 10 I=1,NPOL XPOL(I)=DBLE(XIN(I)) YPOL(I)=DBLE(YIN(I)) 10 CONTINUE *** Next find the intersections between the two sets. NPL=0 DO 40 J=1,NPOL * Set flag to see whether we search for mid-line intersects. SKIP=.FALSE. * Scan the box. DO 30 I=1,NGBOX * See whether the polygon start is on any of the box edges. IF(ONLIND(GXBOX(1+MOD(I-1,NGBOX)),GYBOX(1+MOD(I-1,NGBOX)), - GXBOX(1+MOD(I,NGBOX)),GYBOX(1+MOD(I,NGBOX)), - XPOL(J),YPOL(J)))THEN IF(NPL.GE.MXLIST)GOTO 3000 NPL=NPL+1 XPL(NPL)=REAL(XPOL(J)) YPL(NPL)=REAL(YPOL(J)) ZPL(NPL)=0 SKIP=.TRUE. ENDIF * See whether a box corner is on this polygon segment. IF(ONLIND(XPOL(1+MOD(J-1,NPOL)),YPOL(1+MOD(J-1,NPOL)), - XPOL(1+MOD(J,NPOL)),YPOL(1+MOD(J,NPOL)), - GXBOX(I),GYBOX(I)))THEN IF(NPL.GE.MXLIST)GOTO 3000 NPL=NPL+1 XPL(NPL)=REAL(GXBOX(I)) YPL(NPL)=REAL(GYBOX(I)) ZPL(NPL)=0 SKIP=.TRUE. ENDIF 30 CONTINUE * If neither of this happened, look for mid-line intersects. IF(.NOT.SKIP)THEN DO 100 I=1,NGBOX CALL CRSPND( - GXBOX(1+MOD(I-1,NGBOX)),GYBOX(1+MOD(I-1,NGBOX)), - GXBOX(1+MOD(I ,NGBOX)),GYBOX(1+MOD(I ,NGBOX)), - XPOL(1+MOD(J-1,NPOL)),YPOL(1+MOD(J-1,NPOL)), - XPOL(1+MOD(J ,NPOL)),YPOL(1+MOD(J ,NPOL)), - XAUX,YAUX,ADD) IF(ADD)THEN IF(NPL.GE.MXLIST)GOTO 3000 NPL=NPL+1 XPL(NPL)=REAL(XAUX) YPL(NPL)=REAL(YAUX) ZPL(NPL)=0 ENDIF 100 CONTINUE ENDIF 40 CONTINUE *** Find the vertices of the box internal to the polygon. DO 50 I=1,NGBOX CALL INTERD(NPOL,XPOL,YPOL,GXBOX(I),GYBOX(I),INSIDE,EDGE) * Skip box corners on the polygon. IF(EDGE)GOTO 50 * Add internal points. IF(INSIDE)THEN IF(NPL.GE.MXLIST)GOTO 3000 NPL=NPL+1 XPL(NPL)=REAL(GXBOX(I)) YPL(NPL)=REAL(GYBOX(I)) ZPL(NPL)=0 ENDIF 50 CONTINUE *** Find the vertices of the polygon internal to the box. DO 70 I=1,NPOL * Check whether the point is internal. XAUX=XPOL(I) YAUX=YPOL(I) CALL INTERD(NGBOX,GXBOX,GYBOX,XAUX,YAUX,INSIDE,EDGE) * Skip polygon corners on the box. IF(EDGE)GOTO 70 * Add internal points. IF(INSIDE)THEN IF(NPL.GE.MXLIST)GOTO 3000 NPL=NPL+1 XPL(NPL)=REAL(XPOL(I)) YPL(NPL)=REAL(YPOL(I)) ZPL(NPL)=0 ENDIF 70 CONTINUE *** Ensure there is no butterfly. CALL BUTFLY(NPL,XPL,YPL,ZPL) *** Plot the polygon. IF(NPL.GE.3)CALL GFA(NPL,XPL,YPL) RETURN *** Buffer overflow. 3000 CONTINUE PRINT *,' !!!!!! GRCONV WARNING : Plot vector buffer'// - ' overflow; area not plotted.' END +DECK,GRDAWK. SUBROUTINE GRDAWK(NAME,OPTION) *----------------------------------------------------------------------- * GRDAWK - Deactivates a workstation - GKS version. * (Last changed on 6/ 3/04.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. +SEQ,GRAPHICS. EXTERNAL INPCMX INTEGER INPCMX,IWK,IFAIL,IERR,ISTATE CHARACTER*(*) NAME,OPTION *** Locate workstation. CALL GRQIWK(NAME,IWK,IFAIL) IF(IFAIL.NE.0)RETURN *** Delayed processing. IF(OPTION.EQ.'DELAY'.AND..NOT.WKMULT(IWK))THEN WKSREQ(IWK)=2 RETURN ENDIF *** Check the current state of the workstation. IF(WKSTAT(IWK).LT.2)THEN PRINT *,' !!!!!! GRDAWK WARNING : Workstation ',NAME, - ' is not even open; not deactivated.' RETURN ENDIF CALL GQWKS(IWK,IERR,ISTATE) IF(IERR.NE.0)PRINT *,' !!!!!! GRDAWK WARNING : Inquiry error'// - ' for state of ',NAME,' ; assumed active.' IF(IERR.EQ.0.AND.ISTATE.EQ.0)THEN PRINT *,' !!!!!! GRDAWK WARNING : Workstation ',NAME, - ' is already inactive.' RETURN ENDIF *** And at last deactivate the workstation. CALL GDAWK(IWK) IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GRDAWK DEBUG :'', - '' Workstation '',A,'' has been deactivated.'')') NAME WKSTAT(IWK)=2 +SELF,IF=HIGZ. CALL SGFLAG +SELF. END +DECK,GRDLWK. SUBROUTINE GRDLWK *----------------------------------------------------------------------- * GRDLWK - Deletes a workstation - version for GKS. * (Last changed on 25/ 3/92.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. +SEQ,GRAPHICS. CHARACTER*(MXCHAR) STRING CHARACTER*20 NAME INTEGER NC,IKEY,NWORD,I,NCNAME,IWK *** Determine position of keyword. CALL INPSTR(1,1,STRING,NC) IF(STRING(1:1).EQ.'!'.AND.NC.EQ.1)THEN IKEY=2 ELSE IKEY=1 ENDIF *** Warn if there are no arguments. CALL INPNUM(NWORD) IF(NWORD.EQ.IKEY)THEN PRINT *,' !!!!!! GRDLWK WARNING : DELETE-WORKSTATION'// - ' needs one argument; nothing done.' RETURN ENDIF *** Locate the workstation in the table. CALL INPSTR(IKEY+1,IKEY+1,NAME,NCNAME) * Match with existing names. DO 10 I=1,NWK IF(NAME(1:NCNAME).EQ.WKNAME(I)(1:NCWKNM(I)))THEN IWK=I GOTO 20 ENDIF 10 CONTINUE * Warn if not found. PRINT *,' !!!!!! GRDLWK WARNING : Workstation '//NAME(1:NCNAME)// - ' is not known; not deleted.' RETURN 20 CONTINUE *** Check current status. IF(WKSTAT(IWK).EQ.3)THEN PRINT *,' !!!!!! GRDLWK WARNING : '//NAME(1:NCNAME)// - ' is still active ; deactivating ...' CALL GRDAWK(NAME(1:NCNAME),'IMMEDIATE') ENDIF IF(WKSTAT(IWK).EQ.2)THEN PRINT *,' !!!!!! GRDLWK WARNING : '//NAME(1:NCNAME)// - ' is still open ; closing ...' CALL GRCLWK(NAME(1:NCNAME),'IMMEDIATE') ENDIF *** Delete from the table. DO 30 I=IWK+1,NWK WKNAME(I-1)=WKNAME(I) WKID (I-1)=WKID (I) NCWKNM(I-1)=NCWKNM(I) WKFREF(I-1)=WKFREF(I) WKCON (I-1)=WKCON (I) WKLUN (I-1)=WKLUN (I) WKATTR(I-1)=WKATTR(I) WKSTAT(I-1)=WKSTAT(I) WKSREQ(I-1)=WKSREQ(I) WKMULT(I-1)=WKMULT(I) 30 CONTINUE NWK=NWK-1 END +DECK,GRQIWK. SUBROUTINE GRQIWK(NAME,IWK,IFAIL) *----------------------------------------------------------------------- * GRQIWK - Returns the wkid of a workstation. * (Last changed on 18/ 4/92.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. +SEQ,GRAPHICS. EXTERNAL INPCMX INTEGER INPCMX CHARACTER*(*) NAME *** Assume the routine will fail. IFAIL=1 *** Scan the workstation table. IWK=0 NFOUND=0 DO 10 I=1,NWK IF(INPCMX(NAME,WKNAME(I)(1:NCWKNM(I))).NE.0)THEN IWK=I NFOUND=NFOUND+1 ENDIF 10 CONTINUE *** Error messages. IF(NFOUND.EQ.0)THEN PRINT *,' !!!!!! GRQIWK WARNING : Workstation ',NAME, - ' is not known ; not opened.' RETURN ELSEIF(NFOUND.GT.1)THEN PRINT *,' !!!!!! GRQIWK WARNING : Workstation ',NAME, - ' is ambiguous ; not opened.' RETURN ENDIF *** Things are OK. IFAIL=0 END +DECK,GROPWK. SUBROUTINE GROPWK(NAME,OPTION) *----------------------------------------------------------------------- * GROPWK - Opens a workstation - version for GKS. * (Last changed on 6/ 3/04.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. +SEQ,GRAPHICS. EXTERNAL INPCMX INTEGER INPCMX,IFAIL,IFAIL1,IWK,I,NC,IERR,ISTATE,IOS CHARACTER*(*) NAME,OPTION CHARACTER*(MXNAME) AUX LOGICAL OPENED *** Locate workstation. CALL GRQIWK(NAME,IWK,IFAIL) IF(IFAIL.NE.0)RETURN *** Delayed processing. IF(OPTION.EQ.'DELAY'.AND..NOT.WKMULT(IWK))THEN WKSREQ(IWK)=2 RETURN ENDIF *** Check the current state of the workstation. IF(WKSTAT(IWK).GE.2)THEN PRINT *,' !!!!!! GROPWK WARNING : Workstation ',NAME, - ' is already open ; not opened.' RETURN ENDIF *** Open the workstation: case of a workstation associated with a file. IF(WKFREF(IWK).GT.0)THEN * Find a free logical unit. WKLUN(IWK)=0 INQUIRE(UNIT=11,OPENED=OPENED) IF(OPENED)THEN DO 20 I=40,49 INQUIRE(UNIT=I,OPENED=OPENED) IF(.NOT.OPENED)THEN WKLUN(IWK)=I GOTO 30 ENDIF 20 CONTINUE PRINT *,' !!!!!! GROPWK WARNING : All logical units'// - ' reserved for metafiles are in use ; not opened.' RETURN 30 CONTINUE ELSE WKLUN(IWK)=11 ENDIF * Retrieve the file name. CALL STRBUF('READ',WKFREF(IWK),AUX,NC,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! GROPWK WARNING : Unable to retrieve'// - ' the file name of the workstation; not opened.' RETURN ENDIF * Perform global variable substitution. CALL INPSUB(AUX(1:NC),NC,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! GROPWK WARNING : Substitution of'// - ' global variables in the file name of the'// - ' workstation failed; not opened.' RETURN ENDIF +SELF,IF=CMS. * And open the file. INQUIRE(FILE='/'//AUX(1:NC),OPENED=OPENED) IF(OPENED)THEN PRINT *,' !!!!!! GROPWK WARNING : You have already'// - ' opened file '//AUX(1:NC)//' ; workstation ', - NAME,' not opened.' RETURN ENDIF CALL FILEINF(IRC,'RECFM','V','LRECL',132) OPEN(UNIT=WKLUN(IWK),FILE='/'//AUX(1:NC), - ACTION='READWRITE',ACCESS='SEQUENTIAL', - ERR=2020,IOSTAT=IOS) CALL DSNLOG(AUX(1:NC),'Metafile ','Sequential', - 'Write ') +SELF,IF=-CMS. * And open the file. CALL DSNOPN(AUX(1:NC),NC,WKLUN(IWK),'WRITE-FILE',IFAIL) IF(OPENED)THEN PRINT *,' !!!!!! GROPWK WARNING : Unable to open '// - AUX(1:NC)//' as metafile for workstation ', - NAME,'; left in "defined" state.' RETURN ENDIF CALL DSNLOG(AUX(1:NC),'Metafile ','Sequential', - 'Write ') +SELF. * And open the workstation. CALL GOPWK(IWK,WKLUN(IWK)+WKCON(IWK),WKID(IWK)) WKSTAT(IWK)=2 * Debugging output. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GROPWK DEBUG :'', - '' File '',A,'' opened on unit '',I2,'' for'', - '' workstation '',A,'' of type '',I5,''.'')') - AUX(1:NC),WKLUN(IWK),NAME,WKID(IWK) *** Open the workstation: no associated file. ELSE CALL GOPWK(IWK,WKCON(IWK),WKID(IWK)) WKSTAT(IWK)=2 * Debugging output. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GROPWK DEBUG :'', - '' Workstation '',A,'' of type '',I5,'' opened'', - '' without associated file.'')') NAME,WKID(IWK) ENDIF *** Check that the workstation is really open. CALL GQWKS(IWK,IERR,ISTATE) IF(IERR.EQ.7.OR.IERR.EQ.25)THEN PRINT *,' !!!!!! GROPWK WARNING : Workstation ',NAME, - ' could not be opened.' WKSTAT(IWK)=1 RETURN ELSEIF(IERR.EQ.20)THEN PRINT *,' !!!!!! GROPWK WARNING : Cannot open ',NAME, - ' because the workstation identifier is not valid.' WKSTAT(IWK)=1 RETURN ENDIF *** Set the workstation window. CALL GSWKWN(IWK,0.0,1.0,0.0,1.0) *** End of normal processing. RETURN +SELF,IF=CMS. *** Error handling. 2020 CONTINUE CALL STRBUF('READ',WKFREF(IWK),AUX,NC,IFAIL1) PRINT *,' !!!!!! GROPWK WARNING : Metafile '//AUX(1:NC)//' on '// - ' unit ',WKLUN(IWK),' can not be opened.' CALL INPIOS(IOS) +SELF. END +DECK,GRTERMA,IF=APOLLO,UNIX,CYGWIN. SUBROUTINE GRTERM(IWKTYP,ICON,IFLAG,IFAIL) *----------------------------------------------------------------------- * GRTERM - Returns the workstation identifier from the command line. * Version for GKS. * (Last changed on 19/12/10.) *----------------------------------------------------------------------- implicit none +SEQ,PRINTPLOT. +SELF,IF=APOLLO. %include '/sys/ins/base.ins.ftn' %include '/sys/ins/pgm.ins.ftn' integer*2 iarg,nargs,arg_length integer pointer(128) +SELF,IF=-APOLLO,IF=G77. integer arg_length,iargc,nargs external iargc +SELF,IF=APOLLO,-G77. integer nargs, arg_length +SELF. character*128 args integer istart,iend,ionoff,iflag,iarg,iwktyp,icon,ifail, - iwkr,iconr,icat,ifail1,inext,ierr,idum,inpcmx external inpcmx *** Default settings. call grwkid('*interactive_default',iwktyp,icon,icat,idum) ifail=1 *** Pick up the value from the command line, count arguments. +SELF,IF=APOLLO. call pgm_$get_args(nargs,pointer) nargs=nargs-1 +SELF,IF=-APOLLO. nargs=iargc() +SELF. *** Find the area devoted to the -terminal option. istart=0 iend=nargs ionoff=0 iflag=0 do iarg=1,nargs +SELF,IF=APOLLO. arg_length=pgm_$get_arg(iarg,args,istat) if(istat.ne.status_$ok)then print *,' !!!!!! GRTERM WARNING : Error fetching an'// - ' argument; default terminal type returned.' ifail=1 return endif +SELF,IF=-APOLLO. call argget(iarg,args,arg_length) +SELF. if(args(1:1).eq.'-'.and.arg_length.gt.1.and.istart.ne.0)then iend=iarg-1 goto 10 elseif(inpcmx(args(1:arg_length),'-term#inal').ne.0)then istart=iarg+1 ionoff=1 elseif(inpcmx(args(1:arg_length),'-noterm#inal').ne.0)then ionoff=-1 endif enddo 10 continue *** Return here if there is a -noterminal or no -terminal. if(ionoff.eq.0)then ifail=0 if(ldebug)write(lunout,'('' ++++++ GRTERM DEBUG :'', - '' No -terminal qualifier present.'')') iflag=0 goto 100 elseif(ionoff.eq.-1)then ifail=0 if(ldebug)write(lunout,'('' ++++++ GRTERM DEBUG :'', - '' Request not to produce terminal graphics.'')') +SELF,IF=HIGZ. iflag=0 iwktyp=0 +SELF,IF=-HIGZ. iflag=-1 +SELF. return else iflag=+1 endif *** Decode the part about the terminal. inext=istart do 20 iarg=istart,iend if(iarg.lt.inext)goto 20 ** Retrieve the sub-keyword. +SELF,IF=APOLLO. arg_length=pgm_$get_arg(iarg,args,istat) +SELF,IF=-APOLLO. call argget(iarg,args,arg_length) +SELF. ** Terminal type. if(inpcmx(args(1:arg_length),'t#ype').ne.0)then * Check there indeed is an argument. if(iarg.eq.iend)then PRINT *,' !!!!!! GRTERM WARNING : The argument'// - ' for "type" is missing.' ifail=1 goto 100 endif * Retrieve the argument. +SELF,IF=APOLLO. arg_length=pgm_$get_arg(iarg+1,args,istat) +SELF,IF=-APOLLO. call argget(iarg+1,args,arg_length) +SELF. * Compare with the workstation type list. call grwkid(args(1:arg_length),iwkr,iconr,icat,ifail1) * Check that this is a good interactive workstation type. if(icat.ne.2.or.ifail1.ne.0)then PRINT *,' !!!!!! GRTERM WARNING : Terminal type '// - args(1:arg_length)//' not valid or not for'// - ' interactive use.' ifail=1 return endif iwktyp=iwkr icon=iconr * Debugging output. if(ldebug)write(lunout,'('' ++++++ GRTERM DEBUG :'', - '' Terminal type '',A,'', GKS id '',I5,''.'')') - args(1:arg_length),iwktyp inext=iarg+2 ** Terminal type via GKS identifier. elseif(inpcmx(args(1:arg_length),'GKS#_identifier').ne.0)then * Check there indeed is an argument. if(iarg.eq.iend)then PRINT *,' !!!!!! GRTERM WARNING : The argument'// - ' for "GKS_identifier" is missing.' ifail=1 goto 100 endif * Retrieve the argument. +SELF,IF=APOLLO. arg_length=pgm_$get_arg(iarg+1,args,istat) +SELF,IF=-APOLLO. call argget(iarg+1,args,arg_length) +SELF. * Attempt to read the integer. call inpric(args(1:arg_length),iwkr,0,ifail1) if(ifail1.ne.0)then print *,' !!!!!! GRTERM WARNING : The terminal'// - ' GKS identifier is not a valid integer.' ifail=1 goto 100 endif * Check workstation category. call gqwkca(iwkr,ierr,icat) if(icat.ne.2.or.ierr.ne.0)then PRINT *,' !!!!!! GRTERM WARNING : Terminal type '// - args(1:arg_length)//' not valid or not for'// - ' interactive use.' ifail=1 goto 100 endif * Store the workstation type. iwktyp=iwkr * Debugging output. if(ldebug)write(lunout,'('' ++++++ GRTERM DEBUG :'', - '' GKS identifier '',I5,'' given for terminal'', - '' type.'')') iwktyp inext=iarg+2 ** Connection identifier. elseif(inpcmx(args(1:arg_length), - 'c#onnection_identifier').ne.0)then * Check there indeed is an argument. if(iarg.eq.iend)then PRINT *,' !!!!!! GRTERM WARNING : The argument'// - ' for "connection_identifier" is missing.' ifail=1 return endif * Retrieve the argument. +SELF,IF=APOLLO. arg_length=pgm_$get_arg(iarg+1,args,istat) +SELF,IF=-APOLLO. call argget(iarg+1,args,arg_length) +SELF. * Attempt to read the number. call inpric(args(1:arg_length),iconr,0,ifail1) if(ifail1.ne.0)then print *,' !!!!!! GRTERM WARNING : The terminal'// - ' connection identifier is not a valid integer.' ifail=1 return endif icon=iconr * Debugging output. if(ldebug)write(lunout,'('' ++++++ GRTERM DEBUG :'', - '' Terminal connection identifier '',I3,''.'')') - icon inext=iarg+2 ** Anything else is not valid. else print *,' !!!!!! GRTERM WARNING : The keyword '// - args(1:arg_length)//' is not valid within'// - ' -terminal; is ignored.' endif 20 continue *** Continue here in case of errors. 100 continue +SELF,IF=HIGZ. *** Check whether an inquiry is required. if(iwktyp.eq.-1.and.iflag.ge.0)then call igwkty(iwktyp) icon=0 endif +SELF. *** Things worked fine. ifail=0 end +DECK,GRTERMV,IF=VAX. SUBROUTINE GRTERM(IWKTYP,ICON,IFLAG,IFAIL) *----------------------------------------------------------------------- * GRTERM - Returns the workstation identifier from the command line. * (Last changed on 17/ 6/95.) *----------------------------------------------------------------------- +SEQ,PRINTPLOT. EXTERNAL CLI$GET_VALUE,CLI$PRESENT,CLI$_PRESENT,CLI$_ABSENT, - CLI$_NEGATED,CLI$_DEFAULTED INTEGER STATUS,CLI$GET_VALUE,CLI$PRESENT INTEGER*2 NC CHARACTER*255 TERM INCLUDE '($FORDEF)' INCLUDE '($SSDEF)' +SELF,IF=SAVE. SAVE INIT,IWKRES,ICRES,IFRES,IFLAGR +SELF. *** First and subsequent calls. DATA INIT/0/,IWKRES/0/,ICRES/-1/,IFRES/1/,IFLAGR/0/ IF(INIT.NE.0)THEN IWKTYP=IWKRES ICON=ICRES IFLAG=IFLAGR IFAIL=IFRES RETURN ELSE CALL GRWKID('*interactive_default',IWKTYP,ICON,ICAT,IDUM) IFAIL=1 IFLAG=0 INIT=1 ENDIF *** Terminal qualifier negated ? IF(CLI$PRESENT('TERMINAL').EQ.%LOC(CLI$_NEGATED))THEN IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GRTERM DEBUG :'', - '' Request not to produce terminal graphics'', - '' output.'')') +SELF,IF=HIGZ. IFLAG=0 IWKTYP=0 +SELF,IF=-HIGZ. IFLAG=-1 +SELF. IFAIL=0 GOTO 100 ENDIF *** Is this a private terminal type ? IF(CLI$PRESENT('TERM_GKSID').EQ.%LOC(CLI$_PRESENT))THEN IFLAG=+1 STATUS=CLI$GET_VALUE('TERM_GKSID',TERM,NC) IF(STATUS.NE.SS$_NORMAL)THEN PRINT *,' !!!!!! GRTERM WARNING : Unable to get'// - ' the terminal GKS identifier.' GOTO 100 ENDIF * Attempt to read as integer. CALL INPRIC(TERM(1:NC),IWKR,0,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! GRTERM WARNING : The terminal'// - ' GKS identifier is not a valid integer.' GOTO 100 ENDIF * Check workstation category. CALL GQWKCA(IWKR,IERR,ICAT) IF(ICAT.NE.2.OR.IERR.NE.0)THEN PRINT *,' !!!!!! GRTERM WARNING : Terminal type '// - TERM(1:NC)//' not valid or not for'// - ' interactive use.' GOTO 100 ENDIF * Store workstation type. IWKTYP=IWKR * Debugging output. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GRTERM DEBUG :'// - ' Terminal specified by GKS id='',I6,''.'')') IWKTYP *** Or a standard terminal type ? ELSEIF(CLI$PRESENT('TERM_TYPE').EQ.%LOC(CLI$_PRESENT).OR. - CLI$PRESENT('TERM_TYPE').EQ.%LOC(CLI$_DEFAULTED))THEN STATUS=CLI$GET_VALUE('TERM_TYPE',TERM,NC) IF(STATUS.NE.SS$_NORMAL)THEN PRINT *,' !!!!!! GRTERM WARNING : Unable to get'// - ' the terminal type.' GOTO 100 ENDIF IFLAG=+1 * Compare with the workstation type list. CALL GRWKID(TERM(1:NC),IWKR,ICONR,ICAT,IFAIL1) * Check that this is a good interactive workstation type. IF(ICAT.NE.2.OR.IFAIL1.NE.0)THEN PRINT *,' !!!!!! GRTERM WARNING : Terminal type '// - TERM(1:NC)//' not valid or not for'// - ' interactive use.' GOTO 100 ENDIF IWKTYP=IWKR ICON=ICONR IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GRTERM DEBUG :'', - '' Terminal specified by type='',A,'', GKS id='', - I5,''.'')') TERM(1:NC),IWKTYP ENDIF *** Logical unit. IF(CLI$PRESENT('TERM_CONID').EQ.%LOC(CLI$_PRESENT))THEN STATUS=CLI$GET_VALUE('TERM_CONID',TERM,NC) IF(STATUS.NE.SS$_NORMAL)THEN PRINT *,' !!!!!! GRTERM WARNING : Unable to get'// - ' the terminal connection identifier.' GOTO 100 ENDIF CALL INPRIC(TERM(1:NC),ICONR,0,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! GRTERM WARNING : The terminal'// - ' connection identifier is not a valid integer.' GOTO 100 ENDIF ICON=ICONR IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GRTERM DEBUG :'', - '' Terminal connection identifier '',I3,''.'')') - ICON ENDIF *** Things seem to have worked. IFAIL=0 *** Continue here if something failed. 100 CONTINUE +SELF,IF=HIGZ. *** Check whether an inquiry is required. IF(IWKTYP.EQ.-1.AND.IFLAG.GE.0.AND.IFAIL.EQ.0)THEN CALL IGWKTY(IWKTYP) ICON=0 ENDIF +SELF. *** Store defaults. IWKRES=IWKTYP ICRES=ICON IFLAGR=IFLAG IFRES=IFAIL END +DECK,GRTERMC,IF=CMS. SUBROUTINE GRTERM(IWKTYP,ICON,IFLAG,IFAIL) *----------------------------------------------------------------------- * GRTERM - Returns the workstation identifier from the command line. * (Last changed on 17/ 6/95.) *----------------------------------------------------------------------- +SEQ,PRINTPLOT. INTEGER IRC CHARACTER*255 TERM *** Default settings. CALL GRWKID('*interactive_default',IWKTYP,IOFF,ICAT,IDUM) IFLAG=0 IFAIL=1 *** Check whether the terminal has to be active at all. CALL VMREXX('F','TERM_YN',TERM,IRC) * Handle errors picking up the value. IF(IRC.NE.0)THEN PRINT *,' !!!!!! GRTERM WARNING : Unable to pick up'// - ' the command line yes/no flag for terminals.' IFAIL=1 GOTO 100 ENDIF * Check value. IF(TERM(1:2).EQ.'NO')THEN IFLAG=-1 IF(LDEBUG)PRINT *,' ++++++ GRTERM DEBUG : Requested not'// - ' to produce terminal graphics output.' IFAIL=0 RETURN ELSEIF(TERM(1:3).NE.'YES')THEN PRINT *,' !!!!!! GRTERM WARNING : Invalid terminal yes/no'// - ' flag on the command line; default returned.' IFAIL=1 GOTO 100 ELSE IFLAG=+1 ENDIF *** Read the terminal type. CALL VMREXX('F','TERM_TYPE',TERM,IRC) * Handle errors picking up the value. IF(IRC.NE.0)THEN PRINT *,' !!!!!! GRTERM WARNING : Unable to pick up'// - ' the terminal type from the command line.' IFAIL=1 GOTO 100 ENDIF ** Try to identify if it really is a type. IF(TERM(1:1).NE.'-')THEN * Determine the length. DO I=LEN(TERM),1,-1 IF(TERM(I:I).NE.' ')THEN NC=I GOTO 10 ENDIF ENDDO NC=0 10 CONTINUE IF(NC.GT.20)NC=20 * Compare with the workstation type list. CALL GRWKID(TERM(1:NC),IWKR,ICONR,ICAT,IFAIL1) * Check the entry exists and is for interactive use. IF(ICAT.NE.2.OR.IFAIL1.NE.0)THEN PRINT *,' !!!!!! GRTERM WARNING : Terminal type '// - TERM(1:NC)//' not valid or not for'// - ' interactive use.' IFAIL=1 RETURN ENDIF * Store if OK. IWKTYP=IWKR ICON=ICONR * Debugging output. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GRTERM DEBUG :'', - '' Terminal specified by type '',A,'', GKS id '', - I5,''.'')') TERM(1:NC),IWKTYP ** Otherwise read the GKS identifier. ELSE CALL VMREXX('F','TERM_GKSID',TERM,IRC) * Handle errors picking up the value. IF(IRC.NE.0)THEN PRINT *,' !!!!!! GRTERM WARNING : Unable to pick up'// - ' the terminal GKS identifier.' IFAIL=1 GOTO 100 ENDIF * Determine the length. DO I=LEN(TERM),1,-1 IF(TERM(I:I).NE.' ')THEN NC=I GOTO 20 ENDIF ENDDO NC=0 20 CONTINUE * Interpret as a number. CALL INPRIC(TERM(1:NC),IWKR,0,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! GRTERM WARNING : The terminal'// - ' GKS identifier is not a valid integer.' IFAIL=1 GOTO 100 ENDIF * Check workstation category. CALL GQWKCA(IWKR,IERR,ICAT) IF(ICAT.NE.2.OR.IERR.NE.0)THEN PRINT *,' !!!!!! GRTERM WARNING : Terminal type '// - TERM(1:NC)//' not valid or not for'// - ' interactive use.' IFAIL=1 RETURN ENDIF * Store workstation type. IWKTYP=IWKR * Debugging output. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GRTERM DEBUG :'', - '' Terminal GKS identifier is '',I5,''.'')') - IWKTYP ** And the logical unit offset. CALL VMREXX('F','TERM_CONID',TERM,IRC) * Handle errors picking up the value. IF(IRC.NE.0)THEN PRINT *,' !!!!!! GRTERM WARNING : Unable to get the'// - ' terminal connection identifier.' IFAIL=1 RETURN ENDIF * Determine the length. DO I=LEN(TERM),1,-1 IF(TERM(I:I).NE.' ')THEN NC=I GOTO 30 ENDIF ENDDO NC=0 30 CONTINUE * Interpret as a number. CALL INPRIC(TERM(1:NC),ICONR,0,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! GRTERM WARNING : The terminal'// - ' connection identifier is not a valid integer.' IFAIL=1 RETURN ENDIF ICON=ICONR IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GRTERM DEBUG :'', - '' Terminal logical unit offset '',I3,''.'')') - IOFF ENDIF *** Continue here in case of errors. 100 CONTINUE +SELF,IF=HIGZ. * Check whether an inquiry is required. IF(IWKTYP.EQ.0.AND.IFLAG.EQ.1)THEN CLOSE(5) OPEN(5) CALL IGWKTY(IWKTYP) CLOSE(5) OPEN(5,FORM='UNFORMATTED') ICON=0 ENDIF +SELF. *** Things went OK. IFAIL=0 END +DECK,GRWCNC. SUBROUTINE GRWCNC(XWC,YWC,XNDC,YNDC) *----------------------------------------------------------------------- * GRWCNC - Converts world coordinates into NDC coordinates. * (Last changed on 29/ 6/96.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. +SEQ,PARAMETERS. +SEQ,GRAPHICS. REAL XWC,YWC,XNDC,YNDC,WINDOW(4),VIEWP(4) INTEGER IERR,NT *** Inquire current NT. CALL GQCNTN(IERR,NT) IF(IERR.NE.0)THEN IF(LDEBUG)PRINT *,' ++++++ GRWCNC DEBUG : Error from'// - ' GQCNTN, code=',IERR,'; no conversion.' RETURN ENDIF *** Find out how big the screen is. CALL GQNT(NT,IERR,WINDOW,VIEWP) IF(IERR.NE.0)THEN IF(LDEBUG)PRINT *,' ++++++ GRWCNC DEBUG : Error from'// - ' GQNT, code=',IERR,'; no conversion.' RETURN ENDIF *** x-Coordinate. IF(LOGX.AND.XWC.GT.0)THEN XNDC=(VIEWP(2)-VIEWP(1))*(LOG10(XWC)-WINDOW(1))/ - (WINDOW(2)-WINDOW(1)) ELSEIF(LOGX)THEN XNDC=-1 ELSE XNDC=(VIEWP(2)-VIEWP(1))*(XWC-WINDOW(1))/ - (WINDOW(2)-WINDOW(1)) ENDIF *** y-Coordinate. IF(LOGY.AND.YWC.GT.0)THEN YNDC=(VIEWP(4)-VIEWP(3))*(LOG10(YWC)-WINDOW(3))/ - (WINDOW(4)-WINDOW(3)) ELSEIF(LOGY)THEN YNDC=-1 ELSE YNDC=(VIEWP(4)-VIEWP(3))*(YWC-WINDOW(3))/ - (WINDOW(4)-WINDOW(3)) ENDIF END +DECK,GRWKID. SUBROUTINE GRWKID(NAME,IWKID,LUNOFF,ICAT,IFAIL) *----------------------------------------------------------------------- * GRWKID - Associates a workstation name with an identifier. * VARIABLES : NAME : Input name of the workstation. * IWKID : Will be set to the workstation identifier. * LUNOFF : Offset between conid and lun. * (Last changed on 23/ 4/96.) *----------------------------------------------------------------------- +SEQ,PRINTPLOT. CHARACTER*(*) NAME INTEGER IWKID,IFAIL,LUNOFF +SELF,IF=APOLLO,IF=GTSGRAL. PARAMETER(NTYP=37) INTEGER ITYP(NTYP),IOFF(NTYP),INOUT(NTYP) CHARACTER*20 TYPE(NTYP) *** Workstation lists. DATA (TYPE(I),ITYP(I),IOFF(I),INOUT(I),I=1,10)/ - 'DN300_bw ', 10002, 1, 1, - 'DN3000_bw ', 10002, 1, 1, - '*interactive_default', 10002, 1, 1, - 'DN3000_colour ', 10004, 1, 1, - 'DN550_colour ', 10003, 1, 1, - 'DN660_colour ', 10003, 1, 1, - 'GSR_1 ', 9701, 1, 1, - 'GSR_2 ', 9702, 1, 1, - 'GSR_3 ', 9703, 1, 1, - 'GSR_4 ', 9704, 1, 1/ DATA (TYPE(I),ITYP(I),IOFF(I),INOUT(I),I=11,20)/ - 'GSR_5 ', 9705, 1, 1, - 'GSR_6 ', 9706, 1, 1, - 'GSR_7 ', 9707, 1, 1, - 'GSR_8 ', 9708, 1, 1, - 'X_windows_0 ', 32120, 1, 1, - 'X_windows_1 ', 32121, 1, 1, - 'X_windows_2 ', 32122, 1, 1, - 'X_windows_3 ', 32123, 1, 1, - 'X_windows_4 ', 32124, 1, 1, - 'X_windows_5 ', 32125, 1, 1/ DATA (TYPE(I),ITYP(I),IOFF(I),INOUT(I),I=21,30)/ - 'X_windows_6 ', 32126, 1, 1, - 'X_windows_7 ', 32127, 1, 1, - 'X_windows_8 ', 32128, 1, 1, - 'X_windows_9 ', 32129, 1, 1, - 'X_windows ', 32120, 1, 1, - 'APPENDIX_E ', 4, 0, -1, - 'PS_portrait_colour ', 12201, 100, -1, - 'PS_landscape_colour ', 12202, 100, -1, - 'PS_landscape_bw ', 12204, 100, -1, - 'PS_portrait_bw ', 12203, 100, -1/ DATA (TYPE(I),ITYP(I),IOFF(I),INOUT(I),I=31,NTYP)/ - 'PostScript ', 12203, 100, -1, - 'EPS_portrait_colour ', 12201, 200, -1, - 'EPS_landscape_colour', 12202, 200, -1, - 'EPS_landscape_bw ', 12204, 200, -1, - 'EPS_portrait_bw ', 12203, 200, -1, - 'Encapsulated_PS ', 12203, 200, -1, - '*batch_default ', 12203, 100, -1/ +SELF,IF=-APOLLO,IF=GTSGRAL. PARAMETER(NTYP=51) INTEGER ITYP(NTYP),IOFF(NTYP),INOUT(NTYP) CHARACTER*20 TYPE(NTYP) *** Workstation lists. DATA (TYPE(I),ITYP(I),IOFF(I),INOUT(I),I=1,10)/ - 'VT100_RETROGRAPHICS ', 1001, 1, 1, - 'VT100_SELENAR ', 1002, 1, 1, - 'VT125_REGIS ', 1010, 1, 1, - 'VT240_REGIS ', 1020, 1, 1, - 'VT241_REGIS ', 1021, 1, 1, - 'VT340 ', 1030, 1, 1, - 'VAXSTATION ', 8601, 1, 1, - 'PG7800 ', 7878, 1, 1, - 'MG600 ', 7800, 1, 1, - 'MX2000 ', 221, 1, 1/ DATA (TYPE(I),ITYP(I),IOFF(I),INOUT(I),I=11,20)/ - 'MX7000 ', 221, 1, 1, - 'MX8000 ', 227, 1, 1, - '4010 ', 101, 1, 1, - '4012 ', 102, 1, 1, - '4014 ', 101, 1, 1, - '4015 ', 103, 1, 1, - '4105 ', 110, 1, 1, - '4107 ', 121, 1, 1, - '4109 ', 122, 1, 1, - '4207 ', 121, 1, 1/ DATA (TYPE(I),ITYP(I),IOFF(I),INOUT(I),I=21,30)/ - '4209 ', 122, 1, 1, - '4111 ', 123, 1, 1, - '4113 ', 125, 1, 1, - '4114 ', 127, 1, 1, - '4115 ', 127, 1, 1, - 'FALCO ', 114, 1, 1, - 'X_WINDOWS_0 ', 32120, 1, 1, - 'X_WINDOWS_1 ', 32121, 1, 1, - 'X_WINDOWS_2 ', 32122, 1, 1, - 'X_WINDOWS_3 ', 32123, 1, 1/ DATA (TYPE(I),ITYP(I),IOFF(I),INOUT(I),I=31,40)/ - 'X_WINDOWS_4 ', 32124, 1, 1, - 'X_WINDOWS_5 ', 32125, 1, 1, - 'X_WINDOWS_6 ', 32126, 1, 1, - 'X_WINDOWS_7 ', 32127, 1, 1, - 'X_WINDOWS_8 ', 32128, 1, 1, - 'X_WINDOWS_9 ', 32129, 1, 1, - 'X_WINDOWS ', 32120, 1, 1, - '*interactive_default', 7878, 1, 1, - 'PT-100G ', 112, 1, 1, - 'APPENDIX_E ', 4, 0, -1/ DATA (TYPE(I),ITYP(I),IOFF(I),INOUT(I),I=41,50)/ - 'PS_PORTRAIT_COLOUR ', 12201, 100, -1, - 'PS_LANDSCAPE_COLOUR ', 12202, 100, -1, - 'PS_LANDSCAPE_BW ', 12204, 100, -1, - 'PS_PORTRAIT_BW ', 12203, 100, -1, - 'POSTSCRIPT ', 12203, 100, -1, - 'EPS_PORTRAIT_COLOUR ', 12201, 200, -1, - 'EPS_LANDSCAPE_COLOUR', 12202, 200, -1, - 'EPS_LANDSCAPE_BW ', 12204, 200, -1, - 'EPS_PORTRAIT_BW ', 12203, 200, -1, - 'ENCAPSULATED_PS ', 12203, 200, -1/ DATA (TYPE(I),ITYP(I),IOFF(I),INOUT(I),I=51,NTYP)/ - '*batch_default ', 4, 0, -1/ +SELF,IF=DECGKS. PARAMETER(NTYP=31) INTEGER ITYP(NTYP),IOFF(NTYP),INOUT(NTYP) CHARACTER*20 TYPE(NTYP) *** Workstation lists. DATA (TYPE(I),ITYP(I),IOFF(I),INOUT(I),I=1,10)/ - 'LOGICAL ', 0, 0, 1, - 'VT125_COLOUR ', 11, 0, 1, - 'VT125_BW ', 12, 0, 1, - 'VT240_COLOUR ', 13, 0, 1, - 'VT240_BW ', 14, 0, 1, - 'VT330 ', 16, 0, 1, - 'VT340 ', 17, 0, 1, - 'VAXSTATION_1 ', 42, 0, 1, - 'VAXSTATION_2 ', 41, 0, 1, - 'VS_1 ', 42, 0, 1/ DATA (TYPE(I),ITYP(I),IOFF(I),INOUT(I),I=11,20)/ - 'VS_2 ', 41, 0, 1, - 'VS_2000 ', 41, 0, 1, - 'DECWINDOWS ', 211, 0, 1, - '4014 ', 72, 0, 1, - '*interactive_default', 72, 0, 1, - '4017 ', 82, 0, 1, - 'POSTSCRIPT ', 61, 0, -1, - 'PS ', 61, 0, -1, - '*batch_default ', 61, 0, -1, - 'METAFILE ', 2, 0, -1/ DATA (TYPE(I),ITYP(I),IOFF(I),INOUT(I),I=21,NTYP)/ - 'DECGKS_MO ', 2, 0, -1, - 'CGM ', 7, 0, -1, - 'LCP01 ', 15, 0, -1, - 'LCG01 ', 15, 0, -1, - 'LN03 ', 38, 0, -1, - 'HP7475 ', 51, 0, -1, - 'HP7550 ', 53, 0, -1, - 'HP7580 ', 54, 0, -1, - 'HP7585 ', 56, 0, -1, - 'LBP8A2 ', 531, 0, -1, - 'L880 ', 532, 0, -1/ +SELF,IF=PLOT10GKS. PARAMETER(NTYP=9) INTEGER ITYP(NTYP),IOFF(NTYP),INOUT(NTYP) CHARACTER*20 TYPE(NTYP) *** Workstation lists. DATA (TYPE(I),ITYP(I),IOFF(I),INOUT(I),I=1,NTYP)/ - '4014_NOTABLET ',401400, -2, 1, - '4014_TABLET ',401401, -2, 1, - '4105 ',410500, -2, 1, - '4107 ',410700, -2, 1, - '4109 ',410900, -2, 1, - 'PERICOM ',301400, -2, 1, - '*interactive_default',301400, -2, 1, - 'PLOT10_MO ',100000, 0, -1, - '*batch_default ',100000, 0, -1/ +SELF,IF=MGKS. PARAMETER(NTYP=8) INTEGER ITYP(NTYP),IOFF(NTYP),INOUT(NTYP) CHARACTER*20 TYPE(NTYP) *** Workstation lists. DATA (TYPE(I),ITYP(I),IOFF(I),INOUT(I),I=1,NTYP)/ - 'borrow ',300009, 1, 1, - 'frame ',300010, 1, 1, - 'direct ',300011, 1, 1, - '4014 ',401400, 1, 1, - 'PERICOM ',301400, 1, 1, - '*interactive_default',301400, 1, 1, - 'APPENDIX_E ',300018, 0, -1, - '*batch_default ',300018, 0, -1/ +SELF,IF=SUNGKS. PARAMETER(NTYP=4) INTEGER ITYP(NTYP),IOFF(NTYP),INOUT(NTYP) CHARACTER*20 TYPE(NTYP) *** Workstation lists. DATA (TYPE(I),ITYP(I),IOFF(I),INOUT(I),I=1,NTYP)/ - 'Console ', 4, 1, 1, - '*interactive_default', 4, 1, 1, - 'Appendix_E ', 7, 0, -1, - '*batch_default ', 7, 0, -1/ +SELF,IF=GKSCO. PARAMETER(NTYP=6) INTEGER ITYP(NTYP),IOFF(NTYP),INOUT(NTYP) CHARACTER*20 TYPE(NTYP) *** Workstation lists. DATA (TYPE(I),ITYP(I),IOFF(I),INOUT(I),I=1,NTYP)/ - 'Console ', 1, 1, 1, - 'X_windows ', 6, -1, 1, - '*interactive_default', 6, -1, 1, - 'GDF ', 5, 0, -1, - 'MO ', 3, 0, -1, - '*batch_default ', 3, 0, -1/ +SELF,IF=ATCGKS. (From Werner Koellner) PARAMETER(NTYP=51) INTEGER ITYP(NTYP),IOFF(NTYP),INOUT(NTYP) CHARACTER*20 TYPE(NTYP) *** Workstation lists. DATA (TYPE(I),ITYP(I),IOFF(I),INOUT(I),I=1,10)/ - 'VT125_REGIS ', 2600, 1, 1, - 'VT240_REGIS ', 2601, 1, 1, - 'VT241_REGIS ', 2602, 1, 1, - '*interactive_default', 2602, 1, 1, - 'VT330 ', 2603, 1, 1, - 'VT340 ', 2604, 1, 1, - 'VT340_COLOUR ', 2505, 1, 1, - '4010 ', 2500, 1, 1, - 'COMP_4010 ', 2501, 1, 1, - '4014 ', 2400, 1, 1/ DATA (TYPE(I),ITYP(I),IOFF(I),INOUT(I),I=11,20)/ - '4105 ', 2300, 1, 1, - 'PIX_4105 ', 2301, 1, 1, - 'COMP_4105 ', 2302, 1, 1, - '4107 ', 3100, 1, 1, - '12B_4107 ', 3101, 1, 1, - '4205 ', 3102, 1, 1, - '12B_4205 ', 3103, 1, 1, - '4208 ', 3104, 1, 1, - '12B_4208 ', 3105, 1, 1, - '4111 ', 3200, 1, 1/ DATA (TYPE(I),ITYP(I),IOFF(I),INOUT(I),I=21,30)/ - '32B_4111 ', 3201, 1, 1, - '4115 ', 3202, 1, 1, - '32B_4115 ', 3203, 1, 1, - '4125 ', 3204, 1, 1, - '32B_4125 ', 3205, 1, 1, - 'CIT_414A ', 2502, 1, 1, - 'GRAPHON ', 2506, 1, 1, - 'LAND_IMG ', 6300, 1, 1, - 'PORT_IMG ', 6301, 1, 1, - 'RETRO ', 3203, 1, 1/ DATA (TYPE(I),ITYP(I),IOFF(I),INOUT(I),I=31,40)/ - 'X11 ', 5300, 1, 1, - 'X_WINDOWS ', 5300, 1, 1, - 'BS_X11 ', 5350, 1, 1, - 'CGM_BIN ', 10100, 100, -1, - 'CGM_MBIN ', 10101, 100, -1, - 'CGM_CHAR ', 10110, 200, -1, - 'CGM_TEXT ', 10120, 300, -1, - 'CGM_LBIN ', 10150, 100, -1, - 'CGM_LCHAR ', 10160, 200, -1, - 'CGM_LTEXT ', 10170, 300, -1/ DATA (TYPE(I),ITYP(I),IOFF(I),INOUT(I),I=41,NTYP)/ - 'PS_PORTRAIT_COLOUR ', 1900, 400, -1, - '*batch_default ', 1900, 400, -1, - 'PS_LANDSCAPE_COLOUR ', 1901, 400, -1, - 'PS_LANDSCAPE_BW ', 1901, 400, -1, - 'PS_PORTRAIT_BW ', 1900, 400, -1, - 'POSTSCRIPT ', 1900, 400, -1, - 'EPS_PORTRAIT_COLOUR ', 1900, 400, -1, - 'EPS_LANDSCAPE_COLOUR', 1901, 400, -1, - 'EPS_LANDSCAPE_BW ', 1901, 400, -1, - 'EPS_PORTRAIT_BW ', 1900, 400, -1, - 'ENCAPSULATED_PS ', 1900, 400, -1/ +SELF,IF=HIGZ. (From Zhengyong Feng) PARAMETER(NTYP=33) INTEGER ITYP(NTYP),IOFF(NTYP),INOUT(NTYP) CHARACTER*20 TYPE(NTYP) DATA (TYPE(I),ITYP(I),IOFF(I),INOUT(I),I=1,NTYP)/ - '0 ', 0, 0, 1, - 'NONE ', 0, 0, 1, - 'none ', 0, 0, 1, - 'INQUIRE ', -1, 0, 1, - 'inquire ', -1, 0, 1, - '*interactive_default', -1, 0, 1, - '1 ', 1, 0, 1, - '2 ', 2, 0, 1, - '3 ', 3, 0, 1, - '4 ', 4, 0, 1, - '5 ', 5, 0, 1, - '6 ', 6, 0, 1, - '7 ', 7, 0, 1, - '8 ', 8, 0, 1, - '9 ', 9, 0, 1, - '7878 ', 7878, 0, 1, - 'FALCO ', 7878, 0, 1, - 'Falco ', 7878, 0, 1, - 'XTERM ', 7879, 0, 1, - 'PS_LANDSCAPE ', -112, 0, -1, - 'PS_landscape ', -112, 0, -1, - 'PS_PORTRAIT ', -111, 0, -1, - 'PS_portrait ', -111, 0, -1, - 'POSTSCRIPT ', -111, 0, -1, - 'PostScript ', -111, 0, -1, - '*batch_default ', -111, 0, -1, - 'EPS ', -113, 0, -1, - 'ENCAPSULATED_PS ', -113, 0, -1, - 'encapsulated_PS ', -113, 0, -1, - 'ENCAPSULATED_POSTSCR', -113, 0, -1, - 'encapsulated_PostScr', -113, 0, -1, - 'LATEX ', -777, 0, -1, - 'LaTeX ', -777, 0, -1/ +SELF. *** Preset the workstation and logical unit offset to 0. IWKID=0 LUNOFF=0 *** Assume the routine will fail. IFAIL=1 *** If NTYP has been set to 0, we don't recognise anything. IF(NTYP.EQ.0)THEN PRINT *,' !!!!!! GRWKID WARNING : No workstation type'// - ' list is available; no identifier returned.' IFAIL=1 RETURN ENDIF *** Calculate the length of the workstation name. LENNAM=0 DO 30 I=1,LEN(NAME) IF(NAME(I:I).NE.' ')LENNAM=I 30 CONTINUE *** Warn if the name is blank. IF(LENNAM.EQ.0)THEN PRINT *,' !!!!!! GRWKID WARNING : The workstation type'// - ' is blank; no identifier returned.' IFAIL=1 RETURN ENDIF *** Scan the list of known workstaion names. IFOUND=0 NFOUND=0 DO 10 I=1,NTYP IF(NAME(1:LENNAM).EQ.TYPE(I)(1:LENNAM))THEN IFOUND=I NFOUND=NFOUND+1 ENDIF 10 CONTINUE *** Warn if not known. IF(NFOUND.EQ.0)THEN PRINT *,' !!!!!! GRWKID WARNING : ',NAME(1:LENNAM), - ' is not a known workstation type.' IFAIL=1 RETURN *** Inform about the choice if ambiguous. ELSEIF(NFOUND.GT.1)THEN NCPRT=1 DO 20 J=20,1,-1 IF(TYPE(IFOUND)(J:J).NE.' '.AND.NCPRT.EQ.1)NCPRT=J 20 CONTINUE PRINT *,' ------ GRWKID MESSAGE : ',NAME(1:LENNAM), - ' is an ambiguous workstation type; choosing '// - TYPE(IFOUND)(1:NCPRT)//'.' ENDIF *** Normal assignment. IWKID=ITYP(IFOUND) LUNOFF=IOFF(IFOUND) *** Determine the workstation category. CALL GQWKCA(IWKID,IERR,ICAT) IF(IERR.EQ.8)THEN IF(INOUT(IFOUND).EQ.1)THEN ICAT=2 ELSE ICAT=4 ENDIF ELSEIF(IERR.NE.0)THEN PRINT *,' !!!!!! GRWKID WARNING : ',NAME(1:LENNAM), - ' is not recognised by GKS as a valid workstation.' IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GRWKID DEBUG :'', - '' GQWKCA Error code '',I3,'', category '',I1, - '' for wktype '',I5,''.'')') IERR,ICAT,IWKID ICAT=-1 IFAIL=1 ENDIF *** Things seem to have worked. IFAIL=0 END +DECK,RAIN. SUBROUTINE RAIN(WL,R,G,B) *----------------------------------------------------------------------- * RAIN - RGB values for visible wavelengths * The spectrum is generated using approximate RGB values for * visible wavelengths between 380 nm and 780 nm. The red, * green and blue values (RGB) are assumed to vary linearly * with wavelength (for GAMMA=1). * Author: Dan Bruton (astro@tamu.edu) * Source: http://www.physics.sfasu.edu/astro/color/spectra.html * Original last updated on February 20, 1996, * (Last changed on 11/11/02) *----------------------------------------------------------------------- implicit none REAL WL,R,G,B,GAMMA,SSS *** Gamma setting. GAMMA=0.40 *** Parametrisations for various wave lengths. IF(WL.GE.380.AND.WL.LE.440)THEN R = (440-WL)/60 G = 0 B = 1 ELSEIF(WL.GE.440.AND.WL.LE.490)THEN R = 0 G = (WL-440)/50 B = 1 ELSEIF(WL.GE.490.AND.WL.LE.510)THEN R = 0 G = 1 B = (510-WL)/20 ELSEIF(WL.GE.510.AND.WL.LE.580)THEN R = (WL-510)/70 G = 1 B = 0 ELSEIF(WL.GE.580.AND.WL.LE.645)THEN R = 1 G = (645-WL)/65 B = 0 ELSEIF(WL.GE.645.AND.WL.LE.780)THEN R = 1 G = 0 B = 0 ELSEIF(WL.LT.380.OR.WL.GT.780)THEN PRINT *,' !!!!!! RAIN WARNING : Wave length outside the'// - ' visible range; set to (0,0,0).' R = 0 G = 0 B = 0 RETURN ENDIF *** Let the intensity sss fall off near the vision limits. IF(WL.GT.700)THEN SSS=0.3+0.7*(780-WL)/80 ELSEIF(WL.LT.420)THEN SSS=0.3+0.7*(WL-380)/40 ELSE SSS=1 ENDIF *** Smoothen. SSS=SQRT(SSS) *** Gamma adjust. R=(SSS*R)**GAMMA G=(SSS*G)**GAMMA B=(SSS*B)**GAMMA END +PATCH,GKSHIGZ,IF=HIGZ. C C ***************************************************************************** C * * C * The goal of this package is using HIGZ to replace GKS in GARFIELD. * C * It has been tested with SGI/UNIX and HP/UNIX systems. I don't think * C * there will be big difficulties when use other systems, since HIGZ is * C * a standard CERNLIB package. By using HIGZ, with this preliminary * C * version of HIGZ/GKS/GARFIELD, the positions of texts on screen and in * C * .ps file are not same. The text positions in ps file, by printing, are * C * mostly expected. However, it needs more work. Some functions of original* C * GARFIELD are still missing, specially the PICK functions. TEXT and PICK * C * functions will be the next steps of the work. * C * * C * Some subroutines of GARFIELD/GRAPHICS are also modified to reflect HIGZ * C * use, with flag of HIGZ. They are: * C * * C * JOBLOG, DSNOPN * C * GRINIT, GRNEXT, GRWKID, GRCLAB, GRCUPD * C * GRACWK, GRADWK, GRMETA, GROPWK, GRTERM * C * * C * Zhengyong Feng * C * University of Washington * C * Apr. 25, 1994 * C * * C ***************************************************************************** C +DECK,GCLSG. SUBROUTINE GCLSG CALL GUWK(1,0) RETURN END +DECK,GCRSG. SUBROUTINE GCRSG(ISEG) RETURN END +DECK,GDSG. SUBROUTINE GDSG(ISEG) RETURN END +DECK,GINCH. SUBROUTINE GINCH(KWKID,LCDNR,ISTAT,ICH,IPET,XMIN,XMAX, + YMIN,YMAX,LDR,DATREC) CHARACTER*80 DATREC(LDR) RETURN END +DECK,GINLC. SUBROUTINE GINLC(KWKID,LCDNR,ITR,PX,PY,IPET,XMIN,XMAX, + YMIN,YMAX,LDR,DATREC) CHARACTER*80 DATREC(LDR) RETURN END +DECK,GINPK. SUBROUTINE GINPK(KWKID,LCDNR,ISTAT,ISEG,IPICK,IPET,XMIN,XMAX, + YMIN,YMAX,LDR,DATREC) CHARACTER*80 DATREC(LDR) RETURN END +DECK,GINSK. SUBROUTINE GINSK(KWKID,LCDNR,ITR,N,PX,PY,IPET,XMIN,XMAX, + YMIN,YMAX,LENBUF,LDR,DATREC) CHARACTER*80 DATREC(LDR) DIMENSION PX(N),PY(N) RETURN END +DECK,GINVL. SUBROUTINE GINVL(KWKID,LCDNR,VAL,IPET,XMIN,XMAX, + YMIN,YMAX,VALLOW,VALHIG,LDR,DATREC) CHARACTER*80 DATREC(LDR) RETURN END +DECK,GPREC. SUBROUTINE GPREC(LI,IA,LR,RA,LS,LSTR,STR,MDL,IERR,LD,D) implicit none INTEGER LI,IA(LI),LR,LS,LSTR,MDL,IERR,LD CHARACTER*(*) STR(LS),D(LD) REAL RA(LR) IERR=0 RETURN END +DECK,GSASF. SUBROUTINE GSASF(LASF) *----------------------------------------------------------------------- * GSASF - Set aspect source flag, not available in HIGZ. * (Last changed on 30/ 6/95.) *----------------------------------------------------------------------- INTEGER LASF(13) END +DECK,GSCHSP. SUBROUTINE GSCHSP(CHSP) *----------------------------------------------------------------------- * GSCHSP - Set character spacing, not available in HIGZ. * (Last changed on 30/ 6/95.) *----------------------------------------------------------------------- REAL CHSP END +DECK,GSCHXP. SUBROUTINE GSCHXP(SZSF) *----------------------------------------------------------------------- * GSCHXP - Set character expansion factor, imitated in HIGZ. * (Last changed on 30/ 6/95.) *----------------------------------------------------------------------- REAL SZSF COMMON /CHXP/CHXP0 IF(SZSF.LT.0.)SZSF=1.0 CHXP0=SZSF CALL IGQ('CHHE',HEIT) CHH = HEIT*SZSF CALL ISCHH(CHH) END +DECK,GSTXP. SUBROUTINE GSTXP(IRL) *----------------------------------------------------------------------- * GSTXP - Set the text path, limited availability in HIGZ. * (Last changed on 30/ 6/95.) *----------------------------------------------------------------------- IF(IRL.LT.0 .OR. IRL.GT.3)IRL=0 IF(IRL.EQ.0)CALL ISTXAL(0,0) IF(IRL.EQ.1)CALL ISTXAL(3,0) IF(IRL.EQ.2)CALL ISTXAL(0,1) IF(IRL.EQ.3)CALL ISTXAL(0,3) END +DECK,GMSG. SUBROUTINE GMSG(IWK,TEXT) *----------------------------------------------------------------------- * GMSG - Displays a message. * (Last changed on 2/ 4/95.) *----------------------------------------------------------------------- CHARACTER*(*) TEXT PRINT *,' Graphics: ',TEXT END +DECK,GQACWK. SUBROUTINE GQACWK(I,IERR,NACT,IWK) *----------------------------------------------------------------------- * GQACWK - Returns the active workstation list. * (Last changed on 17/ 6/95.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,GRAPHICS. *** Initial values. NACT=0 IWK=0 IERR=0 *** Loop over the workstation table. DO 10 J=1,NWK * Found an active workstation: return number and increment counter. IF(WKSTAT(J).GE.3)THEN NACT=NACT+1 IF(NACT.EQ.I)IWK=J ENDIF 10 CONTINUE END +DECK,GQCF. SUBROUTINE GQCF(IWKTYP,IERR,NCOLS,ICOLS,NPRE) *----------------------------------------------------------------------- * GQCF - Returns information on colour facilities. * (Last changed on 2/ 4/95.) *----------------------------------------------------------------------- implicit none INTEGER IERR,NCOLS,ICOLS,NPRE,IWKTYP *** No idea, so return generous values. IERR=0 NCOLS=10 ICOLS=1 NPRE=2 END +DECK,GQCHH. SUBROUTINE GQCHH(IERR,CHH) *----------------------------------------------------------------------- * GQCHH - Returns the current character height. * (Last changed on 19/ 6/95.) *----------------------------------------------------------------------- implicit none INTEGER IERR REAL CHH *** Set the error flag. IERR=0 *** Call IGQ to determine the character size. CALL IGQ('CHHE',CHH) END +DECK,GQCHUP. SUBROUTINE GQCHUP(IERR,XUP,YUP) *----------------------------------------------------------------------- * GQCHUP - Returns the current character up vector. * (Last changed on 16/ 5/97.) *----------------------------------------------------------------------- implicit none +SEQ,CONSTANTS. INTEGER IERR REAL XUP,YUP,RANGLE *** Set the error flag. IERR=0 *** Call IGQ to obtain the text orientation. CALL IGQ('TANG',RANGLE) *** And compute up vector. XUP=COS(PI*(RANGLE+90)/180) YUP=SIN(PI*(RANGLE+90)/180) END +DECK,GQCHXP. SUBROUTINE GQCHXP(IERR,CHEXP) *----------------------------------------------------------------------- * GQCHXP - Returns the current character expansion factor. * (Last changed on 2/ 4/95.) *----------------------------------------------------------------------- implicit none INTEGER IERR REAL CHEXP *** Return by default an expansion factor of 1. IERR=0 CHEXP=1.0 END +DECK,GQCHW. SUBROUTINE GQCHW(IERR,CHW) *----------------------------------------------------------------------- * GQCHW - Returns the current width. * (Last changed on 2/ 4/95.) *----------------------------------------------------------------------- implicit none INTEGER IERR REAL CHW *** We don't know the width. IERR=1 CHW=0.01 END +DECK,GQCNTN. SUBROUTINE GQCNTN(IERR,NT) *----------------------------------------------------------------------- * GQCNTN - Returns the current normalisation transformation. * (Last changed on 19/ 6/95.) *----------------------------------------------------------------------- implicit none REAL AUX INTEGER IERR,NT *** Set the error flag. IERR=0 *** Find out what the current normalisation transformation is. CALL IGQWK(0,'NTNB',AUX) NT=NINT(AUX) END +DECK,GQDSP. SUBROUTINE GQDSP(IWKTYP,IERR,IUNIT,RX,RY,LX,LY) *----------------------------------------------------------------------- * GQDSP - Returns the screen size. * (Last changed on 6/ 4/95.) *----------------------------------------------------------------------- implicit none INTEGER IWKTYP,IERR,IUNIT,LX,LY REAL RX,RY *** We don't know this. IERR=1 *** Return some parameters nevertheless. IUNIT=1 RX=1.0 RY=1.0 LX=1 LY=1 END +DECK,GQFACI. SUBROUTINE GQFACI(IERR,ICOL) *----------------------------------------------------------------------- * GQFACI - Inquiry of current fill area colour. * (Last changed on 29/11/97.) *----------------------------------------------------------------------- implicit none INTEGER IERR,ICOL REAL RCOL *** Call the HIGZ function. CALL IGQ('FACI',RCOL) *** Convert to integer. ICOL=NINT(RCOL) *** Set the error flag. IERR=0 END +DECK,GQLVKS. SUBROUTINE GQLVKS(IERR,LEVEL) *----------------------------------------------------------------------- * GQLVKS - Returns the GKS level. * (Last changed on 17/ 6/95.) *----------------------------------------------------------------------- implicit none INTEGER IERR,LEVEL *** HIGZ is not reall a GKS, so return a non-existing value. IERR=0 LEVEL=8 END +DECK,GQLWK. SUBROUTINE GQLWK(IWKTYP,IERR,MPL,MPM,MTX,MFA,MPA,MXCOLI) *----------------------------------------------------------------------- * GQLWK - Returns properties of the workstation. * (Last changed on 2/ 4/95.) *----------------------------------------------------------------------- implicit none INTEGER IWKTYP,IERR,MPL,MPM,MTX,MFA,MPA,MXCOLI *** Not known, but we don't really need accurate information either. IERR=0 *** Return generous settings. MPL=100 MPM=100 MTX=100 MFA=100 MPA=100 MXCOLI=100 END +DECK,GQNT. SUBROUTINE GQNT(NT,IERR,WINDOW,VIEWPT) *----------------------------------------------------------------------- * GQNT - Returns information about normalisation transformations. * (Last changed on 19/ 6/95.) *----------------------------------------------------------------------- implicit none REAL WINDOW(4),VIEWPT(4) INTEGER IERR,NT *** Call IGQWK to find out. CALL IGQWK(0,'NTWN',WINDOW) CALL IGQWK(0,'NTVP',VIEWPT) *** Set the error indicator. IERR=0 END +DECK,GQOPS. SUBROUTINE GQOPS(IOPS) *----------------------------------------------------------------------- * GQOPS - Returns the GKS operating state. * (Last changed on 17/ 6/95.) *----------------------------------------------------------------------- INTEGER IOPS,IERR1,IERR2,NACT,NOP,IWK *** Count number of open and active workstations. CALL GQACWK(0,IERR1,NACT,IWK) CALL GQOPWK(0,IERR2,NOP,IWK) *** Depending on the result, return the state. IF(NACT.GE.1)THEN IOPS=3 ELSEIF(NOP.GE.1)THEN IOPS=2 ELSE IOPS=1 ENDIF END +DECK,GQOPWK. SUBROUTINE GQOPWK(I,IERR,NOP,IWK) *----------------------------------------------------------------------- * GQOPWK - Returns the list of open workstations. * (Last changed on 17/ 6/95.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,GRAPHICS. *** Initial values. NOP=0 IWK=0 IERR=0 *** Loop over the workstation table. DO 10 J=1,NWK * Found an active workstation: return number and increment counter. IF(WKSTAT(J).GE.2)THEN NOP=NOP+1 IF(NOP.EQ.I)IWK=J ENDIF 10 CONTINUE END +DECK,GQTXAL. SUBROUTINE GQTXAL(IERR,ITXALH,ITXALV) *----------------------------------------------------------------------- * GQTXAL - Returns the current text alignment. * (Last changed on 19/ 6/95.) *----------------------------------------------------------------------- REAL RVAL(2) INTEGER IERR,ITXALH,ITXALV *** Set the error flag. IERR=0 *** Inquire. CALL IGQ('TXAL',RVAL) *** Set the alignments. ITXALH=RVAL(1) ITXALV=RVAL(2) END +DECK,GQTXX. SUBROUTINE GQTXX(IWK,X,Y,TEXT,IERR,CPX,CPY,XBOX,YBOX) *----------------------------------------------------------------------- * GQTXX - Returns the text extent, HIGZ version. Currently not able * to get the box directly from HIGZ, but try to do something * reasonable using the character height. * (Last changed on 28/ 1/00.) *----------------------------------------------------------------------- implicit none +SEQ,PRINTPLOT. REAL X,Y,CPX,CPY,XBOX(*),YBOX(*),CHH,CHW,XUP,YUP,XOFF,YOFF,PHI, - XNEW,YNEW INTEGER IWK,IERR,ITXALH,ITXALV,I CHARACTER*(*) TEXT *** Try to get some reasonable estimate of the character size. CALL GQCHH(IERR,CHH) IF(IERR.NE.0)CHH=0.02 IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GQTXX DEBUG : Height: '', - F10.3,'', ierr='',I5)') CHH,IERR CALL GQCHW(IERR,CHW) IF(IERR.NE.0)CHW=0.8*CHH IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GQTXX DEBUG : Width: '', - F10.3,'', ierr='',I5)') CHW,IERR *** Find out what the alignment is like. CALL GQTXAL(IERR,ITXALH,ITXALV) *** Compute from this what the x and y offsets are. IF(ITXALH.EQ.2)THEN XOFF=0.5*CHW*LEN(TEXT) ELSEIF(ITXALH.EQ.3)THEN XOFF=CHW*LEN(TEXT) ELSE XOFF=0 ENDIF IF(ITXALV.EQ.1.OR.ITXALV.EQ.2)THEN YOFF=CHH ELSEIF(ITXALV.EQ.3)THEN YOFF=0.5*CHH ELSE YOFF=0 ENDIF *** Construct a first box. XBOX(1)=-XOFF XBOX(2)=-XOFF XBOX(3)=CHW*LEN(TEXT)-XOFF XBOX(4)=CHW*LEN(TEXT)-XOFF YBOX(1)=-YOFF-0.2*CHH YBOX(2)=CHH-YOFF YBOX(3)=CHH-YOFF YBOX(4)=-YOFF-0.2*CHH *** Determine the character up vector. CALL GQCHUP(IERR,XUP,YUP) IF(IERR.NE.0.OR.XUP**2+YUP**2.LE.0)THEN XUP=0 YUP=1 ENDIF PHI=ATAN2(YUP,XUP) *** And rotate the box in place, translating it too. DO 10 I=1,4 XNEW=+SIN(PHI)*XBOX(I)+COS(PHI)*YBOX(I) YNEW=-COS(PHI)*XBOX(I)+SIN(PHI)*YBOX(I) XBOX(I)=XNEW+X YBOX(I)=YNEW+Y 10 CONTINUE *** Definre the concatenation point. CPX=XBOX(4)+XOFF CPY=YBOX(4)+YOFF *** And set the error flag to "success". IERR=0 *** Debugging output. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GQTXX DEBUG :'', - '' String: "'',A,''"''/ - 26X,''x-box: '',4F10.3/26X,''y-box: '',4F10.3)') - TEXT,(XBOX(I),I=1,4),(YBOX(I),I=1,4) END +DECK,GQWKC. SUBROUTINE GQWKC(IWK,IERR,ICONID,IWKTYP) *----------------------------------------------------------------------- * GQWKC - Returns connection and type of workstation IWK. * (Last changed on 17/ 6/95.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,GRAPHICS. IWKTYP=0 ICONID=0 *** Return if this workstation is out of range. IF(IWK.LT.1.OR.IWK.GT.NWK)THEN IERR=20 RETURN ENDIF *** Make sure the workstation is actually open. IF(WKSTAT(IWK).LT.2)THEN IERR=25 RETURN ENDIF *** Now return the information. ICONID=WKCON(IWK) IWKTYP=WKID(IWK) IERR=0 END +DECK,GQWKCA. SUBROUTINE GQWKCA(IWKID,IERR,ICAT) *----------------------------------------------------------------------- * GQWKCA - Returns the workstation category. * (Last changed on 5/ 2/97.) *----------------------------------------------------------------------- INTEGER IWKID,IERR,ICAT *** Initial values. ICAT=0 IERR=0 *** No output. IF(IWKID.EQ.-1)THEN ICAT=2 *** Described in higzwindows.dat ELSEIF(IWKID.GE.0.AND.IWKID.LE.10)THEN ICAT=2 *** Falco. ELSEIF(IWKID.GE.7878)THEN ICAT=2 *** xterm. ELSEIF(IWKID.GE.7879)THEN ICAT=2 *** Various PS formats. ELSEIF(IWKID.EQ. -111.OR.IWKID.EQ. -112.OR. - IWKID.EQ. -3111.OR.IWKID.EQ. -3112.OR. - IWKID.EQ. -99111.OR.IWKID.EQ. -99112.OR. - IWKID.EQ.-100111.OR.IWKID.EQ.-100112.OR. - IWKID.EQ.-200111.OR.IWKID.EQ.-200112.OR. - IWKID.EQ.-300111.OR.IWKID.EQ.-300112.OR. - IWKID.EQ.-300111.OR.IWKID.EQ.-300112)THEN ICAT=4 *** EPS format. ELSEIF(IWKID.EQ.-113)THEN ICAT=4 *** LaTeX format. ELSEIF(IWKID.EQ.-777)THEN ICAT=4 *** Other values are not known. ELSE IERR=1 ENDIF END +DECK,GQWKDU. SUBROUTINE GQWKDU(I,IERR,IDEFM,IREGM,IEMPTY,IFRAME) *----------------------------------------------------------------------- * GQWKDU - Returns deferral and update state for a workstation. * (Last changed on 27/10/11.) *----------------------------------------------------------------------- INTEGER I,IERR,IDEFM,IREGM,IEMPTY,IFRAME IERR=0 IDEFM=0 IREGM=0 IEMPTY=0 IFRAME=0 END +DECK,GQWKM. SUBROUTINE GQWKM(IERR,MXOPWK,MXACWK,MXWKAS) *----------------------------------------------------------------------- * GQWKM - Returns workstation maxima. * (Last changed on 2/ 4/95.) *----------------------------------------------------------------------- INTEGER IERR,MXOPWK,MXACWK,MXWKAS IERR=0 MXOPWK=10 MXACWK=10 MXWKAS=10 END +DECK,GQWKS. SUBROUTINE GQWKS(IWK,IERR,ISTATE) *----------------------------------------------------------------------- * GQWKS - Returns the state of a workstation. * (Last changed on 29/10/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,GRAPHICS. INTEGER IWK,IERR,ISTATE *** Default state: not active. ISTATE=-1 IERR=0 *** Check validity of workstation number. IF(IWK.LT.1.OR.IWK.GT.NWK)THEN IERR=20 RETURN ENDIF *** Make sure the workstation is actually open. IF(WKSTAT(IWK).LT.2)THEN IERR=25 RETURN ENDIF *** Look in workstation table to determine the state. IF(WKSTAT(IWK).LE.2)THEN ISTATE=0 ELSE ISTATE=1 ENDIF END +DECK,GRQCH. SUBROUTINE GRQCH(IWKCH,IDEVCH,IERR,ICHOIC) *----------------------------------------------------------------------- * GRQCH - Request choice input. * (Last changed on 2/ 4/95.) *----------------------------------------------------------------------- IERR=1 ICHOIC=0 END +DECK,GRQPK. SUBROUTINE GRQPK(IWKPK,IDEVPK,IERR,ISGNA,IPCID) *----------------------------------------------------------------------- * GRQPK - Request pick input. * (Last changed on 2/ 4/95.) *----------------------------------------------------------------------- IERR=1 ISGNA=0 IPCID=0 END +DECK,GRQVL. SUBROUTINE GRQVL(IWKVL,IDEVVL,IERR,VAL) *----------------------------------------------------------------------- * GRQVL - Requests valuator input. * (Last changed on 2/ 4/95.) *----------------------------------------------------------------------- IERR=1 VAL=0.0 end +DECK,GSDS. SUBROUTINE GSDS(IWK,IDEF,IUPD) *----------------------------------------------------------------------- * GSDS - Set deferral and update state. * (Last changed on 2/ 4/95.) *----------------------------------------------------------------------- END +DECK,GSDTEC. SUBROUTINE GSDTEC(I,J) *----------------------------------------------------------------------- * GSDTEC - Segment detectability. * (Last changed on 2/ 4/95.) *----------------------------------------------------------------------- END +DECK,GSPA. SUBROUTINE GSPA(X,Y) *----------------------------------------------------------------------- * GSPA - Sets fill area pattern pattern size. * (Last changed on 2/ 4/95.) *----------------------------------------------------------------------- END +DECK,GSPARF. SUBROUTINE GSPARF(X,Y) *----------------------------------------------------------------------- * GSPARF - Sets fill area pattern reference point. * (Last changed on 2/ 4/95.) *----------------------------------------------------------------------- END +DECK,GSPKID. SUBROUTINE GSPKID(ID) *----------------------------------------------------------------------- * GSPKID - Sets the pick identifier. * (Last changed on 2/ 4/95.) *----------------------------------------------------------------------- END +DECK,GSVPIP. SUBROUTINE GSVPIP(I,J,K) *----------------------------------------------------------------------- * GSVPIP - Sets the viewport input priority. * (Last changed on 2/ 4/95.) *----------------------------------------------------------------------- END +DECK,SGFLAG. SUBROUTINE SGFLAG *----------------------------------------------------------------------- * SGFLAG - Sets GFLAG in HIGZ according to the workstations active. * (Last changed on 8/ 1/08.) *----------------------------------------------------------------------- implicit none +SEQ,PRINTPLOT C*KEEP,HIFLAG. C*CMZ : 1.21/05 16/06/94 14.37.23 by O.Couet *-- Author : LOGICAL GFLAG,GLFLAG,ZFLAG,PFLAG,MFLAG,TFLAG, - ASFLAG,GRFLAG,AXFLAG,CFLAG COMMON /HIFLAG/ GFLAG,GLFLAG,ZFLAG,PFLAG,MFLAG,TFLAG, - ASFLAG,GRFLAG,AXFLAG,CFLAG INTEGER IOPSTA,IERR,NACT,IWK,I,IDUM,ICONID,IWKTYP,ICAT *** Disable temporarily. C return *** Initial setting. GFLAG=.FALSE. *** Determine Operating State value. CALL GQOPS(IOPSTA) *** For states less than 'workstation active' flag is off. IF(IOPSTA.LT.3)THEN GFLAG=.FALSE. *** If a workstation is active, see whether there is an interactive one. ELSE GFLAG=.FALSE. CALL GQACWK(0,IERR,NACT,IWK) DO 10 I=1,NACT CALL GQACWK(I,IERR,IDUM,IWK) CALL GQWKC(IWK,IERR,ICONID,IWKTYP) CALL GQWKCA(IWKTYP,IERR,ICAT) IF(ICAT.EQ.2)GFLAG=.TRUE. 10 CONTINUE ENDIF *** Debugging output. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ SGFLAG DEBUG :'', - '' Setting GFLAG to '',L1,''.'')') GFLAG END +PATCH,PROJECTION. +DECK,PLAARR. SUBROUTINE PLAARR(XX0,YY0,ZZ0,DX,DY,DZ) *----------------------------------------------------------------------- * PLAARR - Plots an arrow in projection. * (Last changed on 24/ 5/99.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,GRAPHICS. +SEQ,PARAMETERS. REAL XX0,YY0,ZZ0,DX,DY,DZ DOUBLE PRECISION XPL(3),YPL(3),XAUX(3),YAUX(3), - X0D,Y0D,Z0D,X1D,Y1D,Z1D,X0,Y0,X1,Y1,PHIARR,ALEN *** Copy to double precision. X0D=DBLE(XX0) Y0D=DBLE(YY0) Z0D=DBLE(ZZ0) X1D=DBLE(XX0+DX) Y1D=DBLE(YY0+DY) Z1D=DBLE(ZZ0+DZ) *** Project begin and end point. CALL PLACOO(X0D,Y0D,Z0D,X0,Y0) CALL PLACOO(X1D,Y1D,Z1D,X1,Y1) *** Straight line of the arrow. XPL(1)=X0 YPL(1)=Y0 XPL(2)=X1 YPL(2)=Y1 * Plot in polar coordinates. IF(PRVIEW.EQ.'R-PHI')THEN CALL CF2RTC(XPL,YPL,XAUX,YAUX,2) CALL GPL2(2,XAUX,YAUX) * Or in Cartesian coordinates. ELSE CALL GPL2(2,XPL,YPL) ENDIF *** Make the arrow top. PHIARR=ATAN2(Y1-Y0,X1-X0) ALEN=SQRT((X1D-X0D)**2+(Y1D-Y0D)**2+(Z1D-Z0D)**2) XPL(1)=X1-ALEN*ARRLEN*COS(DBLE(PHIARR)+ARRANG) YPL(1)=Y1-ALEN*ARRLEN*SIN(DBLE(PHIARR)+ARRANG) XPL(2)=X1 YPL(2)=Y1 XPL(3)=X1-ALEN*ARRLEN*COS(DBLE(PHIARR)-ARRANG) YPL(3)=Y1-ALEN*ARRLEN*SIN(DBLE(PHIARR)-ARRANG) * Plot in polar coordinates. IF(PRVIEW.EQ.'R-PHI')THEN CALL CF2RTC(XPL,YPL,XAUX,YAUX,3) CALL GPL2(3,XAUX,YAUX) * Or in Cartesian coordinates. ELSE CALL GPL2(3,XPL,YPL) ENDIF END +DECK,PLAGPL. SUBROUTINE PLAGPL(NPL,XPL,YPL,ZPL) *----------------------------------------------------------------------- * PLAGPL - Plots a curve through the visible parts. * (Last changed on 28/10/09.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PARAMETERS. +SEQ,PRINTPLOT. INTEGER NPL DOUBLE PRECISION XPL(NPL),YPL(NPL),ZPL(NPL), - XAUX(MXLIST),YAUX(MXLIST) *** Identification and debugging. IF(LIDENT)PRINT *,' /// ROUTINE PLAGPL ///' IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLAGPL DEBUG : Drawing '', - I4,'' points in projection '',A)') NPL,PRVIEW *** Select the plotting routine, x-y view. IF(PRVIEW.EQ.'X-Y')THEN CALL GRLIN2(NPL,XPL,YPL) * r-phi view: transform from internal to Cartesian coordinates. ELSEIF(PRVIEW.EQ.'R-PHI')THEN IF(NPL.GT.MXLIST)THEN PRINT *,' !!!!!! PLAGPL WARNING : Array dimensions'// - ' insufficient to plot a vector; not plotted.' RETURN ENDIF CALL CF2RTC(XPL,YPL,XAUX,YAUX,NPL) CALL GRLIN2(NPL,XAUX,YAUX) * x-z view. ELSEIF(PRVIEW.EQ.'X-Z')THEN CALL GRLIN2(NPL,XPL,ZPL) * y-z view. ELSEIF(PRVIEW.EQ.'Y-Z')THEN CALL GRLIN2(NPL,YPL,ZPL) * cut view. ELSEIF(PRVIEW.EQ.'CUT')THEN CALL PLAGPC(NPL,XPL,YPL,ZPL) * 3D view. ELSEIF(PRVIEW.EQ.'3D'.OR.PRVIEW.EQ.'NEBEM')THEN CALL PLAGPP(NPL,XPL,YPL,ZPL) * Unknown. ELSE PRINT *,' !!!!!! PLAGPL WARNING : Received unknown'// - ' projection type '//PRVIEW ENDIF END +DECK,PLAGPM. SUBROUTINE PLAGPM(NPL,XPL,YPL,ZPL) *----------------------------------------------------------------------- * PLAGPM - Plots markers which are visible. * (Last changed on 28/10/09.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PARAMETERS. +SEQ,PRINTPLOT. INTEGER NPL DOUBLE PRECISION XPL(NPL),YPL(NPL),ZPL(NPL), - XAUX(MXLIST),YAUX(MXLIST) *** Identification and debugging. IF(LIDENT)PRINT *,' /// ROUTINE PLAGPM ///' IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLAGPM DEBUG : Marking '', - I4,'' points in projection '',A)') NPL,PRVIEW *** Select the plotting routine, x-y view. IF(PRVIEW.EQ.'X-Y')THEN CALL GPM2(NPL,XPL,YPL) * r-phi view: transform from internal to Cartesian coordinates. ELSEIF(PRVIEW.EQ.'R-PHI')THEN IF(NPL.GT.MXLIST)THEN PRINT *,' !!!!!! PLAGPM WARNING : Array dimensions'// - ' insufficient to plot a vector; not plotted.' RETURN ENDIF CALL CF2RTC(XPL,YPL,XAUX,YAUX,NPL) CALL GPM2(NPL,XAUX,YAUX) * x-z view. ELSEIF(PRVIEW.EQ.'X-Z')THEN CALL GPM2(NPL,XPL,ZPL) * y-z view. ELSEIF(PRVIEW.EQ.'Y-Z')THEN CALL GPM2(NPL,YPL,ZPL) * cut view. ELSEIF(PRVIEW.EQ.'CUT')THEN CALL PLAGMC(NPL,XPL,YPL,ZPL) * 3D view. ELSEIF(PRVIEW.EQ.'3D'.OR.PRVIEW.EQ.'NEBEM')THEN CALL PLAGMP(NPL,XPL,YPL,ZPL) * Unknown. ELSE PRINT *,' !!!!!! PLAGPM WARNING : Received unknown'// - ' projection type '//PRVIEW ENDIF END +DECK,PLAGPC. SUBROUTINE PLAGPC(NPL,XPL,YPL,ZPL) *----------------------------------------------------------------------- * PLAGPC - Plots a curve through the visible parts. * (Last changed on 8/10/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CONSTANTS. +SEQ,PARAMETERS. +SEQ,SOLIDS. +SEQ,GRAPHICS. +SEQ,PRINTPLOT. INTEGER NPL,I,NOUT,IFAIL DOUBLE PRECISION XPL(NPL),YPL(NPL),ZPL(NPL), - XOUT(MXLIST),YOUT(MXLIST),X0,Y0,Z0,X1,Y1,Z1 LOGICAL CURIN,LASTIN *** No plotting for too few points, IF(NPL.LE.1)RETURN *** Loop over the input array. NOUT=0 DO 10 I=1,NPL-1 * Copy the current and last point. X0=XPL(I) Y0=YPL(I) Z0=ZPL(I) LASTIN=X0.GE.GXMIN.AND.X0.LE.GXMAX.AND. - Y0.GE.GYMIN.AND.Y0.LE.GYMAX.AND. - Z0.GE.GZMIN.AND.Z0.LE.GZMAX X1=XPL(I+1) Y1=YPL(I+1) Z1=ZPL(I+1) CURIN=X1.GE.GXMIN.AND.X1.LE.GXMAX.AND. - Y1.GE.GYMIN.AND.Y1.LE.GYMAX.AND. - Z1.GE.GZMIN.AND.Z1.LE.GZMAX * Compute fragment of this that fits in the frame. CALL CLIP3D(X0,Y0,Z0,X1,Y1,Z1, - GXMIN,GYMIN,GZMIN,GXMAX,GYMAX,GZMAX,IFAIL) * If fully out (IFAIL=1) then skip the rest. IF(IFAIL.NE.0)THEN GOTO 10 * If last point was 'in', add the current point, plot if now 'out'. ELSEIF(LASTIN)THEN IF(NOUT.EQ.0)THEN NOUT=NOUT+1 CALL PLACOO(X0,Y0,Z0,XOUT(NOUT),YOUT(NOUT)) ELSEIF(NOUT.GE.MXLIST)THEN CALL GPL2(NOUT,XOUT,YOUT) XOUT(1)=XOUT(NOUT) YOUT(1)=YOUT(NOUT) NOUT=1 ENDIF NOUT=NOUT+1 CALL PLACOO(X1,Y1,Z1,XOUT(NOUT),YOUT(NOUT)) IF(.NOT.CURIN)THEN IF(NOUT.GT.1)CALL GPL2(NOUT,XOUT,YOUT) NOUT=0 ENDIF * If the last point was 'out', start a new line, plot if now 'out'. ELSE IF(NOUT.GT.1)CALL GPL2(NOUT,XOUT,YOUT) CALL PLACOO(X0,Y0,Z0,XOUT(1),YOUT(1)) CALL PLACOO(X1,Y1,Z1,XOUT(2),YOUT(2)) NOUT=2 IF(.NOT.CURIN)THEN CALL GPL2(NOUT,XOUT,YOUT) NOUT=0 ENDIF ENDIF 10 CONTINUE *** Plot what remains in the buffer. IF(NOUT.GE.2)CALL GPL2(NOUT,XOUT,YOUT) END +DECK,PLAGMC. SUBROUTINE PLAGMC(NPL,XPL,YPL,ZPL) *----------------------------------------------------------------------- * PLAGMC - Plots markers on a cut plot. * (Last changed on 29/ 9/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CONSTANTS. +SEQ,PARAMETERS. +SEQ,SOLIDS. +SEQ,GRAPHICS. +SEQ,PRINTPLOT. INTEGER NPL,I DOUBLE PRECISION XPL(NPL),YPL(NPL),ZPL(NPL),XCUR(1),YCUR(1) *** Copy the curve, projecting each point. IF(NPL.GT.MXLIST)THEN PRINT *,' !!!!!! PLAGMC WARNING : Curve contains too many'// - ' points ; curve not plotted.' RETURN ENDIF DO 10 I=1,NPL IF(XPL(I).GE.GXMIN.AND.XPL(I).LE.GXMAX.AND. - YPL(I).GE.GYMIN.AND.YPL(I).LE.GYMAX.AND. - ZPL(I).GE.GZMIN.AND.ZPL(I).LE.GZMAX)THEN CALL PLACOO(XPL(I),YPL(I),ZPL(I),XCUR(1),YCUR(1)) CALL GPM2(1,XCUR,YCUR) ENDIF 10 CONTINUE END +DECK,PLAGPP. SUBROUTINE PLAGPP(NPL,XPL,YPL,ZPL) *----------------------------------------------------------------------- * PLAGPP - Plots a curve through the visible parts. * (Last changed on 26/ 7/10.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CONSTANTS. +SEQ,PARAMETERS. +SEQ,SOLIDS. +SEQ,GRAPHICS. +SEQ,PRINTPLOT. INTEGER NPL,I,J,K,L,NPL1,ICOL,IFAIL,NCUR,NNEW,NL,IQMIN,I0 DOUBLE PRECISION XPL(NPL),YPL(NPL),ZPL(NPL), - XPL1(MXEDGE),YPL1(MXEDGE),ZPL1(MXEDGE), - XCUR(2*MXLIST),YCUR(2*MXLIST),ZCUR(2*MXLIST), - XNEW(2*MXLIST),YNEW(2*MXLIST),ZNEW(2*MXLIST), - XL(MXEDGE),YL(MXEDGE),ZL(MXEDGE),QL(MXEDGE), - APL,BPL,CPL,DPL,XC,YC,ZC,XAUX,YAUX,ZAUX,QMIN,QAUX, - X0,Y0,Z0,X1,Y1,Z1,EPSX,EPSY,EPSZ LOGICAL DRAW(2*MXLIST),DRAWN(2*MXLIST),INSIDE,EDGE,CROSS,CURIN, - LASTIN *** Set tolerances. IF(LEPSG)THEN EPSX=EPSGX EPSY=EPSGY EPSZ=EPSGZ ELSE EPSX=1.0D-8*ABS(GXMAX-GXMIN) EPSY=1.0D-8*ABS(GYMAX-GYMIN) EPSZ=1.0D-8*ABS(GZMAX-GZMIN) IF(EPSX.LE.0)EPSX=1.0D-8 IF(EPSY.LE.0)EPSY=1.0D-8 IF(EPSZ.LE.0)EPSZ=1.0D-8 ENDIF *** Copy the curve, section by section, set initial number of points. NCUR=0 * Loop over the points. DO 10 I=1,NPL-1 * Make copies of the current and the last point. X0=XPL(I) Y0=YPL(I) Z0=ZPL(I) LASTIN=X0.GE.GXMIN.AND.X0.LE.GXMAX.AND. - Y0.GE.GYMIN.AND.Y0.LE.GYMAX.AND. - Z0.GE.GZMIN.AND.Z0.LE.GZMAX X1=XPL(I+1) Y1=YPL(I+1) Z1=ZPL(I+1) CURIN=X1.GE.GXMIN.AND.X1.LE.GXMAX.AND. - Y1.GE.GYMIN.AND.Y1.LE.GYMAX.AND. - Z1.GE.GZMIN.AND.Z1.LE.GZMAX * Adjust this piece to the dimensions of the box. CALL CLIP3D(X0,Y0,Z0,X1,Y1,Z1, - GXMIN,GYMIN,GZMIN,GXMAX,GYMAX,GZMAX,IFAIL) * If outside the box, skip the section altogether. IF(IFAIL.NE.0)THEN GOTO 10 * Crossing of box, last point in: add current point. ELSEIF(LASTIN)THEN IF(NCUR.EQ.0)THEN NCUR=1 CALL PLACO3(X0,Y0,Z0,XCUR(NCUR),YCUR(NCUR),ZCUR(NCUR)) ENDIF IF(NCUR.GE.2*MXLIST)GOTO 3010 DRAW(NCUR)=.TRUE. NCUR=NCUR+1 CALL PLACO3(X1,Y1,Z1,XCUR(NCUR),YCUR(NCUR),ZCUR(NCUR)) DRAW(NCUR)=CURIN * Crossing of box, last not in: add entry and exit. ELSE IF(NCUR.GT.0)DRAW(NCUR)=.FALSE. IF(NCUR.GE.2*MXLIST)GOTO 3010 NCUR=NCUR+1 CALL PLACO3(X0,Y0,Z0,XCUR(NCUR),YCUR(NCUR),ZCUR(NCUR)) DRAW(NCUR)=.TRUE. IF(NCUR.GE.2*MXLIST)GOTO 3010 NCUR=NCUR+1 CALL PLACO3(X1,Y1,Z1,XCUR(NCUR),YCUR(NCUR),ZCUR(NCUR)) DRAW(NCUR)=CURIN ENDIF 10 CONTINUE *** See whether we have collected anything. IF(NCUR.LT.2)RETURN *** Load all plot panels to see whether there is a crossing. DO 20 J=1,NQ CALL PLABU2('READ',IQ(J),NPL1,XPL1,YPL1,ZPL1,APL,BPL,CPL,DPL, - ICOL,IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! PLAGPP WARNING : Unable to load a'// - ' plot panel ; curve not plotted.' RETURN ENDIF IF(NPL1.LE.2)GOTO 20 * Skip this panel if it is almost normal. IF(ABS(CPL).LT.1.0D-4*SQRT(APL**2+BPL**2))GOTO 20 *** Go over all line segments. NNEW=0 DO 30 I=1,NCUR-1 * For invisible and point segments, just register the starting point. IF((.NOT.DRAW(I)).OR. - (ABS(XCUR(I+1)-XCUR(I)).LE.EPSX.AND. - ABS(YCUR(I+1)-YCUR(I)).LE.EPSY.AND. - ABS(ZCUR(I+1)-ZCUR(I)).LE.EPSZ))THEN IF(NNEW+1.GT.2*MXLIST)THEN PRINT *,' !!!!!! PLAGPP WARNING : Too many'// - ' points generated on curve; not plotted.' RETURN ENDIF IF(NNEW.GE.2*MXLIST)GOTO 3020 NNEW=NNEW+1 XNEW(NNEW)=XCUR(I) YNEW(NNEW)=YCUR(I) ZNEW(NNEW)=ZCUR(I) DRAWN(NNEW)=.FALSE. GOTO 30 ENDIF * Establish the list of crossings. NL=2 XL(1)=XCUR(I) YL(1)=YCUR(I) ZL(1)=ZCUR(I) QL(1)=0 XL(2)=XCUR(I+1) YL(2)=YCUR(I+1) ZL(2)=ZCUR(I+1) QL(2)=1 * Check for crossings in the plane. CALL PLALIN( - XCUR(I) ,YCUR(I) ,ZCUR(I) , - XCUR(I+1),YCUR(I+1),ZCUR(I+1), - XPL1(1) ,YPL1(1) ,ZPL1(1) , - APL,BPL,CPL,XC,YC,ZC,IFAIL) IF(IFAIL.EQ.0)THEN CALL INTERD(NPL1,XPL1,YPL1,XC,YC,INSIDE,EDGE) IF(INSIDE)THEN IF(NL+1.GT.MXEDGE)THEN PRINT *,' !!!!!! PLAGPP WARNING : Too many'// - ' crossings between curve and surface'// - ' elements; not plotted.' RETURN ENDIF NL=NL+1 XL(NL)=XC YL(NL)=YC ZL(NL)=(DPL-APL*XL(NL)-BPL*YL(NL))/CPL CALL PLALAM(XCUR(I),XL(NL),XCUR(I+1), - YCUR(I),YL(NL),YCUR(I+1),QL(NL)) ENDIF ENDIF * Check for crossings on the edges. DO 40 K=1,NPL1 CALL CRSPND( - XPL1(1+MOD(K-1,NPL1)),YPL1(1+MOD(K-1,NPL1)), - XPL1(1+MOD(K ,NPL1)),YPL1(1+MOD(K ,NPL1)), - XCUR(I),YCUR(I),XCUR(I+1),YCUR(I+1), - XC,YC,CROSS) IF(.NOT.CROSS)GOTO 40 IF(NL+1.GT.MXEDGE)THEN PRINT *,' !!!!!! PLAGPP WARNING : Too many crossings'// - ' between curve and surface elements; not plotted.' RETURN ENDIF NL=NL+1 XL(NL)=XC YL(NL)=YC CALL PLALAM(XCUR(I),XL(NL),XCUR(I+1),YCUR(I),YL(NL),YCUR(I+1), - QL(NL)) ZL(NL)=ZCUR(I)+QL(NL)*(ZCUR(I+1)-ZCUR(I)) 40 CONTINUE * Sort the list by using the lambda's. DO 60 K=1,NL-1 QMIN=QL(K) IQMIN=K DO 50 L=K+1,NL IF(QL(L).LT.QMIN)THEN IQMIN=L QMIN=QL(L) ENDIF 50 CONTINUE IF(K.NE.IQMIN)THEN XAUX=XL(K) YAUX=YL(K) ZAUX=ZL(K) QAUX=QL(K) XL(K)=XL(IQMIN) YL(K)=YL(IQMIN) ZL(K)=ZL(IQMIN) QL(K)=QL(IQMIN) XL(IQMIN)=XAUX YL(IQMIN)=YAUX ZL(IQMIN)=ZAUX QL(IQMIN)=QAUX ENDIF 60 CONTINUE * Copy the points to the new vector. DO 70 K=1,NL-1 IF(NNEW+1.GT.2*MXLIST)THEN PRINT *,' !!!!!! PLAGPP WARNING : Too many points'// - ' generated on curve; not plotted.' RETURN ENDIF IF(NNEW.GE.2*MXLIST)GOTO 3020 NNEW=NNEW+1 XNEW(NNEW)=XL(K) YNEW(NNEW)=YL(K) ZNEW(NNEW)=ZL(K) CALL INTERD(NPL1,XPL1,YPL1,(XL(K)+XL(K+1))/2,(YL(K)+YL(K+1))/2, - INSIDE,EDGE) IF(.NOT.(INSIDE.OR.EDGE).OR. - (ZL(K)+ZL(K+1))/2.GE.(DPL-APL*(XL(K)+XL(K+1))/2- - BPL*(YL(K)+YL(K+1))/2)/CPL)THEN DRAWN(NNEW)=.TRUE. ELSE DRAWN(NNEW)=.FALSE. ENDIF 70 CONTINUE * Next line segment. 30 CONTINUE * Place the last point of this section in the list. IF(NNEW.GE.2*MXLIST)GOTO 3020 NNEW=NNEW+1 XNEW(NNEW)=XCUR(NCUR) YNEW(NNEW)=YCUR(NCUR) ZNEW(NNEW)=ZCUR(NCUR) DRAWN(NNEW)=.TRUE. * Copy this list back to the main curve, eliminating invisible parts. IF(DRAWN(1))THEN NCUR=1 XCUR(NCUR)=XNEW(1) YCUR(NCUR)=YNEW(1) ZCUR(NCUR)=ZNEW(1) DRAW(NCUR)=DRAWN(1) ELSE NCUR=0 ENDIF DO 80 I=2,NNEW IF(.NOT.DRAWN(I).AND..NOT.DRAWN(I-1))GOTO 80 IF(NCUR.GE.2*MXLIST)GOTO 3010 NCUR=NCUR+1 XCUR(NCUR)=XNEW(I) YCUR(NCUR)=YNEW(I) ZCUR(NCUR)=ZNEW(I) DRAW(NCUR)=DRAWN(I) 80 CONTINUE * Next panel. 20 CONTINUE *** Plot the remaining line. I0=1 DO 100 I=1,NCUR-1 IF(.NOT.DRAW(I))THEN IF(I-I0+1.GE.2)CALL GPL2(I-I0+1,XCUR(I0),YCUR(I0)) I0=I+1 ENDIF 100 CONTINUE IF(NCUR-I0+1.GE.2)CALL GPL2(NCUR-I0+1,XCUR(I0),YCUR(I0)) RETURN *** Error processing. 3010 CONTINUE PRINT *,' !!!!!! PLAGPP WARNING : Curve contains too many'// - ' points ; curve not plotted.' RETURN 3020 CONTINUE PRINT *,' !!!!!! PLAGPP WARNING : Too many points'// - ' generated on curve; not plotted.' END +DECK,PLAGMP. SUBROUTINE PLAGMP(NPL,XPL,YPL,ZPL) *----------------------------------------------------------------------- * PLAGMP - Plots markers at visible locations. * (Last changed on 8/10/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CONSTANTS. +SEQ,PARAMETERS. +SEQ,SOLIDS. +SEQ,GRAPHICS. +SEQ,PRINTPLOT. INTEGER NPL,I,J,NPL1,ICOL,IFAIL,NCUR DOUBLE PRECISION XPL(NPL),YPL(NPL),ZPL(NPL), - XPL1(MXEDGE),YPL1(MXEDGE),ZPL1(MXEDGE), - XCUR(MXLIST),YCUR(MXLIST),ZCUR(MXLIST), - APL,BPL,CPL,DPL LOGICAL DRAW(MXLIST),INSIDE,EDGE *** Copy the curve, projecting each point. IF(NPL.GT.MXLIST)THEN PRINT *,' !!!!!! PLAGMP WARNING : Curve contains too many'// - ' points ; curve not plotted.' RETURN ENDIF DO 10 I=1,NPL CALL PLACO3(XPL(I),YPL(I),ZPL(I),XCUR(I),YCUR(I),ZCUR(I)) DRAW(I)=XPL(I).GE.GXMIN.AND.XPL(I).LE.GXMAX.AND. - YPL(I).GE.GYMIN.AND.YPL(I).LE.GYMAX.AND. - ZPL(I).GE.GZMIN.AND.ZPL(I).LE.GZMAX 10 CONTINUE NCUR=NPL *** Load all plot panels to see whether there is a crossing. DO 20 J=1,NQ CALL PLABU2('READ',IQ(J),NPL1,XPL1,YPL1,ZPL1,APL,BPL,CPL,DPL, - ICOL,IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! PLAGMP WARNING : Unable to load a'// - ' plot panel ; curve not plotted.' RETURN ENDIF IF(NPL1.LE.2)GOTO 20 * Skip this panel if it is almost normal. IF(ABS(CPL).LT.1.0D-4*SQRT(APL**2+BPL**2))GOTO 20 * Go over all points. DO 30 I=1,NCUR IF(.NOT.DRAW(I))GOTO 30 CALL INTERD(NPL1,XPL1,YPL1,XCUR(I),YCUR(I),INSIDE,EDGE) IF(INSIDE.AND.ZCUR(I).LT.(DPL-APL*XCUR(I)-BPL*YCUR(I))/CPL) - DRAW(I)=.FALSE. 30 CONTINUE 20 CONTINUE *** Plot the visible markers. DO 100 I=1,NCUR IF(DRAW(I))CALL GPM2(1,XCUR(I),YCUR(I)) 100 CONTINUE END +DECK,PLAINT. SUBROUTINE PLAINT *----------------------------------------------------------------------- * PLAINT - Initialisation of the projections. * (Last changed on 12/11/02.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PARAMETERS. +SEQ,CONSTANTS. +SEQ,PRINTPLOT. INTEGER I,J,IFAIL1,IFAIL2 DOUBLE PRECISION DET *** Projection matrices. DO 60 I=1,3 DO 70 J=1,3 FPROJ(I,J)=0 FPRMAT(I,J)=0 70 CONTINUE IF(I.LE.2)FPROJ(I,I)=1 IPRMAT(I)=I FPRMAT(I,I)=1 60 CONTINUE *** Prepare solved projection matrix. CALL DFACT(3,FPRMAT,3,IPRMAT,IFAIL1,DET,IFAIL2) IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLAINT DEBUG :'', - '' Determinant of projection: '',E15.8)') DET IF(IFAIL1.NE.0.OR.IFAIL2.NE.0)PRINT *,' ###### PLAINT'// - ' ERROR : Error establishing a default projection.' *** Projection axis by default z-axis. FPROJA=0 FPROJB=0 FPROJC=1 FPROJD=0 FPROJN=1 *** Labels. PXLAB='x-Axis [cm]' NCXLAB=11 PYLAB='y-Axis [cm]' NCYLAB=11 PROLAB='z=0' NCFPRO=3 *** Light source. PRTHL=30.0*PI/180.0 PRPHIL=30.0*PI/180.0 *** Absorbed and reflected fractions. PRFABS=0.03 PRFREF=0.1 PRFCAL=0.7 PRFMIN=0.1 PRFMAX=0.95 *** Rainbow colour range. WLMIN=400 WLMAX=660 *** Colour table granularity. NPRCOL=10 *** Colour offsets. ICOL0=30 ICOLBX=0 ICOLPL=0 ICOLST=0 ICOLW1=0 ICOLW2=0 ICOLW3=0 ICOLD1=0 ICOLD2=0 ICOLD3=0 ICOLRB=0 *** Partial or full box, planes, tube. LFULLB=.FALSE. LFULLP=.TRUE. LFULLT=.TRUE. *** Cut overlaps. LSPLIT=.TRUE. *** Sort planes. LSORT=.FALSE. *** Outline. LOUTL=.TRUE. *** Single step plotting of planes. LGSTEP=.FALSE. *** Projection method. PRVIEW='X-Y' *** Axis rotation angle. PROROT=0 END +DECK,PLABOX. SUBROUTINE PLABOX(XBOX,YBOX,ZBOX,NCUT,XCUT,YCUT,ZCUT, - X0PL,Y0PL,Z0PL,APL,BPL,CPL) *----------------------------------------------------------------------- * PLABOX - Crossings between a box and a plane. * (Last changed on 4/ 2/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. INTEGER NCUT,IFAIL DOUBLE PRECISION XBOX(8),YBOX(8),ZBOX(8), - XCUT(12),YCUT(12),ZCUT(12), - X0PL,Y0PL,Z0PL,APL,BPL,CPL,XC,YC,ZC *** Initial number of crossings. NCUT=0 *** Compute the, at most 6, crossings between plane and box. CALL PLALIN(XBOX(1),YBOX(1),ZBOX(1),XBOX(2),YBOX(2),ZBOX(2), - X0PL,Y0PL,Z0PL,APL,BPL,CPL,XC,YC,ZC,IFAIL) IF(IFAIL.EQ.0)THEN NCUT=NCUT+1 XCUT(NCUT)=XC YCUT(NCUT)=YC ZCUT(NCUT)=ZC ENDIF CALL PLALIN(XBOX(2),YBOX(2),ZBOX(2),XBOX(3),YBOX(3),ZBOX(3), - X0PL,Y0PL,Z0PL,APL,BPL,CPL,XC,YC,ZC,IFAIL) IF(IFAIL.EQ.0)THEN NCUT=NCUT+1 XCUT(NCUT)=XC YCUT(NCUT)=YC ZCUT(NCUT)=ZC ENDIF CALL PLALIN(XBOX(3),YBOX(3),ZBOX(3),XBOX(4),YBOX(4),ZBOX(4), - X0PL,Y0PL,Z0PL,APL,BPL,CPL,XC,YC,ZC,IFAIL) IF(IFAIL.EQ.0)THEN NCUT=NCUT+1 XCUT(NCUT)=XC YCUT(NCUT)=YC ZCUT(NCUT)=ZC ENDIF CALL PLALIN(XBOX(4),YBOX(4),ZBOX(4),XBOX(1),YBOX(1),ZBOX(1), - X0PL,Y0PL,Z0PL,APL,BPL,CPL,XC,YC,ZC,IFAIL) IF(IFAIL.EQ.0)THEN NCUT=NCUT+1 XCUT(NCUT)=XC YCUT(NCUT)=YC ZCUT(NCUT)=ZC ENDIF CALL PLALIN(XBOX(5),YBOX(5),ZBOX(5),XBOX(6),YBOX(6),ZBOX(6), - X0PL,Y0PL,Z0PL,APL,BPL,CPL,XC,YC,ZC,IFAIL) IF(IFAIL.EQ.0)THEN NCUT=NCUT+1 XCUT(NCUT)=XC YCUT(NCUT)=YC ZCUT(NCUT)=ZC ENDIF CALL PLALIN(XBOX(6),YBOX(6),ZBOX(6),XBOX(7),YBOX(7),ZBOX(7), - X0PL,Y0PL,Z0PL,APL,BPL,CPL,XC,YC,ZC,IFAIL) IF(IFAIL.EQ.0)THEN NCUT=NCUT+1 XCUT(NCUT)=XC YCUT(NCUT)=YC ZCUT(NCUT)=ZC ENDIF CALL PLALIN(XBOX(7),YBOX(7),ZBOX(7),XBOX(8),YBOX(8),ZBOX(8), - X0PL,Y0PL,Z0PL,APL,BPL,CPL,XC,YC,ZC,IFAIL) IF(IFAIL.EQ.0)THEN NCUT=NCUT+1 XCUT(NCUT)=XC YCUT(NCUT)=YC ZCUT(NCUT)=ZC ENDIF CALL PLALIN(XBOX(8),YBOX(8),ZBOX(8),XBOX(5),YBOX(5),ZBOX(5), - X0PL,Y0PL,Z0PL,APL,BPL,CPL,XC,YC,ZC,IFAIL) IF(IFAIL.EQ.0)THEN NCUT=NCUT+1 XCUT(NCUT)=XC YCUT(NCUT)=YC ZCUT(NCUT)=ZC ENDIF CALL PLALIN(XBOX(1),YBOX(1),ZBOX(1),XBOX(5),YBOX(5),ZBOX(5), - X0PL,Y0PL,Z0PL,APL,BPL,CPL,XC,YC,ZC,IFAIL) IF(IFAIL.EQ.0)THEN NCUT=NCUT+1 XCUT(NCUT)=XC YCUT(NCUT)=YC ZCUT(NCUT)=ZC ENDIF CALL PLALIN(XBOX(2),YBOX(2),ZBOX(2),XBOX(6),YBOX(6),ZBOX(6), - X0PL,Y0PL,Z0PL,APL,BPL,CPL,XC,YC,ZC,IFAIL) IF(IFAIL.EQ.0)THEN NCUT=NCUT+1 XCUT(NCUT)=XC YCUT(NCUT)=YC ZCUT(NCUT)=ZC ENDIF CALL PLALIN(XBOX(3),YBOX(3),ZBOX(3),XBOX(7),YBOX(7),ZBOX(7), - X0PL,Y0PL,Z0PL,APL,BPL,CPL,XC,YC,ZC,IFAIL) IF(IFAIL.EQ.0)THEN NCUT=NCUT+1 XCUT(NCUT)=XC YCUT(NCUT)=YC ZCUT(NCUT)=ZC ENDIF CALL PLALIN(XBOX(4),YBOX(4),ZBOX(4),XBOX(8),YBOX(8),ZBOX(8), - X0PL,Y0PL,Z0PL,APL,BPL,CPL,XC,YC,ZC,IFAIL) IF(IFAIL.EQ.0)THEN NCUT=NCUT+1 XCUT(NCUT)=XC YCUT(NCUT)=YC ZCUT(NCUT)=ZC ENDIF *** Eliminate the butterflies. CALL BUTFLD(NCUT,XCUT,YCUT,ZCUT) END +DECK,PLACYP. SUBROUTINE PLACYP(IVOL,IOFCOL) *----------------------------------------------------------------------- * PLACYP - Generates a table of polygons for a cylinder. * (Last changed on 9/10/11.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CONSTANTS. +SEQ,PARAMETERS. +SEQ,SOLIDS. +SEQ,GRAPHICS. +SEQ,PRINTPLOT. INTEGER IREF,IOFCOL,NMAX,N,IVOL,ICOL,IFAIL,I,IRPL PARAMETER(NMAX=MXEDGE/4-1) DOUBLE PRECISION R,ZL,X0,Y0,Z0,A,B,C,CT,ST,CP,SP,FNORM,WW, - U,V,W,XPL(MXEDGE),YPL(MXEDGE),ZPL(MXEDGE),AROT, ALPHA *** Locate the conductor. IF(IVOL.LT.1.OR.IVOL.GT.MXSOLI)THEN PRINT *,' !!!!!! PLACYP WARNING : Volume reference is out'// - ' of range ; not plotted.' RETURN ENDIF IREF=ISTART(IVOL) IF(IREF.LT.0.OR.IREF+23.GT.MXSBUF)THEN PRINT *,' !!!!!! PLACYP WARNING : Volume address is out'// - ' of range ; not plotted.' RETURN ENDIF *** Locate the cylinder parameters, first the radius. R= CBUF(IREF+1) IF(R.LE.0)THEN PRINT *,' !!!!!! PLACYP WARNING : Cylinder ',IVOL,' has a'// - ' non-positive radius; not plotted.' RETURN ENDIF * Half length in z. ZL=ABS(CBUF(IREF+2)) * Centre. X0=CBUF(IREF+3) Y0=CBUF(IREF+4) Z0=CBUF(IREF+5) * Direction vector. FNORM=SQRT(CBUF(IREF+6)**2+CBUF(IREF+7)**2+CBUF(IREF+8)**2) IF(FNORM.LE.0)THEN PRINT *,' !!!!!! PLACYP WARNING : Cylinder ',IVOL,' has a'// - ' zero norm direction vector; not plotted.' RETURN ENDIF A= CBUF(IREF+6)/FNORM B= CBUF(IREF+7)/FNORM C= CBUF(IREF+8)/FNORM * Shorthand for the rotations. CT=CBUF(IREF+10) ST=CBUF(IREF+11) CP=CBUF(IREF+12) SP=CBUF(IREF+13) * Axial rotation. AROT=CBUF(IREF+14) * Determine a suitable number of points on the radii. N=MIN(NMAX-1,NINT(CBUF(IREF+9))) IF(N.LT.1)THEN IF(R.LT.1E-2*MAX(ABS(GXMAX-GXMIN),ABS(GYMAX-GYMIN), - ABS(GZMAX-GZMIN)))THEN N=MIN(MXEDGE-3,NMAX-1,2) ELSEIF(R.LT.1E-1*MAX(ABS(GXMAX-GXMIN),ABS(GYMAX-GYMIN), - ABS(GZMAX-GZMIN)))THEN N=MIN(MXEDGE-3,NMAX-1,3) ELSE N=MIN(MXEDGE-3,NMAX-1,4) ENDIF ENDIF * Set the mean radius if desired. IF(CBUF(IREF+24).GT.0.5)THEN ALPHA = PI/(4.0D0*DBLE(N-1)) R = 2*R/(1.0D0 + ASINH(TAN(ALPHA))*COS(ALPHA)/TAN(ALPHA)) ENDIF * Debugging. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLACYP DEBUG : Drawing a'', - '' cylinder of volume '',I4/26X,''Radius='',E10.3, - '', N='',I5,'', Half-length='',E10.3/26X,''Centre='',3E10.3/ - 26X,''Direction='',3E10.3)') IVOL,R,N,ZL,X0,Y0,Z0,A,B,C *** Create the top lid. IF(CBUF(IREF+22).GT.0.5)THEN DO 10 I=2,4*N-3 * Local coordinates, U=R*COS(AROT+(PI/2)*DBLE(I-1)/DBLE(N-1)) V=R*SIN(AROT+(PI/2)*DBLE(I-1)/DBLE(N-1)) W=ZL * Rotate into place. XPL(I-1)=X0+CP*CT*U-SP*V+CP*ST*W YPL(I-1)=Y0+SP*CT*U+CP*V+SP*ST*W ZPL(I-1)=Z0 -ST*U +CT*W 10 CONTINUE * Compute colour index. CALL COLWGT(A,B,C,WW) IF(WW.GT.0)THEN ICOL=IOFCOL+NINT(MIN(1.0D0,WW)*(NPRCOL-1)) ELSE ICOL=IOFCOL ENDIF * Store the plane. CALL PLABU1('STORE',IRPL,4*N-4,XPL,YPL,ZPL,A,B,C,ICOL,IVOL, - IFAIL) IF(IFAIL.NE.0)PRINT *,' !!!!!! PLACYP WARNING : Unable to'// - ' store the top lid of a cylinder.' ENDIF *** Create the bottom lid. IF(CBUF(IREF+23).GT.0.5)THEN DO 20 I=2,4*N-3 * Local coordinates, U=R*COS(AROT+(PI/2)*DBLE(I-1)/DBLE(N-1)) V=R*SIN(AROT+(PI/2)*DBLE(I-1)/DBLE(N-1)) W=-ZL * Rotate into place. XPL(I-1)=X0+CP*CT*U-SP*V+CP*ST*W YPL(I-1)=Y0+SP*CT*U+CP*V+SP*ST*W ZPL(I-1)=Z0 -ST*U +CT*W 20 CONTINUE * Compute colour index. CALL COLWGT(-A,-B,-C,WW) IF(WW.GT.0)THEN ICOL=IOFCOL+NINT(MIN(1.0D0,WW)*(NPRCOL-1)) ELSE ICOL=IOFCOL ENDIF * Store the plane. CALL PLABU1('STORE',IRPL,4*N-4,XPL,YPL,ZPL,-A,-B,-C, - ICOL,IVOL,IFAIL) IF(IFAIL.NE.0)PRINT *,' !!!!!! PLACYP WARNING : Unable to'// - ' store the bottom lid of a cylinder.' ENDIF *** Create the side panels. U=R*COS(AROT+(PI/2)*DBLE(0)/DBLE(N-1)) V=R*SIN(AROT+(PI/2)*DBLE(0)/DBLE(N-1)) W=ZL * Rotate into place. XPL(1)=X0+CP*CT*U-SP*V+CP*ST*W YPL(1)=Y0+SP*CT*U+CP*V+SP*ST*W ZPL(1)=Z0 -ST*U +CT*W XPL(2)=X0+CP*CT*U-SP*V-CP*ST*W YPL(2)=Y0+SP*CT*U+CP*V-SP*ST*W ZPL(2)=Z0 -ST*U -CT*W ** Go around the cylinder. DO 30 I=2,4*N-3 * Bottom and top of the line along the axis of the cylinder. U=R*COS(AROT+(PI/2)*DBLE(I-1)/DBLE(N-1)) V=R*SIN(AROT+(PI/2)*DBLE(I-1)/DBLE(N-1)) W=ZL * Rotated into place. XPL(3)=X0+CP*CT*U-SP*V-CP*ST*W YPL(3)=Y0+SP*CT*U+CP*V-SP*ST*W ZPL(3)=Z0 -ST*U -CT*W XPL(4)=X0+CP*CT*U-SP*V+CP*ST*W YPL(4)=Y0+SP*CT*U+CP*V+SP*ST*W ZPL(4)=Z0 -ST*U +CT*W * Compute the colour index for this segment. CALL COLWGT(CP*CT*COS(AROT+(PI/2)*DBLE(I-1.5)/DBLE(N-1))- - SP* SIN(AROT+(PI/2)*DBLE(I-1.5)/DBLE(N-1)), - SP*CT* COS(AROT+(PI/2)*DBLE(I-1.5)/DBLE(N-1))+ - CP* SIN(AROT+(PI/2)*DBLE(I-1.5)/DBLE(N-1)), - -ST* COS(AROT+(PI/2)*DBLE(I-1.5)/DBLE(N-1)),WW) IF(WW.GT.0)THEN ICOL=IOFCOL+NINT(MIN(1.0D0,WW)*(NPRCOL-1)) ELSE ICOL=IOFCOL ENDIF * Store the plane. CALL PLABU1('STORE',IRPL,4,XPL,YPL,ZPL, - CP*CT*COS(AROT+(PI/2)*DBLE(I-1.5)/DBLE(N-1))- - SP* SIN(AROT+(PI/2)*DBLE(I-1.5)/DBLE(N-1)), - SP*CT*COS(AROT+(PI/2)*DBLE(I-1.5)/DBLE(N-1))+ - CP* SIN(AROT+(PI/2)*DBLE(I-1.5)/DBLE(N-1)), - -ST* COS(AROT+(PI/2)*DBLE(I-1.5)/DBLE(N-1)), - ICOL,IVOL,IFAIL) IF(IFAIL.NE.0)PRINT *,' !!!!!! PLACYP WARNING : Unable to'// - ' store a panel of a cylinder.' * Shift the points. XPL(1)=XPL(4) YPL(1)=YPL(4) ZPL(1)=ZPL(4) XPL(2)=XPL(3) YPL(2)=YPL(3) ZPL(2)=ZPL(3) 30 CONTINUE *** Look for intersections with the outside box, x=xmin. CALL PLACYC(IVOL,GXMIN,(GYMIN+GYMAX)/2,(GZMIN+GZMAX)/2, - -1.0D0,0.0D0,0.0D0,IOFCOL+1) * x=xmax. CALL PLACYC(IVOL,GXMAX,(GYMIN+GYMAX)/2,(GZMIN+GZMAX)/2, - +1.0D0,0.0D0,0.0D0,IOFCOL+1) * y=ymin. CALL PLACYC(IVOL,(GXMIN+GXMAX)/2,GYMIN,(GZMIN+GZMAX)/2, - 0.0D0,-1.0D0,0.0D0,IOFCOL+1) * y=ymax. CALL PLACYC(IVOL,(GXMIN+GXMAX)/2,GYMAX,(GZMIN+GZMAX)/2, - 0.0D0,+1.0D0,0.0D0,IOFCOL+1) * z=zmin. CALL PLACYC(IVOL,(GXMIN+GXMAX)/2,(GYMIN+GYMAX)/2,GZMIN, - 0.0D0,0.0D0,-1.0D0,IOFCOL+1) * z=zmax. CALL PLACYC(IVOL,(GXMIN+GXMAX)/2,(GYMIN+GYMAX)/2,GZMAX, - 0.0D0,0.0D0,+1.0D0,IOFCOL+1) END +DECK,PLACYC. SUBROUTINE PLACYC(IVOL,X0PL,Y0PL,Z0PL,APL,BPL,CPL,ICOL) *----------------------------------------------------------------------- * PLACYC - Cuts cylinder IVOL with a plane. * (Last changed on 27/ 2/11.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CONSTANTS. +SEQ,PARAMETERS. +SEQ,SOLIDS. +SEQ,GRAPHICS. +SEQ,PRINTPLOT. INTEGER IREF,NMAX,N,IVOL,IFAIL,I,NPL,ICOL,IRPL PARAMETER(NMAX=MXEDGE/4-1) DOUBLE PRECISION R,ZL,X0,Y0,Z0,A,B,C,CT,ST,CP,SP,FNORM,AROT, - U,V,W,X1,Y1,Z1,X2,Y2,Z2,XPL(MXEDGE),YPL(MXEDGE),ZPL(MXEDGE), - X0PL,Y0PL,Z0PL,APL,BPL,CPL,XCUT,YCUT,ZCUT,ALPHA *** Locate the conductor. IF(IVOL.LT.1.OR.IVOL.GT.MXSOLI)THEN PRINT *,' !!!!!! PLACYC WARNING : Volume reference is out'// - ' of range ; not plotted.' RETURN ENDIF IREF=ISTART(IVOL) IF(IREF.LT.0.OR.IREF+23.GT.MXSBUF)THEN PRINT *,' !!!!!! PLACYC WARNING : Volume address is out'// - ' of range ; not plotted.' RETURN ENDIF *** Locate the cylinder parameters, first the radius. R= CBUF(IREF+1) IF(R.LE.0)THEN PRINT *,' !!!!!! PLACYC WARNING : Cylinder ',IVOL,' has a'// - ' non-positive radius; not plotted.' RETURN ENDIF * Half length in z. ZL=ABS(CBUF(IREF+2)) * Centre. X0=CBUF(IREF+3) Y0=CBUF(IREF+4) Z0=CBUF(IREF+5) * Direction vector. FNORM=SQRT(CBUF(IREF+6)**2+CBUF(IREF+7)**2+CBUF(IREF+8)**2) IF(FNORM.LE.0)THEN PRINT *,' !!!!!! PLACYC WARNING : Cylinder ',IVOL,' has a'// - ' zero norm direction vector; not plotted.' RETURN ENDIF A= CBUF(IREF+6)/FNORM B= CBUF(IREF+7)/FNORM C= CBUF(IREF+8)/FNORM * Shorthand for the rotations. CT=CBUF(IREF+10) ST=CBUF(IREF+11) CP=CBUF(IREF+12) SP=CBUF(IREF+13) * Axial rotation. AROT=CBUF(IREF+14) * Determine a suitable number of points on the radii. N=MIN(NMAX-1,NINT(CBUF(IREF+9))) IF(N.LT.1)THEN IF(R.LT.1E-2*MAX(ABS(GXMAX-GXMIN),ABS(GYMAX-GYMIN), - ABS(GZMAX-GZMIN)))THEN N=MIN(MXEDGE-3,NMAX-1,2) ELSEIF(R.LT.1E-1*MAX(ABS(GXMAX-GXMIN),ABS(GYMAX-GYMIN), - ABS(GZMAX-GZMIN)))THEN N=MIN(MXEDGE-3,NMAX-1,3) ELSE N=MIN(MXEDGE-3,NMAX-1,4) ENDIF ENDIF * Set the mean radius if desired. IF(CBUF(IREF+24).GT.0.5)THEN ALPHA = PI/(4.0D0*DBLE(N-1)) R = 2*R/(1.0D0 + ASINH(TAN(ALPHA))*COS(ALPHA)/TAN(ALPHA)) ENDIF * Debugging. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLACYC DEBUG : Drawing a'', - '' cylinder of volume '',I4/26X,''Radius='',E10.3, - '', N='',I5,'', Half-length='',E10.3/26X,''Centre='',3E10.3/ - 26X,''Direction='',3E10.3)') IVOL,R,N,ZL,X0,Y0,Z0,A,B,C *** Initialise the number of points. NPL=0 *** Go through the lines of the top lid, first point. U=R*COS(AROT+(PI/2)*DBLE(0)/DBLE(N-1)) V=R*SIN(AROT+(PI/2)*DBLE(0)/DBLE(N-1)) W=ZL X1=X0+CP*CT*U-SP*V+CP*ST*W Y1=Y0+SP*CT*U+CP*V+SP*ST*W Z1=Z0 -ST*U +CT*W * Loop over the points. DO 10 I=2,4*N-3 * Local coordinates, U=R*COS(AROT+(PI/2)*DBLE(I-1)/DBLE(N-1)) V=R*SIN(AROT+(PI/2)*DBLE(I-1)/DBLE(N-1)) W=ZL * Rotate into place. X2=X0+CP*CT*U-SP*V+CP*ST*W Y2=Y0+SP*CT*U+CP*V+SP*ST*W Z2=Z0 -ST*U +CT*W * Cut with the plane. CALL PLALIN(X1,Y1,Z1,X2,Y2,Z2,X0PL,Y0PL,Z0PL,APL,BPL,CPL, - XCUT,YCUT,ZCUT,IFAIL) * Store the result if there is one. IF(IFAIL.EQ.0.AND.NPL.LE.MXEDGE)THEN NPL=NPL+1 XPL(NPL)=XCUT YPL(NPL)=YCUT ZPL(NPL)=ZCUT ELSEIF(NPL.GE.MXEDGE)THEN PRINT *,' !!!!!! PLACYC WARNING : Too many intersects'// - ' between cylinder and plane; stopped.' RETURN ENDIF * Shift the coordinates. X1=X2 Y1=Y2 Z1=Z2 10 CONTINUE *** Go through the lines of the bottom lid, first point. U=R*COS(AROT+(PI/2)*DBLE(0)/DBLE(N-1)) V=R*SIN(AROT+(PI/2)*DBLE(0)/DBLE(N-1)) W=-ZL X1=X0+CP*CT*U-SP*V+CP*ST*W Y1=Y0+SP*CT*U+CP*V+SP*ST*W Z1=Z0 -ST*U +CT*W * Loop over the points. DO 20 I=2,4*N-3 * Local coordinates, U=R*COS(AROT+(PI/2)*DBLE(I-1)/DBLE(N-1)) V=R*SIN(AROT+(PI/2)*DBLE(I-1)/DBLE(N-1)) W=-ZL * Rotate into place. X2=X0+CP*CT*U-SP*V+CP*ST*W Y2=Y0+SP*CT*U+CP*V+SP*ST*W Z2=Z0 -ST*U +CT*W * Cut with the plane. CALL PLALIN(X1,Y1,Z1,X2,Y2,Z2,X0PL,Y0PL,Z0PL,APL,BPL,CPL, - XCUT,YCUT,ZCUT,IFAIL) * Store the result if there is one. IF(IFAIL.EQ.0.AND.NPL.LE.MXEDGE)THEN NPL=NPL+1 XPL(NPL)=XCUT YPL(NPL)=YCUT ZPL(NPL)=ZCUT ELSEIF(NPL.GE.MXEDGE)THEN PRINT *,' !!!!!! PLACYC WARNING : Too many intersects'// - ' between cylinder and plane; stopped.' RETURN ENDIF * Shift the coordinates. X1=X2 Y1=Y2 Z1=Z2 20 CONTINUE *** Go through the ribs. DO 30 I=2,4*N-3 * Bottom and top of the line along the axis of the cylinder. U=R*COS(AROT+(PI/2)*DBLE(I-1)/DBLE(N-1)) V=R*SIN(AROT+(PI/2)*DBLE(I-1)/DBLE(N-1)) W=ZL * Rotated into place. X1=X0+CP*CT*U-SP*V-CP*ST*W Y1=Y0+SP*CT*U+CP*V-SP*ST*W Z1=Z0 -ST*U -CT*W X2=X0+CP*CT*U-SP*V+CP*ST*W Y2=Y0+SP*CT*U+CP*V+SP*ST*W Z2=Z0 -ST*U +CT*W * Cut with the plane. CALL PLALIN(X1,Y1,Z1,X2,Y2,Z2,X0PL,Y0PL,Z0PL,APL,BPL,CPL, - XCUT,YCUT,ZCUT,IFAIL) * Store the result if there is one. IF(IFAIL.EQ.0.AND.NPL.LE.MXEDGE)THEN NPL=NPL+1 XPL(NPL)=XCUT YPL(NPL)=YCUT ZPL(NPL)=ZCUT ELSEIF(NPL.GE.MXEDGE)THEN PRINT *,' !!!!!! PLACYC WARNING : Too many intersects'// - ' between cylinder and plane; stopped.' RETURN ENDIF 30 CONTINUE *** Get rid of butterflies. CALL BUTFLD(NPL,XPL,YPL,ZPL) *** Store the plane. IF(NPL.GE.3)THEN CALL PLABU1('STORE',IRPL,NPL,XPL,YPL,ZPL, - APL,BPL,CPL,ICOL,IVOL,IFAIL) IF(IFAIL.NE.0)PRINT *,' !!!!!! PLACYC WARNING : Failed to'// - ' store a side cut of a cylinder.' ENDIF END +DECK,PLACYI. SUBROUTINE PLACYI(IVOL,XPOS,YPOS,ZPOS,INSIDE) *----------------------------------------------------------------------- * PLACYI - Determines whether a point is located inside a cylinder. * (Last changed on 12/ 5/10.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CONSTANTS. +SEQ,SOLIDS. +SEQ,PRINTPLOT. INTEGER IREF,IVOL DOUBLE PRECISION R,ZL,X0,Y0,Z0,CT,ST,CP,SP,XPOS,YPOS,ZPOS,U,V,W LOGICAL INSIDE *** Locate the conductor. IF(IVOL.LT.1.OR.IVOL.GT.MXSOLI)THEN PRINT *,' !!!!!! PLACYI WARNING : Volume reference is out'// - ' of range ; not checked.' RETURN ENDIF IREF=ISTART(IVOL) IF(IREF.LT.0.OR.IREF+23.GT.MXSBUF)THEN PRINT *,' !!!!!! PLACYI WARNING : Volume address is out'// - ' of range ; not checked.' RETURN ENDIF *** Locate the cylinder parameters, first the radius. R= CBUF(IREF+1) IF(R.LE.0)THEN PRINT *,' !!!!!! PLACYI WARNING : Cylinder ',IVOL,' has a'// - ' non-positive radius; not checked.' RETURN ENDIF * Half length in z. ZL=ABS(CBUF(IREF+2)) * Centre. X0=CBUF(IREF+3) Y0=CBUF(IREF+4) Z0=CBUF(IREF+5) IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLACYI DEBUG : Checking'', - '' cylindric volume '',I4/26X,''Radius='',E10.3, - '', Half-length='',E10.3/26X,''Centre= '',3E10.3)') - IVOL,R,ZL,X0,Y0,Z0 * Shorthand for the rotations. CT=CBUF(IREF+10) ST=CBUF(IREF+11) CP=CBUF(IREF+12) SP=CBUF(IREF+13) *** Transform the point to local coordinates. U=+CP*CT*(XPOS-X0)+SP*CT*(YPOS-Y0)-ST*(ZPOS-Z0) V=-SP *(XPOS-X0)+CP* (YPOS-Y0) W=+CP*ST*(XPOS-X0)+SP*ST*(YPOS-Y0)+CT*(ZPOS-Z0) *** See whether the point is inside. IF(ABS(W).GT.ZL.OR.U**2+V**2.GT.R**2)THEN INSIDE=.FALSE. ELSE INSIDE=.TRUE. ENDIF END +DECK,PLACYE. SUBROUTINE PLACYE(IVOL,XMIN,YMIN,ZMIN,XMAX,YMAX,ZMAX) *----------------------------------------------------------------------- * PLACYE - Computes an enveloping box * (Last changed on 22/ 2/09.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CONSTANTS. +SEQ,SOLIDS. +SEQ,PRINTPLOT. INTEGER IREF,IVOL DOUBLE PRECISION R,ZL,X0,Y0,Z0,XMIN,YMIN,ZMIN,XMAX,YMAX,ZMAX *** Locate the conductor. IF(IVOL.LT.1.OR.IVOL.GT.MXSOLI)THEN PRINT *,' !!!!!! PLACYI WARNING : Volume reference is out'// - ' of range ; not checked.' RETURN ENDIF IREF=ISTART(IVOL) IF(IREF.LT.0.OR.IREF+23.GT.MXSBUF)THEN PRINT *,' !!!!!! PLACYI WARNING : Volume address is out'// - ' of range ; not checked.' RETURN ENDIF *** Locate the cylinder parameters, first the radius. R= CBUF(IREF+1) * Half length in z. ZL=ABS(CBUF(IREF+2)) * Centre. X0=CBUF(IREF+3) Y0=CBUF(IREF+4) Z0=CBUF(IREF+5) IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLACYE DEBUG :'', - '' Cylindric volume '',I4/26X,''Radius='',E10.3, - '', Half-length='',E10.3/26X,''Centre= '',3E10.3)') - IVOL,R,ZL,X0,Y0,Z0 *** Take the margins wide. XMIN=X0-SQRT(R**2+ZL**2) YMIN=Y0-SQRT(R**2+ZL**2) ZMIN=Z0-SQRT(R**2+ZL**2) XMAX=X0+SQRT(R**2+ZL**2) YMAX=Y0+SQRT(R**2+ZL**2) ZMAX=Z0+SQRT(R**2+ZL**2) END +DECK,PLACYD. SUBROUTINE PLACYD(ISOL,NVTX,XVTX,YVTX,ZVTX,XNORM,YNORM,ZNORM,DIS) *----------------------------------------------------------------------- * PLACYD - Returns the discretisation level required for a primitive. * (Last changed on 11/10/11.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CONSTANTS. +SEQ,SOLIDS. +SEQ,PRINTPLOT. INTEGER ISOL,NVTX,IREF DOUBLE PRECISION XVTX(*), YVTX(*), ZVTX(*), XNORM, YNORM, ZNORM, - CT,ST,CP,SP,U,V,W,DIS *** Locate the conductor. IF(ISOL.LT.1.OR.ISOL.GT.MXSOLI)THEN PRINT *,' !!!!!! PLACYD WARNING : Solid reference is out'// - ' of range ; not checked.' RETURN ENDIF IREF=ISTART(ISOL) IF(IREF.LT.0.OR.IREF+23.GT.MXSBUF)THEN PRINT *,' !!!!!! PLACYD WARNING : Solid address is out'// - ' of range ; not checked.' RETURN ENDIF *** Locate the cylinder rotation parameters. CT=CBUF(IREF+10) ST=CBUF(IREF+11) CP=CBUF(IREF+12) SP=CBUF(IREF+13) *** Transform the normal vector to local coordinates. U=+CP*CT*XNORM+SP*CT*YNORM-ST*ZNORM V=-SP *XNORM+CP* YNORM W=+CP*ST*XNORM+SP*ST*YNORM+CT*ZNORM C print *,' Axis vector: ',u,v,w *** Identify the vector. IF(W.GT.MAX(ABS(U),ABS(V)))THEN DIS=CBUF(IREF+19) ELSEIF(W.LT.-MAX(ABS(U),ABS(V)))THEN DIS=CBUF(IREF+20) ELSE DIS=CBUF(IREF+21) ENDIF * Debugging. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLACYD DEBUG :'', - '' Discretisation of solid '',I5,'' (cylinder)''/ - '' Norm vector: '',3F10.3/ - '' Discretisation: '',E12.5)') - ISOL,U,V,W,DIS END +DECK,PLABXP. SUBROUTINE PLABXP(IVOL,IOFCOL) *----------------------------------------------------------------------- * PLABXP - Plots a box in 3D perspective. * (Last changed on 1/10/10.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CONSTANTS. +SEQ,PARAMETERS. +SEQ,SOLIDS. +SEQ,GRAPHICS. +SEQ,PRINTPLOT. INTEGER IVOL,IREF,IOFCOL,ICOL,IFAIL,IRPL DOUBLE PRECISION XL,YL,ZL,X0,Y0,Z0,A,B,C,CT,ST,CP,SP, - U1,V1,W1,WW,FNORM,XPL(4),YPL(4),ZPL(4) *** Locate the conductor. IF(IVOL.LT.1.OR.IVOL.GT.MXSOLI)THEN PRINT *,' !!!!!! PLABXP WARNING : Volume reference is out'// - ' of range ; not plotted.' RETURN ENDIF IREF=ISTART(IVOL) IF(IREF.LT.0.OR.IREF+8.GT.MXSBUF)THEN PRINT *,' !!!!!! PLABXP WARNING : Volume address is out'// - ' of range ; not plotted.' RETURN ENDIF *** Locate the cube parameters. XL=ABS(CBUF(IREF+1)) YL=ABS(CBUF(IREF+2)) ZL=ABS(CBUF(IREF+3)) X0=CBUF(IREF+4) Y0=CBUF(IREF+5) Z0=CBUF(IREF+6) FNORM=SQRT(CBUF(IREF+7)**2+CBUF(IREF+8)**2+CBUF(IREF+9)**2) IF(FNORM.LE.0)THEN PRINT *,' !!!!!! PLABXP WARNING : Box ',IVOL,' has a'// - ' zero norm direction vector; not plotted.' RETURN ENDIF A= CBUF(IREF+7)/FNORM B= CBUF(IREF+8)/FNORM C= CBUF(IREF+9)/FNORM IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLABXP DEBUG : Drawing a'', - '' box from address '',I4/26X,''Centre= '',3E10.3/ - 26X,''Half-lengths='',3E10.3/26X,''Direction= '',3E10.3)') - IREF,X0,Y0,Z0,XL,YL,ZL,A,B,C * Shorthand for the rotations. CT=CBUF(IREF+10) ST=CBUF(IREF+11) CP=CBUF(IREF+12) SP=CBUF(IREF+13) *** Draw the 6 sides of the box, start with the x=xmin face. IF(YL.GT.0.AND.ZL.GT.0)THEN U1=-XL V1=-YL W1=-ZL XPL(1)=X0+CP*CT*U1-SP*V1+CP*ST*W1 YPL(1)=Y0+SP*CT*U1+CP*V1+SP*ST*W1 ZPL(1)=Z0 -ST*U1 +CT*W1 U1=-XL V1=+YL W1=-ZL XPL(2)=X0+CP*CT*U1-SP*V1+CP*ST*W1 YPL(2)=Y0+SP*CT*U1+CP*V1+SP*ST*W1 ZPL(2)=Z0 -ST*U1 +CT*W1 U1=-XL V1=+YL W1=+ZL XPL(3)=X0+CP*CT*U1-SP*V1+CP*ST*W1 YPL(3)=Y0+SP*CT*U1+CP*V1+SP*ST*W1 ZPL(3)=Z0 -ST*U1 +CT*W1 U1=-XL V1=-YL W1=+ZL XPL(4)=X0+CP*CT*U1-SP*V1+CP*ST*W1 YPL(4)=Y0+SP*CT*U1+CP*V1+SP*ST*W1 ZPL(4)=Z0 -ST*U1 +CT*W1 CALL COLWGT(-CP*CT,-SP*CT,+ST,WW) IF(WW.GE.0)THEN ICOL=IOFCOL+NINT(MIN(1.0D0,WW)*(NPRCOL-1)) ELSE ICOL=IOFCOL ENDIF CALL PLABU1('STORE',IRPL,4,XPL,YPL,ZPL,-CP*CT,-SP*CT,+ST, - ICOL,IVOL,IFAIL) IF(IFAIL.NE.0)PRINT *,' !!!!!! PLABXP WARNING : Unable to'// - ' store a panel of a box.' ENDIF * The x=xmax face. IF(XL.GT.0.AND.YL.GT.0.AND.ZL.GT.0)THEN U1=+XL V1=-YL W1=-ZL XPL(1)=X0+CP*CT*U1-SP*V1+CP*ST*W1 YPL(1)=Y0+SP*CT*U1+CP*V1+SP*ST*W1 ZPL(1)=Z0 -ST*U1 +CT*W1 U1=+XL V1=+YL W1=-ZL XPL(2)=X0+CP*CT*U1-SP*V1+CP*ST*W1 YPL(2)=Y0+SP*CT*U1+CP*V1+SP*ST*W1 ZPL(2)=Z0 -ST*U1 +CT*W1 U1=+XL V1=+YL W1=+ZL XPL(3)=X0+CP*CT*U1-SP*V1+CP*ST*W1 YPL(3)=Y0+SP*CT*U1+CP*V1+SP*ST*W1 ZPL(3)=Z0 -ST*U1 +CT*W1 U1=+XL V1=-YL W1=+ZL XPL(4)=X0+CP*CT*U1-SP*V1+CP*ST*W1 YPL(4)=Y0+SP*CT*U1+CP*V1+SP*ST*W1 ZPL(4)=Z0 -ST*U1 +CT*W1 CALL COLWGT(CP*CT,SP*CT,-ST,WW) IF(WW.GE.0)THEN ICOL=IOFCOL+NINT(MIN(1.0D0,WW)*(NPRCOL-1)) ELSE ICOL=IOFCOL ENDIF CALL PLABU1('STORE',IRPL,4,XPL,YPL,ZPL,CP*CT,SP*CT,-ST, - ICOL,IVOL,IFAIL) IF(IFAIL.NE.0)PRINT *,' !!!!!! PLABXP WARNING : Unable to'// - ' store a panel of a box.' ENDIF * The y=ymin face. IF(XL.GT.0.AND.ZL.GT.0)THEN U1=-XL V1=-YL W1=-ZL XPL(1)=X0+CP*CT*U1-SP*V1+CP*ST*W1 YPL(1)=Y0+SP*CT*U1+CP*V1+SP*ST*W1 ZPL(1)=Z0 -ST*U1 +CT*W1 U1=+XL V1=-YL W1=-ZL XPL(2)=X0+CP*CT*U1-SP*V1+CP*ST*W1 YPL(2)=Y0+SP*CT*U1+CP*V1+SP*ST*W1 ZPL(2)=Z0 -ST*U1 +CT*W1 U1=+XL V1=-YL W1=+ZL XPL(3)=X0+CP*CT*U1-SP*V1+CP*ST*W1 YPL(3)=Y0+SP*CT*U1+CP*V1+SP*ST*W1 ZPL(3)=Z0 -ST*U1 +CT*W1 U1=-XL V1=-YL W1=+ZL XPL(4)=X0+CP*CT*U1-SP*V1+CP*ST*W1 YPL(4)=Y0+SP*CT*U1+CP*V1+SP*ST*W1 ZPL(4)=Z0 -ST*U1 +CT*W1 CALL COLWGT(+SP,-CP,0.0D0,WW) IF(WW.GE.0)THEN ICOL=IOFCOL+NINT(MIN(1.0D0,WW)*(NPRCOL-1)) ELSE ICOL=IOFCOL ENDIF CALL PLABU1('STORE',IRPL,4,XPL,YPL,ZPL,SP,-CP,0.0D0, - ICOL,IVOL,IFAIL) IF(IFAIL.NE.0)PRINT *,' !!!!!! PLABXP WARNING : Unable to'// - ' store a panel of a box.' ENDIF * The y=ymax face. IF(XL.GT.0.AND.YL.GT.0.AND.ZL.GT.0)THEN U1=-XL V1=+YL W1=-ZL XPL(1)=X0+CP*CT*U1-SP*V1+CP*ST*W1 YPL(1)=Y0+SP*CT*U1+CP*V1+SP*ST*W1 ZPL(1)=Z0 -ST*U1 +CT*W1 U1=+XL V1=+YL W1=-ZL XPL(2)=X0+CP*CT*U1-SP*V1+CP*ST*W1 YPL(2)=Y0+SP*CT*U1+CP*V1+SP*ST*W1 ZPL(2)=Z0 -ST*U1 +CT*W1 U1=+XL V1=+YL W1=+ZL XPL(3)=X0+CP*CT*U1-SP*V1+CP*ST*W1 YPL(3)=Y0+SP*CT*U1+CP*V1+SP*ST*W1 ZPL(3)=Z0 -ST*U1 +CT*W1 U1=-XL V1=+YL W1=+ZL XPL(4)=X0+CP*CT*U1-SP*V1+CP*ST*W1 YPL(4)=Y0+SP*CT*U1+CP*V1+SP*ST*W1 ZPL(4)=Z0 -ST*U1 +CT*W1 CALL COLWGT(-SP,+CP,0.0D0,WW) IF(WW.GE.0)THEN ICOL=IOFCOL+NINT(MIN(1.0D0,WW)*(NPRCOL-1)) ELSE ICOL=IOFCOL ENDIF CALL PLABU1('STORE',IRPL,4,XPL,YPL,ZPL,-SP,+CP,0.0D0, - ICOL,IVOL,IFAIL) IF(IFAIL.NE.0)PRINT *,' !!!!!! PLABXP WARNING : Unable to'// - ' store a panel of a box.' ENDIF * The z=zmin face. IF(XL.GT.0.AND.YL.GT.0)THEN U1=-XL V1=-YL W1=-ZL XPL(1)=X0+CP*CT*U1-SP*V1+CP*ST*W1 YPL(1)=Y0+SP*CT*U1+CP*V1+SP*ST*W1 ZPL(1)=Z0 -ST*U1 +CT*W1 U1=-XL V1=+YL W1=-ZL XPL(2)=X0+CP*CT*U1-SP*V1+CP*ST*W1 YPL(2)=Y0+SP*CT*U1+CP*V1+SP*ST*W1 ZPL(2)=Z0 -ST*U1 +CT*W1 U1=+XL V1=+YL W1=-ZL XPL(3)=X0+CP*CT*U1-SP*V1+CP*ST*W1 YPL(3)=Y0+SP*CT*U1+CP*V1+SP*ST*W1 ZPL(3)=Z0 -ST*U1 +CT*W1 U1=+XL V1=-YL W1=-ZL XPL(4)=X0+CP*CT*U1-SP*V1+CP*ST*W1 YPL(4)=Y0+SP*CT*U1+CP*V1+SP*ST*W1 ZPL(4)=Z0 -ST*U1 +CT*W1 CALL COLWGT(-CP*ST,-SP*ST,-CT,WW) IF(WW.GE.0)THEN ICOL=IOFCOL+NINT(MIN(1.0D0,WW)*(NPRCOL-1)) ELSE ICOL=IOFCOL ENDIF CALL PLABU1('STORE',IRPL,4,XPL,YPL,ZPL,-CP*ST,-SP*ST,-CT, - ICOL,IVOL,IFAIL) IF(IFAIL.NE.0)PRINT *,' !!!!!! PLABXP WARNING : Unable to'// - ' store a panel of a box.' ENDIF * The z=zmax face. IF(XL.GT.0.AND.YL.GT.0.AND.ZL.GT.0)THEN U1=-XL V1=-YL W1=+ZL XPL(1)=X0+CP*CT*U1-SP*V1+CP*ST*W1 YPL(1)=Y0+SP*CT*U1+CP*V1+SP*ST*W1 ZPL(1)=Z0 -ST*U1 +CT*W1 U1=-XL V1=+YL W1=+ZL XPL(2)=X0+CP*CT*U1-SP*V1+CP*ST*W1 YPL(2)=Y0+SP*CT*U1+CP*V1+SP*ST*W1 ZPL(2)=Z0 -ST*U1 +CT*W1 U1=+XL V1=+YL W1=+ZL XPL(3)=X0+CP*CT*U1-SP*V1+CP*ST*W1 YPL(3)=Y0+SP*CT*U1+CP*V1+SP*ST*W1 ZPL(3)=Z0 -ST*U1 +CT*W1 U1=+XL V1=-YL W1=+ZL XPL(4)=X0+CP*CT*U1-SP*V1+CP*ST*W1 YPL(4)=Y0+SP*CT*U1+CP*V1+SP*ST*W1 ZPL(4)=Z0 -ST*U1 +CT*W1 CALL COLWGT(+CP*ST,+SP*ST,+CT,WW) IF(WW.GE.0)THEN ICOL=IOFCOL+NINT(MIN(1.0D0,WW)*(NPRCOL-1)) ELSE ICOL=IOFCOL ENDIF CALL PLABU1('STORE',IRPL,4,XPL,YPL,ZPL,+CP*ST,+SP*ST,+CT, - ICOL,IVOL,IFAIL) IF(IFAIL.NE.0)PRINT *,' !!!!!! PLABXP WARNING : Unable to'// - ' store a panel of a box.' ENDIF *** Look for intersections with the outside box, x=xmin. CALL PLABXC(IVOL,GXMIN,(GYMIN+GYMAX)/2,(GZMIN+GZMAX)/2, - -1.0D0,0.0D0,0.0D0,IOFCOL+1) * x=xmax. CALL PLABXC(IVOL,GXMAX,(GYMIN+GYMAX)/2,(GZMIN+GZMAX)/2, - +1.0D0,0.0D0,0.0D0,IOFCOL+1) * y=ymin. CALL PLABXC(IVOL,(GXMIN+GXMAX)/2,GYMIN,(GZMIN+GZMAX)/2, - 0.0D0,-1.0D0,0.0D0,IOFCOL+1) * y=ymax. CALL PLABXC(IVOL,(GXMIN+GXMAX)/2,GYMAX,(GZMIN+GZMAX)/2, - 0.0D0,+1.0D0,0.0D0,IOFCOL+1) * z=zmin. CALL PLABXC(IVOL,(GXMIN+GXMAX)/2,(GYMIN+GYMAX)/2,GZMIN, - 0.0D0,0.0D0,-1.0D0,IOFCOL+1) * z=zmax. CALL PLABXC(IVOL,(GXMIN+GXMAX)/2,(GYMIN+GYMAX)/2,GZMAX, - 0.0D0,0.0D0,+1.0D0,IOFCOL+1) END +DECK,PLABXC. SUBROUTINE PLABXC(IVOL,X0PL,Y0PL,Z0PL,APL,BPL,CPL,ICOL) *----------------------------------------------------------------------- * PLABXC - Cuts box IVOL with a plane. * (Last changed on 19/11/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CONSTANTS. +SEQ,PARAMETERS. +SEQ,SOLIDS. +SEQ,GRAPHICS. +SEQ,PRINTPLOT. INTEGER IREF,IVOL,IFAIL,NPL,ICOL,IRPL DOUBLE PRECISION X0,Y0,Z0,A,B,C,XL,YL,ZL,CT,ST,CP,SP, - FNORM,U1,V1,W1,U2,V2,W2,X1,Y1,Z1,X2,Y2,Z2, - XPL(MXEDGE),YPL(MXEDGE),ZPL(MXEDGE), - X0PL,Y0PL,Z0PL,APL,BPL,CPL,XCUT,YCUT,ZCUT *** Locate the conductor. IF(ABS(IVOL).LT.1.OR.ABS(IVOL).GT.MXSOLI)THEN PRINT *,' !!!!!! PLABXC WARNING : Volume reference is out'// - ' of range ; not plotted.' RETURN ENDIF IREF=ISTART(ABS(IVOL)) IF(IREF.LT.0.OR.IREF+8.GT.MXSBUF)THEN PRINT *,' !!!!!! PLABXC WARNING : Volume address is out'// - ' of range ; not plotted.' RETURN ENDIF *** Locate the cube parameters. XL=ABS(CBUF(IREF+1)) YL=ABS(CBUF(IREF+2)) ZL=ABS(CBUF(IREF+3)) X0=CBUF(IREF+4) Y0=CBUF(IREF+5) Z0=CBUF(IREF+6) FNORM=SQRT(CBUF(IREF+7)**2+CBUF(IREF+8)**2+CBUF(IREF+9)**2) IF(FNORM.LE.0)THEN PRINT *,' !!!!!! PLABXC WARNING : Box ',ABS(IVOL),' has a'// - ' zero norm direction vector; not plotted.' RETURN ENDIF A= CBUF(IREF+7)/FNORM B= CBUF(IREF+8)/FNORM C= CBUF(IREF+9)/FNORM IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLABXC DEBUG : Drawing a'', - '' box from address '',I4/26X,''Centre= '',3E10.3/ - 26X,''Half-lengths='',3E10.3/26X,''Direction= '',3E10.3)') - IREF,X0,Y0,Z0,XL,YL,ZL,A,B,C * Shorthand for the rotations. CT=CBUF(IREF+10) ST=CBUF(IREF+11) CP=CBUF(IREF+12) SP=CBUF(IREF+13) *** Initial number of points. NPL=0 *** Draw all 12 lines and cut, (xmin,ymin,zmin) to (xmax,ymin,zmin). U1=-XL V1=-YL W1=-ZL X1=X0+CP*CT*U1-SP*V1+CP*ST*W1 Y1=Y0+SP*CT*U1+CP*V1+SP*ST*W1 Z1=Z0 -ST*U1 +CT*W1 U2=+XL V2=-YL W2=-ZL X2=X0+CP*CT*U2-SP*V2+CP*ST*W2 Y2=Y0+SP*CT*U2+CP*V2+SP*ST*W2 Z2=Z0 -ST*U2 +CT*W2 * Cut with the plane. CALL PLALIN(X1,Y1,Z1,X2,Y2,Z2,X0PL,Y0PL,Z0PL,APL,BPL,CPL, - XCUT,YCUT,ZCUT,IFAIL) * Store the result if there is one. IF(IFAIL.EQ.0.AND.NPL.LE.MXEDGE)THEN NPL=NPL+1 XPL(NPL)=XCUT YPL(NPL)=YCUT ZPL(NPL)=ZCUT ELSEIF(NPL.GE.MXEDGE)THEN PRINT *,' !!!!!! PLABXC WARNING : Too many intersects'// - ' between box and plane; stopped.' RETURN ENDIF ** ... to (xmin,ymax,zmin). U2=-XL V2=+YL W2=-ZL X2=X0+CP*CT*U2-SP*V2+CP*ST*W2 Y2=Y0+SP*CT*U2+CP*V2+SP*ST*W2 Z2=Z0 -ST*U2 +CT*W2 * Cut with the plane. CALL PLALIN(X1,Y1,Z1,X2,Y2,Z2,X0PL,Y0PL,Z0PL,APL,BPL,CPL, - XCUT,YCUT,ZCUT,IFAIL) * Store the result if there is one. IF(IFAIL.EQ.0.AND.NPL.LE.MXEDGE)THEN NPL=NPL+1 XPL(NPL)=XCUT YPL(NPL)=YCUT ZPL(NPL)=ZCUT ELSEIF(NPL.GE.MXEDGE)THEN PRINT *,' !!!!!! PLABXC WARNING : Too many intersects'// - ' between box and plane; stopped.' RETURN ENDIF ** ... to (xmin,ymin,zmax). U2=-XL V2=-YL W2=+ZL X2=X0+CP*CT*U2-SP*V2+CP*ST*W2 Y2=Y0+SP*CT*U2+CP*V2+SP*ST*W2 Z2=Z0 -ST*U2 +CT*W2 * Cut with the plane. CALL PLALIN(X1,Y1,Z1,X2,Y2,Z2,X0PL,Y0PL,Z0PL,APL,BPL,CPL, - XCUT,YCUT,ZCUT,IFAIL) * Store the result if there is one. IF(IFAIL.EQ.0.AND.NPL.LE.MXEDGE)THEN NPL=NPL+1 XPL(NPL)=XCUT YPL(NPL)=YCUT ZPL(NPL)=ZCUT ELSEIF(NPL.GE.MXEDGE)THEN PRINT *,' !!!!!! PLABXC WARNING : Too many intersects'// - ' between box and plane; stopped.' RETURN ENDIF *** The line (xmax,ymax,zmin) to (xmin,ymax,zmin). U1=+XL V1=+YL W1=-ZL X1=X0+CP*CT*U1-SP*V1+CP*ST*W1 Y1=Y0+SP*CT*U1+CP*V1+SP*ST*W1 Z1=Z0 -ST*U1 +CT*W1 U2=-XL V2=+YL W2=-ZL X2=X0+CP*CT*U2-SP*V2+CP*ST*W2 Y2=Y0+SP*CT*U2+CP*V2+SP*ST*W2 Z2=Z0 -ST*U2 +CT*W2 * Cut with the plane. CALL PLALIN(X1,Y1,Z1,X2,Y2,Z2,X0PL,Y0PL,Z0PL,APL,BPL,CPL, - XCUT,YCUT,ZCUT,IFAIL) * Store the result if there is one. IF(IFAIL.EQ.0.AND.NPL.LE.MXEDGE)THEN NPL=NPL+1 XPL(NPL)=XCUT YPL(NPL)=YCUT ZPL(NPL)=ZCUT ELSEIF(NPL.GE.MXEDGE)THEN PRINT *,' !!!!!! PLABXC WARNING : Too many intersects'// - ' between box and plane; stopped.' RETURN ENDIF ** ... to (xmax,ymin,zmin). U2=+XL V2=-YL W2=-ZL X2=X0+CP*CT*U2-SP*V2+CP*ST*W2 Y2=Y0+SP*CT*U2+CP*V2+SP*ST*W2 Z2=Z0 -ST*U2 +CT*W2 * Cut with the plane. CALL PLALIN(X1,Y1,Z1,X2,Y2,Z2,X0PL,Y0PL,Z0PL,APL,BPL,CPL, - XCUT,YCUT,ZCUT,IFAIL) * Store the result if there is one. IF(IFAIL.EQ.0.AND.NPL.LE.MXEDGE)THEN NPL=NPL+1 XPL(NPL)=XCUT YPL(NPL)=YCUT ZPL(NPL)=ZCUT ELSEIF(NPL.GE.MXEDGE)THEN PRINT *,' !!!!!! PLABXC WARNING : Too many intersects'// - ' between box and plane; stopped.' RETURN ENDIF ** ... to (xmax,ymax,zmax). U2=+XL V2=+YL W2=+ZL X2=X0+CP*CT*U2-SP*V2+CP*ST*W2 Y2=Y0+SP*CT*U2+CP*V2+SP*ST*W2 Z2=Z0 -ST*U2 +CT*W2 * Cut with the plane. CALL PLALIN(X1,Y1,Z1,X2,Y2,Z2,X0PL,Y0PL,Z0PL,APL,BPL,CPL, - XCUT,YCUT,ZCUT,IFAIL) * Store the result if there is one. IF(IFAIL.EQ.0.AND.NPL.LE.MXEDGE)THEN NPL=NPL+1 XPL(NPL)=XCUT YPL(NPL)=YCUT ZPL(NPL)=ZCUT ELSEIF(NPL.GE.MXEDGE)THEN PRINT *,' !!!!!! PLABXC WARNING : Too many intersects'// - ' between box and plane; stopped.' RETURN ENDIF *** The line (xmin,ymax,zmax) to (xmax,ymax,zmax). U1=-XL V1=+YL W1=+ZL X1=X0+CP*CT*U1-SP*V1+CP*ST*W1 Y1=Y0+SP*CT*U1+CP*V1+SP*ST*W1 Z1=Z0 -ST*U1 +CT*W1 U2=+XL V2=+YL W2=+ZL X2=X0+CP*CT*U2-SP*V2+CP*ST*W2 Y2=Y0+SP*CT*U2+CP*V2+SP*ST*W2 Z2=Z0 -ST*U2 +CT*W2 * Cut with the plane. CALL PLALIN(X1,Y1,Z1,X2,Y2,Z2,X0PL,Y0PL,Z0PL,APL,BPL,CPL, - XCUT,YCUT,ZCUT,IFAIL) * Store the result if there is one. IF(IFAIL.EQ.0.AND.NPL.LE.MXEDGE)THEN NPL=NPL+1 XPL(NPL)=XCUT YPL(NPL)=YCUT ZPL(NPL)=ZCUT ELSEIF(NPL.GE.MXEDGE)THEN PRINT *,' !!!!!! PLABXC WARNING : Too many intersects'// - ' between box and plane; stopped.' RETURN ENDIF ** ... to (xmin,ymin,zmax). U2=-XL V2=-YL W2=+ZL X2=X0+CP*CT*U2-SP*V2+CP*ST*W2 Y2=Y0+SP*CT*U2+CP*V2+SP*ST*W2 Z2=Z0 -ST*U2 +CT*W2 * Cut with the plane. CALL PLALIN(X1,Y1,Z1,X2,Y2,Z2,X0PL,Y0PL,Z0PL,APL,BPL,CPL, - XCUT,YCUT,ZCUT,IFAIL) * Store the result if there is one. IF(IFAIL.EQ.0.AND.NPL.LE.MXEDGE)THEN NPL=NPL+1 XPL(NPL)=XCUT YPL(NPL)=YCUT ZPL(NPL)=ZCUT ELSEIF(NPL.GE.MXEDGE)THEN PRINT *,' !!!!!! PLABXC WARNING : Too many intersects'// - ' between box and plane; stopped.' RETURN ENDIF ** ... to (xmin,ymax,zmin). U1=-XL V1=+YL W1=-ZL X1=X0+CP*CT*U1-SP*V1+CP*ST*W1 Y1=Y0+SP*CT*U1+CP*V1+SP*ST*W1 Z1=Z0 -ST*U1 +CT*W1 U2=-XL V2=+YL W2=+ZL X2=X0+CP*CT*U2-SP*V2+CP*ST*W2 Y2=Y0+SP*CT*U2+CP*V2+SP*ST*W2 Z2=Z0 -ST*U2 +CT*W2 * Cut with the plane. CALL PLALIN(X1,Y1,Z1,X2,Y2,Z2,X0PL,Y0PL,Z0PL,APL,BPL,CPL, - XCUT,YCUT,ZCUT,IFAIL) * Store the result if there is one. IF(IFAIL.EQ.0.AND.NPL.LE.MXEDGE)THEN NPL=NPL+1 XPL(NPL)=XCUT YPL(NPL)=YCUT ZPL(NPL)=ZCUT ELSEIF(NPL.GE.MXEDGE)THEN PRINT *,' !!!!!! PLABXC WARNING : Too many intersects'// - ' between box and plane; stopped.' RETURN ENDIF *** The line (xmax,ymin,zmax) to (xmin,ymin,zmax). U1=+XL V1=-YL W1=+ZL X1=X0+CP*CT*U1-SP*V1+CP*ST*W1 Y1=Y0+SP*CT*U1+CP*V1+SP*ST*W1 Z1=Z0 -ST*U1 +CT*W1 U2=-XL V2=-YL W2=+ZL X2=X0+CP*CT*U2-SP*V2+CP*ST*W2 Y2=Y0+SP*CT*U2+CP*V2+SP*ST*W2 Z2=Z0 -ST*U2 +CT*W2 * Cut with the plane. CALL PLALIN(X1,Y1,Z1,X2,Y2,Z2,X0PL,Y0PL,Z0PL,APL,BPL,CPL, - XCUT,YCUT,ZCUT,IFAIL) * Store the result if there is one. IF(IFAIL.EQ.0.AND.NPL.LE.MXEDGE)THEN NPL=NPL+1 XPL(NPL)=XCUT YPL(NPL)=YCUT ZPL(NPL)=ZCUT ELSEIF(NPL.GE.MXEDGE)THEN PRINT *,' !!!!!! PLABXC WARNING : Too many intersects'// - ' between box and plane; stopped.' RETURN ENDIF * ... to (xmax,ymax,zmax). U2=+XL V2=+YL W2=+ZL X2=X0+CP*CT*U2-SP*V2+CP*ST*W2 Y2=Y0+SP*CT*U2+CP*V2+SP*ST*W2 Z2=Z0 -ST*U2 +CT*W2 * Cut with the plane. CALL PLALIN(X1,Y1,Z1,X2,Y2,Z2,X0PL,Y0PL,Z0PL,APL,BPL,CPL, - XCUT,YCUT,ZCUT,IFAIL) * Store the result if there is one. IF(IFAIL.EQ.0.AND.NPL.LE.MXEDGE)THEN NPL=NPL+1 XPL(NPL)=XCUT YPL(NPL)=YCUT ZPL(NPL)=ZCUT ELSEIF(NPL.GE.MXEDGE)THEN PRINT *,' !!!!!! PLABXC WARNING : Too many intersects'// - ' between box and plane; stopped.' RETURN ENDIF * ... to (xmax,ymin,zmin). U2=+XL V2=-YL W2=-ZL X2=X0+CP*CT*U2-SP*V2+CP*ST*W2 Y2=Y0+SP*CT*U2+CP*V2+SP*ST*W2 Z2=Z0 -ST*U2 +CT*W2 * Cut with the plane. CALL PLALIN(X1,Y1,Z1,X2,Y2,Z2,X0PL,Y0PL,Z0PL,APL,BPL,CPL, - XCUT,YCUT,ZCUT,IFAIL) * Store the result if there is one. IF(IFAIL.EQ.0.AND.NPL.LE.MXEDGE)THEN NPL=NPL+1 XPL(NPL)=XCUT YPL(NPL)=YCUT ZPL(NPL)=ZCUT ELSEIF(NPL.GE.MXEDGE)THEN PRINT *,' !!!!!! PLABXC WARNING : Too many intersects'// - ' between box and plane; stopped.' RETURN ENDIF *** Get rid of butterflies. CALL BUTFLD(NPL,XPL,YPL,ZPL) *** Store the plane. IF(NPL.GE.3)THEN CALL PLABU1('STORE',IRPL,NPL,XPL,YPL,ZPL, - APL,BPL,CPL,ICOL,IVOL,IFAIL) IF(IFAIL.NE.0)PRINT *,' !!!!!! PLABXC WARNING : Failed to'// - ' store a side cut of a box.' ENDIF END +DECK,PLABXO. SUBROUTINE PLABXO(IVOL) *----------------------------------------------------------------------- * PLABXO - Plots the outlines of a box. * (Last changed on 13/ 4/10.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PARAMETERS. +SEQ,SOLIDS. +SEQ,PRINTPLOT. INTEGER IREF,IVOL DOUBLE PRECISION X0,Y0,Z0,XL,YL,ZL,CT,ST,CP,SP,U,V,W, - XPL(5),YPL(5),ZPL(5) *** Locate the conductor. IF(IVOL.LT.1.OR.IVOL.GT.MXSOLI)THEN PRINT *,' !!!!!! PLABXO WARNING : Volume reference is out'// - ' of range ; not plotted.' RETURN ENDIF IREF=ISTART(IVOL) IF(IREF.LT.0.OR.IREF+13.GT.MXSBUF)THEN PRINT *,' !!!!!! PLABXO WARNING : Volume address is out'// - ' of range ; not plotted.' RETURN ENDIF *** Locate the cube parameters. XL=ABS(CBUF(IREF+1)) YL=ABS(CBUF(IREF+2)) ZL=ABS(CBUF(IREF+3)) X0=CBUF(IREF+4) Y0=CBUF(IREF+5) Z0=CBUF(IREF+6) IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLABXO DEBUG : Outlining'', - '' a box from address '',I4/26X,''Centre= '',3E10.3/ - 26X,''Half-lengths='',3E10.3)') IREF,X0,Y0,Z0,XL,YL,ZL * Shorthand for the rotations. CT=CBUF(IREF+10) ST=CBUF(IREF+11) CP=CBUF(IREF+12) SP=CBUF(IREF+13) *** The z=zmin face. U=-XL V=-YL W=-ZL XPL(1)=X0+CP*CT*U-SP*V+CP*ST*W YPL(1)=Y0+SP*CT*U+CP*V+SP*ST*W ZPL(1)=Z0 -ST*U +CT*W U=-XL V=+YL W=-ZL XPL(2)=X0+CP*CT*U-SP*V+CP*ST*W YPL(2)=Y0+SP*CT*U+CP*V+SP*ST*W ZPL(2)=Z0 -ST*U +CT*W U=+XL V=+YL W=-ZL XPL(3)=X0+CP*CT*U-SP*V+CP*ST*W YPL(3)=Y0+SP*CT*U+CP*V+SP*ST*W ZPL(3)=Z0 -ST*U +CT*W U=+XL V=-YL W=-ZL XPL(4)=X0+CP*CT*U-SP*V+CP*ST*W YPL(4)=Y0+SP*CT*U+CP*V+SP*ST*W ZPL(4)=Z0 -ST*U +CT*W XPL(5)=XPL(1) YPL(5)=YPL(1) ZPL(5)=ZPL(1) CALL PLAGPL(5,XPL,YPL,ZPL) *** The z=zmax face. U=-XL V=-YL W=+ZL XPL(1)=X0+CP*CT*U-SP*V+CP*ST*W YPL(1)=Y0+SP*CT*U+CP*V+SP*ST*W ZPL(1)=Z0 -ST*U +CT*W U=-XL V=+YL W=+ZL XPL(2)=X0+CP*CT*U-SP*V+CP*ST*W YPL(2)=Y0+SP*CT*U+CP*V+SP*ST*W ZPL(2)=Z0 -ST*U +CT*W U=+XL V=+YL W=+ZL XPL(3)=X0+CP*CT*U-SP*V+CP*ST*W YPL(3)=Y0+SP*CT*U+CP*V+SP*ST*W ZPL(3)=Z0 -ST*U +CT*W U=+XL V=-YL W=+ZL XPL(4)=X0+CP*CT*U-SP*V+CP*ST*W YPL(4)=Y0+SP*CT*U+CP*V+SP*ST*W ZPL(4)=Z0 -ST*U +CT*W XPL(5)=XPL(1) YPL(5)=YPL(1) ZPL(5)=ZPL(1) CALL PLAGPL(5,XPL,YPL,ZPL) *** The ribs. U=-XL V=-YL W=-ZL XPL(1)=X0+CP*CT*U-SP*V+CP*ST*W YPL(1)=Y0+SP*CT*U+CP*V+SP*ST*W ZPL(1)=Z0 -ST*U +CT*W U=-XL V=-YL W=+ZL XPL(2)=X0+CP*CT*U-SP*V+CP*ST*W YPL(2)=Y0+SP*CT*U+CP*V+SP*ST*W ZPL(2)=Z0 -ST*U +CT*W CALL PLAGPL(2,XPL,YPL,ZPL) U=+XL V=-YL W=-ZL XPL(1)=X0+CP*CT*U-SP*V+CP*ST*W YPL(1)=Y0+SP*CT*U+CP*V+SP*ST*W ZPL(1)=Z0 -ST*U +CT*W U=+XL V=-YL W=+ZL XPL(2)=X0+CP*CT*U-SP*V+CP*ST*W YPL(2)=Y0+SP*CT*U+CP*V+SP*ST*W ZPL(2)=Z0 -ST*U +CT*W CALL PLAGPL(2,XPL,YPL,ZPL) U=-XL V=+YL W=-ZL XPL(1)=X0+CP*CT*U-SP*V+CP*ST*W YPL(1)=Y0+SP*CT*U+CP*V+SP*ST*W ZPL(1)=Z0 -ST*U +CT*W U=-XL V=+YL W=+ZL XPL(2)=X0+CP*CT*U-SP*V+CP*ST*W YPL(2)=Y0+SP*CT*U+CP*V+SP*ST*W ZPL(2)=Z0 -ST*U +CT*W CALL PLAGPL(2,XPL,YPL,ZPL) U=+XL V=+YL W=-ZL XPL(1)=X0+CP*CT*U-SP*V+CP*ST*W YPL(1)=Y0+SP*CT*U+CP*V+SP*ST*W ZPL(1)=Z0 -ST*U +CT*W U=+XL V=+YL W=+ZL XPL(2)=X0+CP*CT*U-SP*V+CP*ST*W YPL(2)=Y0+SP*CT*U+CP*V+SP*ST*W ZPL(2)=Z0 -ST*U +CT*W CALL PLAGPL(2,XPL,YPL,ZPL) END +DECK,PLABXI. SUBROUTINE PLABXI(IVOL,XPOS,YPOS,ZPOS,INSIDE) *----------------------------------------------------------------------- * PLABXI - Determines whether a point is located inside a box. * (Last changed on 8/ 5/10.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CONSTANTS. +SEQ,SOLIDS. +SEQ,PRINTPLOT. INTEGER IVOL,IREF DOUBLE PRECISION XL,YL,ZL,X0,Y0,Z0,CT,ST,CP,SP, - XPOS,YPOS,ZPOS,U,V,W LOGICAL INSIDE *** Locate the conductor. IF(IVOL.LT.1.OR.IVOL.GT.MXSOLI)THEN PRINT *,' !!!!!! PLABXI WARNING : Volume reference is out'// - ' of range ; not checked.' RETURN ENDIF IREF=ISTART(IVOL) IF(IREF.LT.0.OR.IREF+13.GT.MXSBUF)THEN PRINT *,' !!!!!! PLABXI WARNING : Volume address is out'// - ' of range ; not checked.' RETURN ENDIF *** Locate the cube parameters. XL=ABS(CBUF(IREF+1)) YL=ABS(CBUF(IREF+2)) ZL=ABS(CBUF(IREF+3)) X0=CBUF(IREF+4) Y0=CBUF(IREF+5) Z0=CBUF(IREF+6) IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLABXI DEBUG : Checking'', - '' box from address '',I4/ - 26X,''Position = '',3E10.3/ - 26X,''Centre= '',3E10.3/ - 26X,''Half-lengths='',3E10.3)') - IREF,XPOS,YPOS,ZPOS,X0,Y0,Z0,XL,YL,ZL * Shorthand for the rotations. CT=CBUF(IREF+10) ST=CBUF(IREF+11) CP=CBUF(IREF+12) SP=CBUF(IREF+13) *** Transform the point to local coordinates. U=+CP*CT*(XPOS-X0)+SP*CT*(YPOS-Y0)-ST*(ZPOS-Z0) V=-SP *(XPOS-X0)+CP* (YPOS-Y0) W=+CP*ST*(XPOS-X0)+SP*ST*(YPOS-Y0)+CT*(ZPOS-Z0) *** See whether the point is inside. IF(ABS(U).GT.XL.OR.ABS(V).GT.YL.OR.ABS(W).GT.ZL)THEN INSIDE=.FALSE. ELSE INSIDE=.TRUE. ENDIF IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLABXI DEBUG : Inside = '', - L1)') INSIDE END +DECK,PLABXE. SUBROUTINE PLABXE(IVOL,XMIN,YMIN,ZMIN,XMAX,YMAX,ZMAX) *----------------------------------------------------------------------- * PLABXE - Computes an enveloping box * (Last changed on 22/ 2/09.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CONSTANTS. +SEQ,SOLIDS. +SEQ,PRINTPLOT. INTEGER IREF,IVOL DOUBLE PRECISION XL,YL,ZL,X0,Y0,Z0,XMIN,YMIN,ZMIN,XMAX,YMAX,ZMAX *** Locate the conductor. IF(IVOL.LT.1.OR.IVOL.GT.MXSOLI)THEN PRINT *,' !!!!!! PLABXE WARNING : Volume reference is out'// - ' of range ; not checked.' RETURN ENDIF IREF=ISTART(IVOL) IF(IREF.LT.0.OR.IREF+6.GT.MXSBUF)THEN PRINT *,' !!!!!! PLABXE WARNING : Volume address is out'// - ' of range ; not checked.' RETURN ENDIF *** Locate the cube parameters. XL=ABS(CBUF(IREF+1)) YL=ABS(CBUF(IREF+2)) ZL=ABS(CBUF(IREF+3)) X0=CBUF(IREF+4) Y0=CBUF(IREF+5) Z0=CBUF(IREF+6) IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLABXE DEBUG :'', - '' Box from address '',I4/26X,''Centre= '',3E10.3/ - 26X,''Half-lengths='',3E10.3)') IREF,X0,Y0,Z0,XL,YL,ZL *** Take the margins wide. XMIN=X0-SQRT(XL**2+YL**2+ZL**2) YMIN=Y0-SQRT(XL**2+YL**2+ZL**2) ZMIN=Z0-SQRT(XL**2+YL**2+ZL**2) XMAX=X0+SQRT(XL**2+YL**2+ZL**2) YMAX=Y0+SQRT(XL**2+YL**2+ZL**2) ZMAX=Z0+SQRT(XL**2+YL**2+ZL**2) END +DECK,PLABXD. SUBROUTINE PLABXD(ISOL,NVTX,XVTX,YVTX,ZVTX,XNORM,YNORM,ZNORM,DIS) *----------------------------------------------------------------------- * PLABXD - Returns the discretisation level required for a primitive. * (Last changed on 5/ 7/10.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CONSTANTS. +SEQ,SOLIDS. +SEQ,PRINTPLOT. INTEGER ISOL,NVTX,IREF DOUBLE PRECISION XVTX(*), YVTX(*), ZVTX(*), XNORM, YNORM, ZNORM, - CT,ST,CP,SP,U,V,W,DIS *** Locate the conductor. IF(ISOL.LT.1.OR.ISOL.GT.MXSOLI)THEN PRINT *,' !!!!!! PLABXD WARNING : Solid reference is out'// - ' of range ; not checked.' RETURN ENDIF IREF=ISTART(ISOL) IF(IREF.LT.0.OR.IREF+14.GT.MXSBUF)THEN PRINT *,' !!!!!! PLABXD WARNING : Solid address is out'// - ' of range ; not checked.' RETURN ENDIF *** Locate the cylinder rotation parameters. CT=CBUF(IREF+10) ST=CBUF(IREF+11) CP=CBUF(IREF+12) SP=CBUF(IREF+13) *** Transform the normal vector to local coordinates. U=+CP*CT*XNORM+SP*CT*YNORM-ST*ZNORM V=-SP *XNORM+CP* YNORM W=+CP*ST*XNORM+SP*ST*YNORM+CT*ZNORM C print *,' Axis vector: ',u,v,w *** Identify the vector. IF(U.GT.MAX(ABS(V),ABS(W)))THEN DIS=CBUF(IREF+18) ELSEIF(U.LT.-MAX(ABS(V),ABS(W)))THEN DIS=CBUF(IREF+19) ELSEIF(V.GT.MAX(ABS(U),ABS(W)))THEN DIS=CBUF(IREF+20) ELSEIF(V.LT.-MAX(ABS(U),ABS(W)))THEN DIS=CBUF(IREF+21) ELSEIF(W.GT.MAX(ABS(U),ABS(V)))THEN DIS=CBUF(IREF+22) ELSEIF(W.LT.-MAX(ABS(U),ABS(V)))THEN DIS=CBUF(IREF+23) ELSE PRINT *,' !!!!!! PLABXD WARNING : Found no match for the'// - ' box panel; returning 1st value.' DIS=CBUF(IREF+18) ENDIF * Debugging. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLABXD DEBUG :'', - '' Discretisation of solid '',I5,'' (box)''/ - '' Norm vector: '',3F10.3/ - '' Discretisation: '',E12.5)') - ISOL,U,V,W,DIS END +DECK,PLASPP. SUBROUTINE PLASPP(IVOL,IOFCOL) *----------------------------------------------------------------------- * PLASPP - Plots a sphere in 3D perspective. * (Last changed on 7/ 7/10.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CONSTANTS. +SEQ,PARAMETERS. +SEQ,SOLIDS. +SEQ,GRAPHICS. +SEQ,PRINTPLOT. INTEGER IVOL,IREF,IOFCOL,ICOL,NMAX,I,J,N,IFAIL,NPL,IRPL PARAMETER(NMAX=50) DOUBLE PRECISION R,X0,Y0,Z0,WW,PHI0,PHI1,THETA0,THETA1, - XPL(4),YPL(4),ZPL(4),CI,SI *** Locate the conductor. IF(IVOL.LT.1.OR.IVOL.GT.MXSOLI)THEN PRINT *,' !!!!!! PLASPP WARNING : Volume reference is out'// - ' of range ; not plotted.' RETURN ENDIF IREF=ISTART(IVOL) IF(IREF.LT.0.OR.IREF+8.GT.MXSBUF)THEN PRINT *,' !!!!!! PLASPP WARNING : Volume address is out'// - ' of range ; not plotted.' RETURN ENDIF *** Locate the sphere parameters. R= CBUF(IREF+1) IF(R.LE.0)THEN PRINT *,' !!!!!! PLASPP WARNING : Sphere ',IVOL,' has a'// - ' non-positive radius; not plotted.' RETURN ENDIF X0=CBUF(IREF+2) Y0=CBUF(IREF+3) Z0=CBUF(IREF+4) IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLASPP DEBUG : Drawing a'', - '' sphere from address '',I4/26X,''Radius='',E10.3/ - 26X,''Centre='',3E10.3)') IREF,R,X0,Y0,Z0 N= MIN(MXEDGE-1,NMAX-1,NINT(CBUF(IREF+5))) *** Determine a suitable number of points on the radii. IF(N.LT.1)THEN IF(R.LT.1E-3*MAX(ABS(FRXMAX-FRXMIN),ABS(FRYMAX-FRYMIN)))THEN N=MIN(NMAX-1,MXEDGE-1,5) ELSEIF(R.LT.1E-2*MAX(ABS(FRXMAX-FRXMIN), - ABS(FRYMAX-FRYMIN)))THEN N=MIN(NMAX-1,MXEDGE-1,10) ELSEIF(R.LT.1E-1*MAX(ABS(FRXMAX-FRXMIN), - ABS(FRYMAX-FRYMIN)))THEN N=MIN(NMAX-1,MXEDGE-1,20) ELSE N=MIN(NMAX-1,MXEDGE-1) ENDIF ENDIF *** Loop over the sphere. DO 10 I=1,N PHI0=2.0D0*PI*DBLE(I-1)/DBLE(N) PHI1=2.0D0*PI*DBLE(I)/DBLE(N) DO 20 J=1,N THETA0=-PI/2+PI*DBLE(J-1)/DBLE(N) THETA1=-PI/2+PI*DBLE(J)/DBLE(N) * Corners of this parcel. IF(J.EQ.1)THEN XPL(1)=X0+R*COS(PHI0)*COS(THETA0) YPL(1)=Y0+R*SIN(PHI0)*COS(THETA0) ZPL(1)=Z0+R *SIN(THETA0) XPL(2)=X0+R*COS(PHI1)*COS(THETA1) YPL(2)=Y0+R*SIN(PHI1)*COS(THETA1) ZPL(2)=Z0+R *SIN(THETA1) XPL(3)=X0+R*COS(PHI0)*COS(THETA1) YPL(3)=Y0+R*SIN(PHI0)*COS(THETA1) ZPL(3)=Z0+R *SIN(THETA1) NPL=3 ELSEIF(J.EQ.N)THEN XPL(1)=X0+R*COS(PHI0)*COS(THETA0) YPL(1)=Y0+R*SIN(PHI0)*COS(THETA0) ZPL(1)=Z0+R *SIN(THETA0) XPL(2)=X0+R*COS(PHI1)*COS(THETA0) YPL(2)=Y0+R*SIN(PHI1)*COS(THETA0) ZPL(2)=Z0+R *SIN(THETA0) XPL(3)=X0+R*COS(PHI1)*COS(THETA1) YPL(3)=Y0+R*SIN(PHI1)*COS(THETA1) ZPL(3)=Z0+R *SIN(THETA1) NPL=3 ELSE XPL(1)=X0+R*COS(PHI0)*COS(THETA0) YPL(1)=Y0+R*SIN(PHI0)*COS(THETA0) ZPL(1)=Z0+R *SIN(THETA0) XPL(2)=X0+R*COS(PHI1)*COS(THETA0) YPL(2)=Y0+R*SIN(PHI1)*COS(THETA0) ZPL(2)=Z0+R *SIN(THETA0) XPL(3)=X0+R*COS(PHI1)*COS(THETA1) YPL(3)=Y0+R*SIN(PHI1)*COS(THETA1) ZPL(3)=Z0+R *SIN(THETA1) XPL(4)=X0+R*COS(PHI0)*COS(THETA1) YPL(4)=Y0+R*SIN(PHI0)*COS(THETA1) ZPL(4)=Z0+R *SIN(THETA1) NPL=4 ENDIF * Inclination angle in theta. CI=COS(ATAN2( - (COS(THETA0)-COS(THETA1))*SQRT((1+COS(PHI1-PHI0))/2), - SIN(THETA1)-SIN(THETA0))) SI=SIN(ATAN2( - (COS(THETA0)-COS(THETA1))*SQRT((1+COS(PHI1-PHI0))/2), - SIN(THETA1)-SIN(THETA0))) * Compute the colour index. CALL COLWGT(COS((PHI0+PHI1)/2)*CI,SIN((PHI0+PHI1)/2)*CI,SI,WW) IF(WW.GE.0)THEN ICOL=IOFCOL+NINT(MIN(1.0D0,WW)*(NPRCOL-1)) ELSE ICOL=IOFCOL ENDIF * Store the panel. CALL PLABU1('STORE',IRPL,NPL,XPL,YPL,ZPL, - COS((PHI0+PHI1)/2)*CI,SIN((PHI0+PHI1)/2)*CI,SI, - ICOL,IVOL,IFAIL) IF(IFAIL.NE.0)PRINT *,' !!!!!! PLASPP WARNING : Unable to'// - ' store a panel of a sphere.' * Next point. 20 CONTINUE 10 CONTINUE *** Look for intersections with the outside box, x=xmin. CALL PLASPC(IVOL,GXMIN,(GYMIN+GYMAX)/2,(GZMIN+GZMAX)/2, - -1.0D0,0.0D0,0.0D0,IOFCOL+1) * x=xmax. CALL PLASPC(IVOL,GXMAX,(GYMIN+GYMAX)/2,(GZMIN+GZMAX)/2, - +1.0D0,0.0D0,0.0D0,IOFCOL+1) * y=ymin. CALL PLASPC(IVOL,(GXMIN+GXMAX)/2,GYMIN,(GZMIN+GZMAX)/2, - 0.0D0,-1.0D0,0.0D0,IOFCOL+1) * y=ymax. CALL PLASPC(IVOL,(GXMIN+GXMAX)/2,GYMAX,(GZMIN+GZMAX)/2, - 0.0D0,+1.0D0,0.0D0,IOFCOL+1) * z=zmin. CALL PLASPC(IVOL,(GXMIN+GXMAX)/2,(GYMIN+GYMAX)/2,GZMIN, - 0.0D0,0.0D0,-1.0D0,IOFCOL+1) * z=zmax. CALL PLASPC(IVOL,(GXMIN+GXMAX)/2,(GYMIN+GYMAX)/2,GZMAX, - 0.0D0,0.0D0,+1.0D0,IOFCOL+1) END +DECK,PLASPC. SUBROUTINE PLASPC(IVOL,X0PL,Y0PL,Z0PL,APL,BPL,CPL,ICOL) *----------------------------------------------------------------------- * PLASPC - Cuts sphere IVOL with a plane. * (Last changed on 4/ 2/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CONSTANTS. +SEQ,PARAMETERS. +SEQ,SOLIDS. +SEQ,GRAPHICS. +SEQ,PRINTPLOT. INTEGER IREF,IVOL,IFAIL,I,J,NPL,N,NMAX,ICOL,IRPL PARAMETER(NMAX=50) DOUBLE PRECISION X0,Y0,Z0,X1,X2,Y1,Y2,Z1,Z2, - PHI0,PHI1,THETA0,THETA1,R, - XPL(MXEDGE),YPL(MXEDGE),ZPL(MXEDGE), - X0PL,Y0PL,Z0PL,APL,BPL,CPL,XCUT,YCUT,ZCUT *** Locate the conductor. IF(IVOL.LT.1.OR.IVOL.GT.MXSOLI)THEN PRINT *,' !!!!!! PLASPC WARNING : Volume reference is out'// - ' of range ; not plotted.' RETURN ENDIF IREF=ISTART(IVOL) IF(IREF.LT.0.OR.IREF+8.GT.MXSBUF)THEN PRINT *,' !!!!!! PLASPC WARNING : Volume address is out'// - ' of range ; not plotted.' RETURN ENDIF *** Locate the sphere parameters. R= CBUF(IREF+1) IF(R.LE.0)THEN PRINT *,' !!!!!! PLASPC WARNING : Sphere ',IVOL,' has a'// - ' non-positive radius; not plotted.' RETURN ENDIF X0=CBUF(IREF+2) Y0=CBUF(IREF+3) Z0=CBUF(IREF+4) IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLASPC DEBUG : Drawing a'', - '' sphere from address '',I4/26X,''Radius='',E10.3/ - 26X,''Centre='',3E10.3)') IREF,R,X0,Y0,Z0 N= MIN(MXEDGE-1,NMAX-1,NINT(CBUF(IREF+5))) *** Determine a suitable number of points on the radii. IF(N.LT.1)THEN IF(R.LT.1E-3*MAX(ABS(FRXMAX-FRXMIN),ABS(FRYMAX-FRYMIN)))THEN N=MIN(NMAX-1,MXEDGE-1,5) ELSEIF(R.LT.1E-2*MAX(ABS(FRXMAX-FRXMIN), - ABS(FRYMAX-FRYMIN)))THEN N=MIN(NMAX-1,MXEDGE-1,10) ELSEIF(R.LT.1E-1*MAX(ABS(FRXMAX-FRXMIN), - ABS(FRYMAX-FRYMIN)))THEN N=MIN(NMAX-1,MXEDGE-1,20) ELSE N=MIN(NMAX-1,MXEDGE-1) ENDIF ENDIF *** Initialise the number of points on the square. NPL=0 *** Loop over the sphere. DO 10 I=1,N * phi-Coordinates. PHI0=2.0D0*PI*DBLE(I-1)/DBLE(N) PHI1=2.0D0*PI*DBLE(I)/DBLE(N) DO 20 J=1,N * theta-Coordinates. THETA0=-PI/2+PI*DBLE(J-1)/DBLE(N) THETA1=-PI/2+PI*DBLE(J)/DBLE(N) * Reference point of this square. X1=X0+R*COS(PHI0)*COS(THETA0) Y1=Y0+R*SIN(PHI0)*COS(THETA0) Z1=Z0+R *SIN(THETA0) ** The meridian segment, doesn't exist at the S pole. IF(J.GT.0)THEN X2=X0+R*COS(PHI1)*COS(THETA0) Y2=Y0+R*SIN(PHI1)*COS(THETA0) Z2=Z0+R *SIN(THETA0) * Cut with the plane. CALL PLALIN(X1,Y1,Z1,X2,Y2,Z2,X0PL,Y0PL,Z0PL,APL,BPL,CPL, - XCUT,YCUT,ZCUT,IFAIL) * Store the result if there is one. IF(IFAIL.EQ.0.AND.NPL.LE.MXEDGE)THEN NPL=NPL+1 XPL(NPL)=XCUT YPL(NPL)=YCUT ZPL(NPL)=ZCUT ELSEIF(NPL.GE.MXEDGE)THEN PRINT *,' !!!!!! PLASPC WARNING : Too many'// - ' intersects between sphere and plane; stopped.' RETURN ENDIF ENDIF ** The latitude. X2=X0+R*COS(PHI0)*COS(THETA1) Y2=Y0+R*SIN(PHI0)*COS(THETA1) Z2=Z0+R *SIN(THETA1) * Cut with the plane. CALL PLALIN(X1,Y1,Z1,X2,Y2,Z2,X0PL,Y0PL,Z0PL,APL,BPL,CPL, - XCUT,YCUT,ZCUT,IFAIL) * Store the result if there is one. IF(IFAIL.EQ.0.AND.NPL.LE.MXEDGE)THEN NPL=NPL+1 XPL(NPL)=XCUT YPL(NPL)=YCUT ZPL(NPL)=ZCUT ELSEIF(NPL.GE.MXEDGE)THEN PRINT *,' !!!!!! PLASPC WARNING : Too many intersects'// - ' between sphere and plane; stopped.' RETURN ENDIF * Next point. 20 CONTINUE 10 CONTINUE *** Get rid of butterflies. CALL BUTFLD(NPL,XPL,YPL,ZPL) *** Store the plane. IF(NPL.GE.3)THEN CALL PLABU1('STORE',IRPL,NPL,XPL,YPL,ZPL, - APL,BPL,CPL,ICOL,IVOL,IFAIL) IF(IFAIL.NE.0)PRINT *,' !!!!!! PLASPC WARNING : Failed to'// - ' store a side cut of a sphere.' ENDIF END +DECK,PLASPI. SUBROUTINE PLASPI(IVOL,XPOS,YPOS,ZPOS,INSIDE) *----------------------------------------------------------------------- * PLASPI - Determines whether a point is located inside a sphere. * (Last changed on 4/ 2/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CONSTANTS. +SEQ,SOLIDS. +SEQ,PRINTPLOT. INTEGER IVOL,IREF DOUBLE PRECISION R,X0,Y0,Z0,XPOS,YPOS,ZPOS LOGICAL INSIDE *** Locate the conductor. IF(IVOL.LT.1.OR.IVOL.GT.MXSOLI)THEN PRINT *,' !!!!!! PLASPI WARNING : Volume reference is out'// - ' of range ; not checked.' RETURN ENDIF IREF=ISTART(IVOL) IF(IREF.LT.0.OR.IREF+4.GT.MXSBUF)THEN PRINT *,' !!!!!! PLASPI WARNING : Volume address is out'// - ' of range ; not checked.' RETURN ENDIF *** Locate the sphere parameters. R= CBUF(IREF+1) IF(R.LE.0)THEN PRINT *,' !!!!!! PLASPI WARNING : Sphere ',IVOL,' has a'// - ' non-positive radius; not checked.' RETURN ENDIF X0=CBUF(IREF+2) Y0=CBUF(IREF+3) Z0=CBUF(IREF+4) IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLASPI DEBUG : Checking'', - '' sphere from address '',I4/26X,''Radius='',E10.3/ - 26X,''Centre='',3E10.3)') IREF,R,X0,Y0,Z0 *** See whether the point is inside. IF((XPOS-X0)**2+(YPOS-Y0)**2+(ZPOS-Z0)**2.GT.R**2)THEN INSIDE=.FALSE. ELSE INSIDE=.TRUE. ENDIF END +DECK,PLASPE. SUBROUTINE PLASPE(IVOL,XMIN,YMIN,ZMIN,XMAX,YMAX,ZMAX) *----------------------------------------------------------------------- * PLASPE - Computes an enveloping box * (Last changed on 22/ 2/09.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CONSTANTS. +SEQ,SOLIDS. +SEQ,PRINTPLOT. INTEGER IREF,IVOL DOUBLE PRECISION R,X0,Y0,Z0,XMIN,YMIN,ZMIN,XMAX,YMAX,ZMAX *** Locate the conductor. IF(IVOL.LT.1.OR.IVOL.GT.MXSOLI)THEN PRINT *,' !!!!!! PLASPE WARNING : Volume reference is out'// - ' of range ; not checked.' RETURN ENDIF IREF=ISTART(IVOL) IF(IREF.LT.0.OR.IREF+4.GT.MXSBUF)THEN PRINT *,' !!!!!! PLASPE WARNING : Volume address is out'// - ' of range ; not checked.' RETURN ENDIF *** Locate the sphere parameters. R= CBUF(IREF+1) X0=CBUF(IREF+2) Y0=CBUF(IREF+3) Z0=CBUF(IREF+4) IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLASPE DEBUG :'', - '' Sphere from address '',I4/26X,''Radius='',E10.3/ - 26X,''Centre='',3E10.3)') IREF,R,X0,Y0,Z0 *** Take the margins wide. XMIN=X0-R YMIN=Y0-R ZMIN=Z0-R XMAX=X0+R YMAX=Y0+R ZMAX=Z0+R END +DECK,PLASPD. SUBROUTINE PLASPD(ISOL,NVTX,XVTX,YVTX,ZVTX,XNORM,YNORM,ZNORM,DIS) *----------------------------------------------------------------------- * PLASPD - Returns the discretisation level required for a primitive. * (Last changed on 6/ 7/10.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CONSTANTS. +SEQ,SOLIDS. +SEQ,PRINTPLOT. INTEGER ISOL,NVTX,IREF DOUBLE PRECISION XVTX(*), YVTX(*), ZVTX(*), XNORM, YNORM, ZNORM, - DIS *** Locate the conductor. IF(ISOL.LT.1.OR.ISOL.GT.MXSOLI)THEN PRINT *,' !!!!!! PLASPD WARNING : Solid reference is out'// - ' of range ; not checked.' RETURN ENDIF IREF=ISTART(ISOL) IF(IREF.LT.0.OR.IREF+14.GT.MXSBUF)THEN PRINT *,' !!!!!! PLASPD WARNING : Solid address is out'// - ' of range ; not checked.' RETURN ENDIF *** Return the discretisation (only 1 possibility). DIS=CBUF(IREF+10) END +DECK,PLACHP. SUBROUTINE PLACHP(IVOL,IOFCOL) *----------------------------------------------------------------------- * PLACHP - Plots a cylindrical hole in a box. * (Last changed on 26/ 2/11.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CONSTANTS. +SEQ,PARAMETERS. +SEQ,SOLIDS. +SEQ,GRAPHICS. +SEQ,PRINTPLOT. INTEGER IVOL,IREF,IOFCOL,ICOL,IFAIL,N,NMAX,I,ISIDE,IRPL PARAMETER(NMAX=50) DOUBLE PRECISION XL,YL,ZL,X0,Y0,Z0,R1,R2,R,A,B,C,CT,ST,CP,SP, - U,V,W,WW,FNORM,XPL(4),YPL(4),ZPL(4),CI,SI,ALPHA *** Locate the conductor. IF(IVOL.LT.1.OR.IVOL.GT.MXSOLI)THEN PRINT *,' !!!!!! PLACHP WARNING : Volume reference is out'// - ' of range ; not plotted.' RETURN ENDIF IREF=ISTART(IVOL) IF(IREF.LT.0.OR.IREF+11.GT.MXSBUF)THEN PRINT *,' !!!!!! PLACHP WARNING : Volume address is out'// - ' of range ; not plotted.' RETURN ENDIF *** Locate the parameters of the surrounding box and of the cylinder. R1= CBUF(IREF+1) R2= CBUF(IREF+2) IF(R1.LE.0.OR.R2.LE.0)THEN PRINT *,' !!!!!! PLACHP WARNING : Cylindrical hole ',IVOL, - ' has a non-positive radius; not plotted.' RETURN ENDIF XL=ABS(CBUF(IREF+3)) YL=ABS(CBUF(IREF+4)) ZL=ABS(CBUF(IREF+5)) IF(R1.GE.XL.OR.R1.GE.YL.OR.R2.GE.XL.OR.R2.GE.YL)THEN PRINT *,' !!!!!! PLACHP WARNING : Radius of cylindrical', - ' hole ',IVOL,' not smaller than the box; not plotted.' RETURN ENDIF X0=CBUF(IREF+6) Y0=CBUF(IREF+7) Z0=CBUF(IREF+8) FNORM=SQRT(CBUF(IREF+9)**2+CBUF(IREF+10)**2+CBUF(IREF+11)**2) IF(FNORM.LE.0)THEN PRINT *,' !!!!!! PLACHP WARNING : Cylindrical hole ',IVOL, - ' has a zero norm direction vector; not plotted.' RETURN ENDIF A= CBUF(IREF+9)/FNORM B= CBUF(IREF+10)/FNORM C= CBUF(IREF+11)/FNORM N= MIN(MXEDGE-3,NMAX-1,NINT(CBUF(IREF+12))) IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLACHP DEBUG : Drawing a'', - '' hole from address '',I4/26X,''Centre= '',3E10.3/ - 26X,''Half-lengths='',3E10.3/26X,''Direction= '',3E10.3/ - 26X,''Radii= '',2E10.3)') - IREF,X0,Y0,Z0,XL,YL,ZL,A,B,C,R1,R2 * Shorthand for the rotations. CT=CBUF(IREF+13) ST=CBUF(IREF+14) CP=CBUF(IREF+15) SP=CBUF(IREF+16) *** Determine a suitable number of points on the radii. IF(N.LE.1)THEN R=MAX(R1,R2) IF(R.LT.1E-2*MAX(ABS(GXMAX-GXMIN),ABS(GYMAX-GYMIN), - ABS(GZMAX-GZMIN)))THEN N=MIN(MXEDGE-3,NMAX-1,2) ELSEIF(R.LT.1E-1*MAX(ABS(GXMAX-GXMIN),ABS(GYMAX-GYMIN), - ABS(GZMAX-GZMIN)))THEN N=MIN(MXEDGE-3,NMAX-1,3) ELSE N=MIN(MXEDGE-3,NMAX-1,4) ENDIF ENDIF *** Adjust the mean radii if requested IF(CBUF(IREF+28).GT.0.5)THEN ALPHA = PI/(4.0D0*DBLE(N-1)) R1 = 2*R1/(1.0D0 + ASINH(TAN(ALPHA))*COS(ALPHA)/TAN(ALPHA)) R2 = 2*R2/(1.0D0 + ASINH(TAN(ALPHA))*COS(ALPHA)/TAN(ALPHA)) ENDIF *** Draw the 6 sides of the box, start with the x=xmin face. U=-XL V=-YL W=-ZL XPL(1)=X0+CP*CT*U-SP*V+CP*ST*W YPL(1)=Y0+SP*CT*U+CP*V+SP*ST*W ZPL(1)=Z0 -ST*U +CT*W U=-XL V=+YL W=-ZL XPL(2)=X0+CP*CT*U-SP*V+CP*ST*W YPL(2)=Y0+SP*CT*U+CP*V+SP*ST*W ZPL(2)=Z0 -ST*U +CT*W U=-XL V=+YL W=+ZL XPL(3)=X0+CP*CT*U-SP*V+CP*ST*W YPL(3)=Y0+SP*CT*U+CP*V+SP*ST*W ZPL(3)=Z0 -ST*U +CT*W U=-XL V=-YL W=+ZL XPL(4)=X0+CP*CT*U-SP*V+CP*ST*W YPL(4)=Y0+SP*CT*U+CP*V+SP*ST*W ZPL(4)=Z0 -ST*U +CT*W CALL COLWGT(-CP*CT,-SP*CT,+ST,WW) IF(WW.GE.0)THEN ICOL=IOFCOL+NINT(MIN(1.0D0,WW)*(NPRCOL-1)) ELSE ICOL=IOFCOL ENDIF CALL PLABU1('STORE',IRPL,4,XPL,YPL,ZPL,-CP*CT,-SP*CT,+ST, - ICOL,IVOL,IFAIL) IF(IFAIL.NE.0)PRINT *,' !!!!!! PLACHP WARNING : Unable to'// - ' store a panel of a box.' * The x=xmax face. U=+XL V=-YL W=-ZL XPL(1)=X0+CP*CT*U-SP*V+CP*ST*W YPL(1)=Y0+SP*CT*U+CP*V+SP*ST*W ZPL(1)=Z0 -ST*U +CT*W U=+XL V=+YL W=-ZL XPL(2)=X0+CP*CT*U-SP*V+CP*ST*W YPL(2)=Y0+SP*CT*U+CP*V+SP*ST*W ZPL(2)=Z0 -ST*U +CT*W U=+XL V=+YL W=+ZL XPL(3)=X0+CP*CT*U-SP*V+CP*ST*W YPL(3)=Y0+SP*CT*U+CP*V+SP*ST*W ZPL(3)=Z0 -ST*U +CT*W U=+XL V=-YL W=+ZL XPL(4)=X0+CP*CT*U-SP*V+CP*ST*W YPL(4)=Y0+SP*CT*U+CP*V+SP*ST*W ZPL(4)=Z0 -ST*U +CT*W CALL COLWGT(CP*CT,SP*CT,-ST,WW) IF(WW.GE.0)THEN ICOL=IOFCOL+NINT(MIN(1.0D0,WW)*(NPRCOL-1)) ELSE ICOL=IOFCOL ENDIF CALL PLABU1('STORE',IRPL,4,XPL,YPL,ZPL,CP*CT,SP*CT,-ST, - ICOL,IVOL,IFAIL) IF(IFAIL.NE.0)PRINT *,' !!!!!! PLACHP WARNING : Unable to'// - ' store a panel of a box.' * The y=ymin face. U=-XL V=-YL W=-ZL XPL(1)=X0+CP*CT*U-SP*V+CP*ST*W YPL(1)=Y0+SP*CT*U+CP*V+SP*ST*W ZPL(1)=Z0 -ST*U +CT*W U=+XL V=-YL W=-ZL XPL(2)=X0+CP*CT*U-SP*V+CP*ST*W YPL(2)=Y0+SP*CT*U+CP*V+SP*ST*W ZPL(2)=Z0 -ST*U +CT*W U=+XL V=-YL W=+ZL XPL(3)=X0+CP*CT*U-SP*V+CP*ST*W YPL(3)=Y0+SP*CT*U+CP*V+SP*ST*W ZPL(3)=Z0 -ST*U +CT*W U=-XL V=-YL W=+ZL XPL(4)=X0+CP*CT*U-SP*V+CP*ST*W YPL(4)=Y0+SP*CT*U+CP*V+SP*ST*W ZPL(4)=Z0 -ST*U +CT*W CALL COLWGT(+SP,-CP,0.0D0,WW) IF(WW.GE.0)THEN ICOL=IOFCOL+NINT(MIN(1.0D0,WW)*(NPRCOL-1)) ELSE ICOL=IOFCOL ENDIF CALL PLABU1('STORE',IRPL,4,XPL,YPL,ZPL,SP,-CP,0.0D0, - ICOL,IVOL,IFAIL) IF(IFAIL.NE.0)PRINT *,' !!!!!! PLACHP WARNING : Unable to'// - ' store a panel of a box.' * The y=ymax face. U=-XL V=+YL W=-ZL XPL(1)=X0+CP*CT*U-SP*V+CP*ST*W YPL(1)=Y0+SP*CT*U+CP*V+SP*ST*W ZPL(1)=Z0 -ST*U +CT*W U=+XL V=+YL W=-ZL XPL(2)=X0+CP*CT*U-SP*V+CP*ST*W YPL(2)=Y0+SP*CT*U+CP*V+SP*ST*W ZPL(2)=Z0 -ST*U +CT*W U=+XL V=+YL W=+ZL XPL(3)=X0+CP*CT*U-SP*V+CP*ST*W YPL(3)=Y0+SP*CT*U+CP*V+SP*ST*W ZPL(3)=Z0 -ST*U +CT*W U=-XL V=+YL W=+ZL XPL(4)=X0+CP*CT*U-SP*V+CP*ST*W YPL(4)=Y0+SP*CT*U+CP*V+SP*ST*W ZPL(4)=Z0 -ST*U +CT*W CALL COLWGT(-SP,+CP,0.0D0,WW) IF(WW.GE.0)THEN ICOL=IOFCOL+NINT(MIN(1.0D0,WW)*(NPRCOL-1)) ELSE ICOL=IOFCOL ENDIF CALL PLABU1('STORE',IRPL,4,XPL,YPL,ZPL,-SP,+CP,0.0D0, - ICOL,IVOL,IFAIL) IF(IFAIL.NE.0)PRINT *,' !!!!!! PLACHP WARNING : Unable to'// - ' store a panel of a box.' * The faces at constant z have a hole, and are drawn in parts. DO 10 ISIDE=-1,+1,2 IF(ISIDE.EQ.-1)THEN R=R1 ELSE R=R2 ENDIF * All sub-panels have the same colour. CALL COLWGT(ISIDE*CP*ST,ISIDE*SP*ST,ISIDE*CT,WW) IF(WW.GE.0)THEN ICOL=IOFCOL+NINT(MIN(1.0D0,WW)*(NPRCOL-1)) ELSE ICOL=IOFCOL ENDIF * Loop over the panels. DO 20 I=1,N-1 * The panels for x=xmax. U=R*COS(-PI/4+(PI/2)*DBLE(I-1)/DBLE(N-1)) V=R*SIN(-PI/4+(PI/2)*DBLE(I-1)/DBLE(N-1)) W=ZL*ISIDE XPL(1)=X0+CP*CT*U-SP*V+CP*ST*W YPL(1)=Y0+SP*CT*U+CP*V+SP*ST*W ZPL(1)=Z0 -ST*U +CT*W U=XL V=YL*TAN(-PI/4+(PI/2)*DBLE(I-1)/DBLE(N-1)) W=ZL*ISIDE XPL(2)=X0+CP*CT*U-SP*V+CP*ST*W YPL(2)=Y0+SP*CT*U+CP*V+SP*ST*W ZPL(2)=Z0 -ST*U +CT*W U=XL V=YL*TAN(-PI/4+(PI/2)*DBLE(I )/DBLE(N-1)) W=ZL*ISIDE XPL(3)=X0+CP*CT*U-SP*V+CP*ST*W YPL(3)=Y0+SP*CT*U+CP*V+SP*ST*W ZPL(3)=Z0 -ST*U +CT*W U=R*COS(-PI/4+(PI/2)*DBLE(I )/DBLE(N-1)) V=R*SIN(-PI/4+(PI/2)*DBLE(I )/DBLE(N-1)) W=ZL*ISIDE XPL(4)=X0+CP*CT*U-SP*V+CP*ST*W YPL(4)=Y0+SP*CT*U+CP*V+SP*ST*W ZPL(4)=Z0 -ST*U +CT*W CALL PLABU1('STORE',IRPL,4,XPL,YPL,ZPL, - ISIDE*CP*ST,ISIDE*SP*ST,ISIDE*CT, - ICOL,IVOL,IFAIL) IF(IFAIL.NE.0)PRINT *,' !!!!!! PLACHP WARNING : Unable to'// - ' store a panel of a box.' * The panels for y=ymax. U=R*COS(+PI/4+(PI/2)*DBLE(I-1)/DBLE(N-1)) V=R*SIN(+PI/4+(PI/2)*DBLE(I-1)/DBLE(N-1)) W=ZL*ISIDE XPL(1)=X0+CP*CT*U-SP*V+CP*ST*W YPL(1)=Y0+SP*CT*U+CP*V+SP*ST*W ZPL(1)=Z0 -ST*U +CT*W U=-XL*TAN(-PI/4+(PI/2)*DBLE(I-1)/DBLE(N-1)) V=YL W=ZL*ISIDE XPL(2)=X0+CP*CT*U-SP*V+CP*ST*W YPL(2)=Y0+SP*CT*U+CP*V+SP*ST*W ZPL(2)=Z0 -ST*U +CT*W U=-XL*TAN(-PI/4+(PI/2)*DBLE(I )/DBLE(N-1)) V=YL W=ZL*ISIDE XPL(3)=X0+CP*CT*U-SP*V+CP*ST*W YPL(3)=Y0+SP*CT*U+CP*V+SP*ST*W ZPL(3)=Z0 -ST*U +CT*W U=R*COS(+PI/4+(PI/2)*DBLE(I )/DBLE(N-1)) V=R*SIN(+PI/4+(PI/2)*DBLE(I )/DBLE(N-1)) W=ZL*ISIDE XPL(4)=X0+CP*CT*U-SP*V+CP*ST*W YPL(4)=Y0+SP*CT*U+CP*V+SP*ST*W ZPL(4)=Z0 -ST*U +CT*W CALL PLABU1('STORE',IRPL,4,XPL,YPL,ZPL, - ISIDE*CP*ST,ISIDE*SP*ST,ISIDE*CT, - ICOL,IVOL,IFAIL) IF(IFAIL.NE.0)PRINT *,' !!!!!! PLACHP WARNING : Unable to'// - ' store a panel of a box.' * The panels for x=xmin. U=R*COS(3*PI/4+(PI/2)*DBLE(I-1)/DBLE(N-1)) V=R*SIN(3*PI/4+(PI/2)*DBLE(I-1)/DBLE(N-1)) W=ZL*ISIDE XPL(1)=X0+CP*CT*U-SP*V+CP*ST*W YPL(1)=Y0+SP*CT*U+CP*V+SP*ST*W ZPL(1)=Z0 -ST*U +CT*W U=-XL V=-YL*TAN(-PI/4+(PI/2)*DBLE(I-1)/DBLE(N-1)) W=ZL*ISIDE XPL(2)=X0+CP*CT*U-SP*V+CP*ST*W YPL(2)=Y0+SP*CT*U+CP*V+SP*ST*W ZPL(2)=Z0 -ST*U +CT*W U=-XL V=-YL*TAN(-PI/4+(PI/2)*DBLE(I )/DBLE(N-1)) W=ZL*ISIDE XPL(3)=X0+CP*CT*U-SP*V+CP*ST*W YPL(3)=Y0+SP*CT*U+CP*V+SP*ST*W ZPL(3)=Z0 -ST*U +CT*W U=R*COS(3*PI/4+(PI/2)*DBLE(I )/DBLE(N-1)) V=R*SIN(3*PI/4+(PI/2)*DBLE(I )/DBLE(N-1)) W=ZL*ISIDE XPL(4)=X0+CP*CT*U-SP*V+CP*ST*W YPL(4)=Y0+SP*CT*U+CP*V+SP*ST*W ZPL(4)=Z0 -ST*U +CT*W CALL PLABU1('STORE',IRPL,4,XPL,YPL,ZPL, - ISIDE*CP*ST,ISIDE*SP*ST,ISIDE*CT, - ICOL,IVOL,IFAIL) IF(IFAIL.NE.0)PRINT *,' !!!!!! PLACHP WARNING : Unable to'// - ' store a panel of a box.' * The panels for y=ymin. U=R*COS(-3*PI/4+(PI/2)*DBLE(I-1)/DBLE(N-1)) V=R*SIN(-3*PI/4+(PI/2)*DBLE(I-1)/DBLE(N-1)) W=ZL*ISIDE XPL(1)=X0+CP*CT*U-SP*V+CP*ST*W YPL(1)=Y0+SP*CT*U+CP*V+SP*ST*W ZPL(1)=Z0 -ST*U +CT*W U=XL*TAN(-PI/4+(PI/2)*DBLE(I-1)/DBLE(N-1)) V=-YL W=ZL*ISIDE XPL(2)=X0+CP*CT*U-SP*V+CP*ST*W YPL(2)=Y0+SP*CT*U+CP*V+SP*ST*W ZPL(2)=Z0 -ST*U +CT*W U=XL*TAN(-PI/4+(PI/2)*DBLE(I )/DBLE(N-1)) V=-YL W=ZL*ISIDE XPL(3)=X0+CP*CT*U-SP*V+CP*ST*W YPL(3)=Y0+SP*CT*U+CP*V+SP*ST*W ZPL(3)=Z0 -ST*U +CT*W U=R*COS(-3*PI/4+(PI/2)*DBLE(I )/DBLE(N-1)) V=R*SIN(-3*PI/4+(PI/2)*DBLE(I )/DBLE(N-1)) W=ZL*ISIDE XPL(4)=X0+CP*CT*U-SP*V+CP*ST*W YPL(4)=Y0+SP*CT*U+CP*V+SP*ST*W ZPL(4)=Z0 -ST*U +CT*W CALL PLABU1('STORE',IRPL,4,XPL,YPL,ZPL, - ISIDE*CP*ST,ISIDE*SP*ST,ISIDE*CT, - ICOL,IVOL,IFAIL) IF(IFAIL.NE.0)PRINT *,' !!!!!! PLACHP WARNING : Unable to'// - ' store a panel of a box.' 20 CONTINUE 10 CONTINUE *** The panels of the central cylinder, compute the projection angles. CI=COS(ATAN2((R1-R2)*COS(PI/(4*(N-1))),2*ZL)) SI=SIN(ATAN2((R1-R2)*COS(PI/(4*(N-1))),2*ZL)) * Initialise loop. U=R1*COS(-PI/4) V=R1*SIN(-PI/4) W=-ZL XPL(1)=X0+CP*CT*U-SP*V+CP*ST*W YPL(1)=Y0+SP*CT*U+CP*V+SP*ST*W ZPL(1)=Z0 -ST*U +CT*W U=R2*COS(-PI/4) V=R2*SIN(-PI/4) W=+ZL XPL(2)=X0+CP*CT*U-SP*V+CP*ST*W YPL(2)=Y0+SP*CT*U+CP*V+SP*ST*W ZPL(2)=Z0 -ST*U +CT*W ** Go around the cylinder. DO 40 I=2,4*N-3 * Bottom and top of the line along the axis of the cylinder. U=R2*COS(-PI/4+(PI/2)*DBLE(I-1)/DBLE(N-1)) V=R2*SIN(-PI/4+(PI/2)*DBLE(I-1)/DBLE(N-1)) W=+ZL XPL(3)=X0+CP*CT*U-SP*V+CP*ST*W YPL(3)=Y0+SP*CT*U+CP*V+SP*ST*W ZPL(3)=Z0 -ST*U +CT*W U=R1*COS(-PI/4+(PI/2)*DBLE(I-1)/DBLE(N-1)) V=R1*SIN(-PI/4+(PI/2)*DBLE(I-1)/DBLE(N-1)) W=-ZL XPL(4)=X0+CP*CT*U-SP*V+CP*ST*W YPL(4)=Y0+SP*CT*U+CP*V+SP*ST*W ZPL(4)=Z0 -ST*U +CT*W * Compute the colour index for this segment. CALL COLWGT( - -CP*CT*COS(-PI/4+(PI/2)*(I-1.5)/DBLE(N-1))*CI+ - SP* SIN(-PI/4+(PI/2)*(I-1.5)/DBLE(N-1))*CI- - CP*ST *SI, - -SP*CT*COS(-PI/4+(PI/2)*(I-1.5)/DBLE(N-1))*CI- - CP* SIN(-PI/4+(PI/2)*(I-1.5)/DBLE(N-1))*CI- - SP*ST *SI, - ST* COS(-PI/4+(PI/2)*(I-1.5)/DBLE(N-1))*CI- - CT *SI, - WW) IF(WW.GT.0)THEN ICOL=IOFCOL+NINT(MIN(1.0D0,WW)*(NPRCOL-1)) ELSE ICOL=IOFCOL ENDIF * Store the plane. CALL PLABU1('STORE',IRPL,4,XPL,YPL,ZPL, - -CP*CT*COS(-PI/4+(PI/2)*(I-1.5)/DBLE(N-1))*CI+ - SP* SIN(-PI/4+(PI/2)*(I-1.5)/DBLE(N-1))*CI- - CP*ST *SI, - -SP*CT*COS(-PI/4+(PI/2)*(I-1.5)/DBLE(N-1))*CI- - CP* SIN(-PI/4+(PI/2)*(I-1.5)/DBLE(N-1))*CI- - SP*ST *SI, - ST* COS(-PI/4+(PI/2)*(I-1.5)/DBLE(N-1))*CI- - CT *SI, - ICOL,IVOL,IFAIL) IF(IFAIL.NE.0)PRINT *,' !!!!!! PLACHP WARNING : Unable to'// - ' store a panel of a cylinder.' * Shift the points. XPL(1)=XPL(4) YPL(1)=YPL(4) ZPL(1)=ZPL(4) XPL(2)=XPL(3) YPL(2)=YPL(3) ZPL(2)=ZPL(3) 40 CONTINUE *** Look for intersections with the outside box, x=xmin. CALL PLACHC(IVOL,GXMIN,(GYMIN+GYMAX)/2,(GZMIN+GZMAX)/2, - -1.0D0,0.0D0,0.0D0,IOFCOL+1) * x=xmax. CALL PLACHC(IVOL,GXMAX,(GYMIN+GYMAX)/2,(GZMIN+GZMAX)/2, - +1.0D0,0.0D0,0.0D0,IOFCOL+1) * y=ymin. CALL PLACHC(IVOL,(GXMIN+GXMAX)/2,GYMIN,(GZMIN+GZMAX)/2, - 0.0D0,-1.0D0,0.0D0,IOFCOL+1) * y=ymax. CALL PLACHC(IVOL,(GXMIN+GXMAX)/2,GYMAX,(GZMIN+GZMAX)/2, - 0.0D0,+1.0D0,0.0D0,IOFCOL+1) * z=zmin. CALL PLACHC(IVOL,(GXMIN+GXMAX)/2,(GYMIN+GYMAX)/2,GZMIN, - 0.0D0,0.0D0,-1.0D0,IOFCOL+1) * z=zmax. CALL PLACHC(IVOL,(GXMIN+GXMAX)/2,(GYMIN+GYMAX)/2,GZMAX, - 0.0D0,0.0D0,+1.0D0,IOFCOL+1) END +DECK,PLACHC. SUBROUTINE PLACHC(IVOL,X0PL,Y0PL,Z0PL,APL,BPL,CPL,ICOL) *----------------------------------------------------------------------- * PLACHC - Cuts a cylindrical hole with a plane. * (Last changed on 27/ 2/11.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CONSTANTS. +SEQ,PARAMETERS. +SEQ,SOLIDS. +SEQ,GRAPHICS. +SEQ,PRINTPLOT. INTEGER IREF,IVOL,IFAIL,NCUT,N,NMAX,I,ICOL,ISIDE,IRPL PARAMETER(NMAX=50) DOUBLE PRECISION X0,Y0,Z0,A,B,C,XL,YL,ZL,CT,ST,CP,SP, - FNORM,U,V,W,R1,R2,R, - XBOX(8),YBOX(8),ZBOX(8),XCUT(12),YCUT(12),ZCUT(12), - X0PL,Y0PL,Z0PL,APL,BPL,CPL,ALPHA *** Locate the conductor. IF(IVOL.LT.1.OR.IVOL.GT.MXSOLI)THEN PRINT *,' !!!!!! PLACHC WARNING : Volume reference is out'// - ' of range ; not plotted.' RETURN ENDIF IREF=ISTART(IVOL) IF(IREF.LT.0.OR.IREF+11.GT.MXSBUF)THEN PRINT *,' !!!!!! PLACHC WARNING : Volume address is out'// - ' of range ; not plotted.' RETURN ENDIF *** Locate the parameters of the surrounding box and of the cylinder. R1= CBUF(IREF+1) R2= CBUF(IREF+2) IF(R1.LE.0.OR.R2.LE.0)THEN PRINT *,' !!!!!! PLACHC WARNING : Cylindrical hole ',IREF, - ' has a non-positive radius; not plotted.' RETURN ENDIF XL=ABS(CBUF(IREF+3)) YL=ABS(CBUF(IREF+4)) ZL=ABS(CBUF(IREF+5)) IF(R1.GE.XL.OR.R1.GE.YL.OR.R2.GE.XL.OR.R2.GE.YL)THEN PRINT *,' !!!!!! PLACHC WARNING : Radius of cylindrical', - ' hole ',IREF,' not smaller than the box; not plotted.' RETURN ENDIF X0=CBUF(IREF+6) Y0=CBUF(IREF+7) Z0=CBUF(IREF+8) FNORM=SQRT(CBUF(IREF+9)**2+CBUF(IREF+10)**2+CBUF(IREF+11)**2) IF(FNORM.LE.0)THEN PRINT *,' !!!!!! PLACHC WARNING : Cylindrical hole ',IREF, - ' has a zero norm direction vector; not plotted.' RETURN ENDIF A= CBUF(IREF+9)/FNORM B= CBUF(IREF+10)/FNORM C= CBUF(IREF+11)/FNORM N= MIN(MXEDGE-3,NMAX-1,NINT(CBUF(IREF+12))) IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLACHC DEBUG : Drawing a'', - '' hole from address '',I4/26X,''Centre= '',3E10.3/ - 26X,''Half-lengths='',3E10.3/26X,''Direction= '',3E10.3/ - 26X,''Radii= '',2E10.3)') - IREF,X0,Y0,Z0,XL,YL,ZL,A,B,C,R1,R2 * Shorthand for the rotations. CT=CBUF(IREF+13) ST=CBUF(IREF+14) CP=CBUF(IREF+15) SP=CBUF(IREF+16) *** Determine a suitable number of points on the radii. IF(N.LE.1)THEN R=MAX(R1,R2) IF(R.LT.1E-2*MAX(ABS(GXMAX-GXMIN),ABS(GYMAX-GYMIN), - ABS(GZMAX-GZMIN)))THEN N=MIN(MXEDGE-3,NMAX-1,2) ELSEIF(R.LT.1E-1*MAX(ABS(GXMAX-GXMIN),ABS(GYMAX-GYMIN), - ABS(GZMAX-GZMIN)))THEN N=MIN(MXEDGE-3,NMAX-1,3) ELSE N=MIN(MXEDGE-3,NMAX-1,4) ENDIF ENDIF *** Adjust the mean radii if requested IF(CBUF(IREF+28).GT.0.5)THEN ALPHA = PI/(4.0D0*DBLE(N-1)) R1 = 2*R1/(1.0D0 + ASINH(TAN(ALPHA))*COS(ALPHA)/TAN(ALPHA)) R2 = 2*R2/(1.0D0 + ASINH(TAN(ALPHA))*COS(ALPHA)/TAN(ALPHA)) ENDIF *** Loop over the boxes that make up the hole. DO 10 I=1,N-1 * The boxes ending at x=xmax. DO 20 ISIDE=-1,+1,2 IF(ISIDE.EQ.-1)THEN R=R1 ELSE R=R2 ENDIF U=R*COS(-PI/4+(PI/2)*DBLE(I-1)/DBLE(N-1)) V=R*SIN(-PI/4+(PI/2)*DBLE(I-1)/DBLE(N-1)) W=ISIDE*ZL XBOX(2+2*ISIDE+1)=X0+CP*CT*U-SP*V+CP*ST*W YBOX(2+2*ISIDE+1)=Y0+SP*CT*U+CP*V+SP*ST*W ZBOX(2+2*ISIDE+1)=Z0 -ST*U +CT*W U=XL V=YL*TAN(-PI/4+(PI/2)*DBLE(I-1)/DBLE(N-1)) W=ISIDE*ZL XBOX(2+2*ISIDE+2)=X0+CP*CT*U-SP*V+CP*ST*W YBOX(2+2*ISIDE+2)=Y0+SP*CT*U+CP*V+SP*ST*W ZBOX(2+2*ISIDE+2)=Z0 -ST*U +CT*W U=XL V=YL*TAN(-PI/4+(PI/2)*DBLE(I )/DBLE(N-1)) W=ISIDE*ZL XBOX(2+2*ISIDE+3)=X0+CP*CT*U-SP*V+CP*ST*W YBOX(2+2*ISIDE+3)=Y0+SP*CT*U+CP*V+SP*ST*W ZBOX(2+2*ISIDE+3)=Z0 -ST*U +CT*W U=R*COS(-PI/4+(PI/2)*DBLE(I )/DBLE(N-1)) V=R*SIN(-PI/4+(PI/2)*DBLE(I )/DBLE(N-1)) W=ISIDE*ZL XBOX(2+2*ISIDE+4)=X0+CP*CT*U-SP*V+CP*ST*W YBOX(2+2*ISIDE+4)=Y0+SP*CT*U+CP*V+SP*ST*W ZBOX(2+2*ISIDE+4)=Z0 -ST*U +CT*W 20 CONTINUE CALL PLABOX(XBOX,YBOX,ZBOX,NCUT,XCUT,YCUT,ZCUT, - X0PL,Y0PL,Z0PL,APL,BPL,CPL) IF(NCUT.GE.3)THEN CALL PLABU1('STORE',IRPL,NCUT,XCUT,YCUT,ZCUT, - APL,BPL,CPL,ICOL,IVOL,IFAIL) IF(IFAIL.NE.0)PRINT *,' !!!!!! PLACHC WARNING : Unable to'// - ' store a panel of a box.' ENDIF * The panels for y=ymax. DO 30 ISIDE=-1,+1,2 IF(ISIDE.EQ.-1)THEN R=R1 ELSE R=R2 ENDIF U=R*COS(+PI/4+(PI/2)*DBLE(I-1)/DBLE(N-1)) V=R*SIN(+PI/4+(PI/2)*DBLE(I-1)/DBLE(N-1)) W=ZL*ISIDE XBOX(2+2*ISIDE+1)=X0+CP*CT*U-SP*V+CP*ST*W YBOX(2+2*ISIDE+1)=Y0+SP*CT*U+CP*V+SP*ST*W ZBOX(2+2*ISIDE+1)=Z0 -ST*U +CT*W U=-XL*TAN(-PI/4+(PI/2)*DBLE(I-1)/DBLE(N-1)) V=YL W=ZL*ISIDE XBOX(2+2*ISIDE+2)=X0+CP*CT*U-SP*V+CP*ST*W YBOX(2+2*ISIDE+2)=Y0+SP*CT*U+CP*V+SP*ST*W ZBOX(2+2*ISIDE+2)=Z0 -ST*U +CT*W U=-XL*TAN(-PI/4+(PI/2)*DBLE(I )/DBLE(N-1)) V=YL W=ZL*ISIDE XBOX(2+2*ISIDE+3)=X0+CP*CT*U-SP*V+CP*ST*W YBOX(2+2*ISIDE+3)=Y0+SP*CT*U+CP*V+SP*ST*W ZBOX(2+2*ISIDE+3)=Z0 -ST*U +CT*W U=R*COS(+PI/4+(PI/2)*DBLE(I )/DBLE(N-1)) V=R*SIN(+PI/4+(PI/2)*DBLE(I )/DBLE(N-1)) W=ZL*ISIDE XBOX(2+2*ISIDE+4)=X0+CP*CT*U-SP*V+CP*ST*W YBOX(2+2*ISIDE+4)=Y0+SP*CT*U+CP*V+SP*ST*W ZBOX(2+2*ISIDE+4)=Z0 -ST*U +CT*W 30 CONTINUE CALL PLABOX(XBOX,YBOX,ZBOX,NCUT,XCUT,YCUT,ZCUT, - X0PL,Y0PL,Z0PL,APL,BPL,CPL) IF(NCUT.GE.3)THEN CALL PLABU1('STORE',IRPL,NCUT,XCUT,YCUT,ZCUT, - APL,BPL,CPL,ICOL,IVOL,IFAIL) IF(IFAIL.NE.0)PRINT *,' !!!!!! PLACHC WARNING : Unable to'// - ' store a panel of a box.' ENDIF * The panels for x=xmin. DO 40 ISIDE=-1,+1,2 IF(ISIDE.EQ.-1)THEN R=R1 ELSE R=R2 ENDIF U=R*COS(3*PI/4+(PI/2)*DBLE(I-1)/DBLE(N-1)) V=R*SIN(3*PI/4+(PI/2)*DBLE(I-1)/DBLE(N-1)) W=ZL*ISIDE XBOX(2+2*ISIDE+1)=X0+CP*CT*U-SP*V+CP*ST*W YBOX(2+2*ISIDE+1)=Y0+SP*CT*U+CP*V+SP*ST*W ZBOX(2+2*ISIDE+1)=Z0 -ST*U +CT*W U=-XL V=-YL*TAN(-PI/4+(PI/2)*DBLE(I-1)/DBLE(N-1)) W=ZL*ISIDE XBOX(2+2*ISIDE+2)=X0+CP*CT*U-SP*V+CP*ST*W YBOX(2+2*ISIDE+2)=Y0+SP*CT*U+CP*V+SP*ST*W ZBOX(2+2*ISIDE+2)=Z0 -ST*U +CT*W U=-XL V=-YL*TAN(-PI/4+(PI/2)*DBLE(I )/DBLE(N-1)) W=ZL*ISIDE XBOX(2+2*ISIDE+3)=X0+CP*CT*U-SP*V+CP*ST*W YBOX(2+2*ISIDE+3)=Y0+SP*CT*U+CP*V+SP*ST*W ZBOX(2+2*ISIDE+3)=Z0 -ST*U +CT*W U=R*COS(3*PI/4+(PI/2)*DBLE(I )/DBLE(N-1)) V=R*SIN(3*PI/4+(PI/2)*DBLE(I )/DBLE(N-1)) W=ZL*ISIDE XBOX(2+2*ISIDE+4)=X0+CP*CT*U-SP*V+CP*ST*W YBOX(2+2*ISIDE+4)=Y0+SP*CT*U+CP*V+SP*ST*W ZBOX(2+2*ISIDE+4)=Z0 -ST*U +CT*W 40 CONTINUE CALL PLABOX(XBOX,YBOX,ZBOX,NCUT,XCUT,YCUT,ZCUT, - X0PL,Y0PL,Z0PL,APL,BPL,CPL) IF(NCUT.GE.3)THEN CALL PLABU1('STORE',IRPL,NCUT,XCUT,YCUT,ZCUT, - APL,BPL,CPL,ICOL,IVOL,IFAIL) IF(IFAIL.NE.0)PRINT *,' !!!!!! PLACHC WARNING : Unable to'// - ' store a panel of a box.' ENDIF * The panels for y=ymin. DO 50 ISIDE=-1,+1,2 IF(ISIDE.EQ.-1)THEN R=R1 ELSE R=R2 ENDIF U=R*COS(-3*PI/4+(PI/2)*DBLE(I-1)/DBLE(N-1)) V=R*SIN(-3*PI/4+(PI/2)*DBLE(I-1)/DBLE(N-1)) W=ZL*ISIDE XBOX(2+2*ISIDE+1)=X0+CP*CT*U-SP*V+CP*ST*W YBOX(2+2*ISIDE+1)=Y0+SP*CT*U+CP*V+SP*ST*W ZBOX(2+2*ISIDE+1)=Z0 -ST*U +CT*W U=XL*TAN(-PI/4+(PI/2)*DBLE(I-1)/DBLE(N-1)) V=-YL W=ZL*ISIDE XBOX(2+2*ISIDE+2)=X0+CP*CT*U-SP*V+CP*ST*W YBOX(2+2*ISIDE+2)=Y0+SP*CT*U+CP*V+SP*ST*W ZBOX(2+2*ISIDE+2)=Z0 -ST*U +CT*W U=XL*TAN(-PI/4+(PI/2)*DBLE(I )/DBLE(N-1)) V=-YL W=ZL*ISIDE XBOX(2+2*ISIDE+3)=X0+CP*CT*U-SP*V+CP*ST*W YBOX(2+2*ISIDE+3)=Y0+SP*CT*U+CP*V+SP*ST*W ZBOX(2+2*ISIDE+3)=Z0 -ST*U +CT*W U=R*COS(-3*PI/4+(PI/2)*DBLE(I )/DBLE(N-1)) V=R*SIN(-3*PI/4+(PI/2)*DBLE(I )/DBLE(N-1)) W=ZL*ISIDE XBOX(2+2*ISIDE+4)=X0+CP*CT*U-SP*V+CP*ST*W YBOX(2+2*ISIDE+4)=Y0+SP*CT*U+CP*V+SP*ST*W ZBOX(2+2*ISIDE+4)=Z0 -ST*U +CT*W 50 CONTINUE CALL PLABOX(XBOX,YBOX,ZBOX,NCUT,XCUT,YCUT,ZCUT, - X0PL,Y0PL,Z0PL,APL,BPL,CPL) IF(NCUT.GE.3)THEN CALL PLABU1('STORE',IRPL,NCUT,XCUT,YCUT,ZCUT, - APL,BPL,CPL,ICOL,IVOL,IFAIL) IF(IFAIL.NE.0)PRINT *,' !!!!!! PLACHC WARNING : Unable to'// - ' store a panel of a box.' ENDIF 10 CONTINUE END +DECK,PLACHO. SUBROUTINE PLACHO(IVOL) *----------------------------------------------------------------------- * PLACHO - Plots the outlines of a cylindrical hole. * (Last changed on 8/10/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CONSTANTS. +SEQ,PARAMETERS. +SEQ,SOLIDS. +SEQ,GRAPHICS. +SEQ,PRINTPLOT. INTEGER IREF,IVOL,N,NMAX,I,ISIDE PARAMETER(NMAX=50) DOUBLE PRECISION X0,Y0,Z0,A,B,C,XL,YL,ZL,CT,ST,CP,SP, - FNORM,U,V,W,R1,R2,R, - XPL(4*MXEDGE),YPL(4*MXEDGE),ZPL(4*MXEDGE) *** Locate the conductor. IF(IVOL.LT.1.OR.IVOL.GT.MXSOLI)THEN PRINT *,' !!!!!! PLACHO WARNING : Volume reference is out'// - ' of range ; not plotted.' RETURN ENDIF IREF=ISTART(IVOL) IF(IREF.LT.0.OR.IREF+11.GT.MXSBUF)THEN PRINT *,' !!!!!! PLACHO WARNING : Volume address is out'// - ' of range ; not plotted.' RETURN ENDIF *** Locate the parameters of the surrounding box and of the cylinder. R1= CBUF(IREF+1) R2= CBUF(IREF+2) IF(R1.LE.0.OR.R2.LE.0)THEN PRINT *,' !!!!!! PLACHO WARNING : Cylindrical hole ',IVOL, - ' has a non-positive radius; not plotted.' RETURN ENDIF XL=ABS(CBUF(IREF+3)) YL=ABS(CBUF(IREF+4)) ZL=ABS(CBUF(IREF+5)) IF(R1.GE.XL.OR.R1.GE.YL.OR.R2.GE.XL.OR.R2.GE.YL)THEN PRINT *,' !!!!!! PLACHO WARNING : Cylindrical hole ',IVOL, - ' is larger than the box; not plotted.' RETURN ENDIF X0=CBUF(IREF+6) Y0=CBUF(IREF+7) Z0=CBUF(IREF+8) FNORM=SQRT(CBUF(IREF+9)**2+CBUF(IREF+10)**2+CBUF(IREF+11)**2) IF(FNORM.LE.0)THEN PRINT *,' !!!!!! PLACHO WARNING : Cylindrical hole ',IVOL, - ' has a zero norm direction vector; not plotted.' RETURN ENDIF A= CBUF(IREF+9)/FNORM B= CBUF(IREF+10)/FNORM C= CBUF(IREF+11)/FNORM N= MIN(MXEDGE-3,NMAX-1,NINT(CBUF(IREF+12))) IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLACHO DEBUG : Drawing a'', - '' hole from address '',I4/26X,''Centre= '',3E10.3/ - 26X,''Half-lengths='',3E10.3/26X,''Direction= '',3E10.3/ - 26X,''Radii= '',2E10.3)') - IREF,X0,Y0,Z0,XL,YL,ZL,A,B,C,R1,R2 * Shorthand for the rotations. CT=CBUF(IREF+13) ST=CBUF(IREF+14) CP=CBUF(IREF+15) SP=CBUF(IREF+16) *** Determine a suitable number of points on the radii. IF(N.LE.1)THEN R=MAX(R1,R2) IF(R.LT.1E-2*MAX(ABS(GXMAX-GXMIN),ABS(GYMAX-GYMIN), - ABS(GZMAX-GZMIN)))THEN N=MIN(MXEDGE-3,NMAX-1,2) ELSEIF(R.LT.1E-1*MAX(ABS(GXMAX-GXMIN),ABS(GYMAX-GYMIN), - ABS(GZMAX-GZMIN)))THEN N=MIN(MXEDGE-3,NMAX-1,3) ELSE N=MIN(MXEDGE-3,NMAX-1,4) ENDIF ENDIF * Loop over the panels. DO 10 ISIDE=-1,+1,2 IF(ISIDE.EQ.-1)THEN R=0.9999*R1 ELSE R=0.9999*R2 ENDIF DO 20 I=1,4*N-3 * The panels for x=xmax. U=R*COS(-PI/4+(PI/2)*DBLE(I-1)/DBLE(N-1)) V=R*SIN(-PI/4+(PI/2)*DBLE(I-1)/DBLE(N-1)) W=1.0001*ZL*ISIDE XPL(I)=X0+CP*CT*U-SP*V+CP*ST*W YPL(I)=Y0+SP*CT*U+CP*V+SP*ST*W ZPL(I)=Z0 -ST*U +CT*W 20 CONTINUE CALL PLAGPL(4*N-3,XPL,YPL,ZPL) 10 CONTINUE END +DECK,PLACHI. SUBROUTINE PLACHI(IVOL,XPOS,YPOS,ZPOS,INSIDE) *----------------------------------------------------------------------- * PLACHI - Determines whether a point is located inside a box. * (Last changed on 8/ 1/08.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CONSTANTS. +SEQ,SOLIDS. +SEQ,PRINTPLOT. INTEGER IVOL,IREF DOUBLE PRECISION XL,YL,ZL,X0,Y0,Z0,R1,R2,CT,ST,CP,SP, - XPOS,YPOS,ZPOS,U,V,W LOGICAL INSIDE *** Locate the conductor. IF(IVOL.LT.1.OR.IVOL.GT.MXSOLI)THEN PRINT *,' !!!!!! PLACHI WARNING : Volume reference is out'// - ' of range ; not checked.' RETURN ENDIF IREF=ISTART(IVOL) IF(IREF.LT.0.OR.IREF+16.GT.MXSBUF)THEN PRINT *,' !!!!!! PLACHI WARNING : Volume address is out'// - ' of range ; not checked.' RETURN ENDIF *** Locate the parameters of the surrounding box and of the cylinder. R1= CBUF(IREF+1) R2= CBUF(IREF+2) IF(R1.LE.0.OR.R2.LE.0)THEN PRINT *,' !!!!!! PLACHI WARNING : Cylindrical hole ',IVOL, - ' has a non-positive radius; not checked.' RETURN ENDIF XL=ABS(CBUF(IREF+3)) YL=ABS(CBUF(IREF+4)) ZL=ABS(CBUF(IREF+5)) IF(R1.GE.XL.OR.R1.GE.YL.OR.R2.GE.XL.OR.R2.GE.YL.OR.ZL.LE.0)THEN PRINT *,' !!!!!! PLACHI WARNING : Radius of cylindrical', - ' hole ',IVOL,' not smaller than the box; not checked.' RETURN ENDIF X0=CBUF(IREF+6) Y0=CBUF(IREF+7) Z0=CBUF(IREF+8) IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLACHI DEBUG : Checking'', - '' hole from address '',I4/26X,''Centre= '',3E10.3/ - 26X,''Half-lengths='',3E10.3/26X,''Radii= '',2E10.3)') - IREF,X0,Y0,Z0,XL,YL,ZL,R1,R2 * Shorthand for the rotations. CT=CBUF(IREF+13) ST=CBUF(IREF+14) CP=CBUF(IREF+15) SP=CBUF(IREF+16) *** Transform the point to local coordinates. U=+CP*CT*(XPOS-X0)+SP*CT*(YPOS-Y0)-ST*(ZPOS-Z0) V=-SP *(XPOS-X0)+CP* (YPOS-Y0) W=+CP*ST*(XPOS-X0)+SP*ST*(YPOS-Y0)+CT*(ZPOS-Z0) *** See whether the point is inside. IF(ABS(U).GT.XL.OR.ABS(V).GT.YL.OR.ABS(W).GT.ZL.OR. - U**2+V**2.LT.(R1+(W+ZL)*(R2-R1)/(2*ZL))**2)THEN INSIDE=.FALSE. ELSE INSIDE=.TRUE. ENDIF END +DECK,PLACHE. SUBROUTINE PLACHE(IVOL,XMIN,YMIN,ZMIN,XMAX,YMAX,ZMAX) *----------------------------------------------------------------------- * PLACHE - Computes an enveloping box * (Last changed on 22/ 2/09.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CONSTANTS. +SEQ,SOLIDS. +SEQ,PRINTPLOT. INTEGER IREF,IVOL DOUBLE PRECISION XL,YL,ZL,X0,Y0,Z0,XMIN,YMIN,ZMIN,XMAX,YMAX,ZMAX *** Locate the conductor. IF(IVOL.LT.1.OR.IVOL.GT.MXSOLI)THEN PRINT *,' !!!!!! PLACHE WARNING : Volume reference is out'// - ' of range ; not checked.' RETURN ENDIF IREF=ISTART(IVOL) IF(IREF.LT.0.OR.IREF+8.GT.MXSBUF)THEN PRINT *,' !!!!!! PLACHE WARNING : Volume address is out'// - ' of range ; not checked.' RETURN ENDIF *** Locate the cube parameters. XL=ABS(CBUF(IREF+3)) YL=ABS(CBUF(IREF+4)) ZL=ABS(CBUF(IREF+5)) X0=CBUF(IREF+6) Y0=CBUF(IREF+7) Z0=CBUF(IREF+8) IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLACHE DEBUG :'', - '' Hole from address '',I4/26X,''Centre= '',3E10.3/ - 26X,''Half-lengths='',3E10.3)') - IREF,X0,Y0,Z0,XL,YL,ZL *** Take the margins wide. XMIN=X0-SQRT(XL**2+YL**2+ZL**2) YMIN=Y0-SQRT(XL**2+YL**2+ZL**2) ZMIN=Z0-SQRT(XL**2+YL**2+ZL**2) XMAX=X0+SQRT(XL**2+YL**2+ZL**2) YMAX=Y0+SQRT(XL**2+YL**2+ZL**2) ZMAX=Z0+SQRT(XL**2+YL**2+ZL**2) END +DECK,PLACHD. SUBROUTINE PLACHD(ISOL,NVTX,XVTX,YVTX,ZVTX,XNORM,YNORM,ZNORM,DIS) *----------------------------------------------------------------------- * PLACHD - Returns the discretisation level required for a primitive. * (Last changed on 6/ 7/10.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CONSTANTS. +SEQ,SOLIDS. +SEQ,PRINTPLOT. INTEGER ISOL,NVTX,IREF DOUBLE PRECISION XVTX(*), YVTX(*), ZVTX(*), XNORM, YNORM, ZNORM, - CT,ST,CP,SP, UN,VN,WN, U1,V1,W1, DIS *** Locate the conductor. IF(ISOL.LT.1.OR.ISOL.GT.MXSOLI)THEN PRINT *,' !!!!!! PLACHD WARNING : Solid reference is out'// - ' of range ; not checked.' RETURN ENDIF IREF=ISTART(ISOL) IF(IREF.LT.0.OR.IREF+14.GT.MXSBUF)THEN PRINT *,' !!!!!! PLACHD WARNING : Solid address is out'// - ' of range ; not checked.' RETURN ENDIF *** Locate the cylinder rotation parameters. CT=CBUF(IREF+13) ST=CBUF(IREF+14) CP=CBUF(IREF+15) SP=CBUF(IREF+16) *** Transform the normal vector to local coordinates. UN=+CP*CT*XNORM+SP*CT*YNORM-ST*ZNORM VN=-SP *XNORM+CP* YNORM WN=+CP*ST*XNORM+SP*ST*YNORM+CT*ZNORM C print *,' Axis vector: ',un,vn,wn *** Transform one of the points (first). U1=+CP*CT*(XVTX(1)-CBUF(IREF+6))+SP*CT*(YVTX(1)-CBUF(IREF+7))- - ST*(ZVTX(1)-CBUF(IREF+8)) V1=-SP *(XVTX(1)-CBUF(IREF+6))+CP* (YVTX(1)-CBUF(IREF+7)) W1=+CP*ST*(XVTX(1)-CBUF(IREF+6))+SP*ST*(YVTX(1)-CBUF(IREF+7))+ - CT*(ZVTX(1)-CBUF(IREF+8)) C print *,' Point 1 ',u1,v1,w1 *** Identify the vector. IF(WN.GT.MAX(ABS(UN),ABS(VN)))THEN DIS=CBUF(IREF+25) ELSEIF(WN.LT.-MAX(ABS(UN),ABS(VN)))THEN DIS=CBUF(IREF+26) ELSEIF(UN*U1+VN*V1+WN*W1.LT.0)THEN DIS=CBUF(IREF+27) ELSEIF(UN.GT.MAX(ABS(VN),ABS(WN)))THEN DIS=CBUF(IREF+21) ELSEIF(UN.LT.-MAX(ABS(VN),ABS(WN)))THEN DIS=CBUF(IREF+22) ELSEIF(VN.GT.MAX(ABS(UN),ABS(WN)))THEN DIS=CBUF(IREF+23) ELSEIF(VN.LT.-MAX(ABS(UN),ABS(WN)))THEN DIS=CBUF(IREF+24) ELSE PRINT *,' !!!!!! PLACHD WARNING : Found no match for the'// - ' hole panel; returning 1st value.' DIS=CBUF(IREF+21) ENDIF * Debugging. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLACHD DEBUG :'', - '' Discretisation of solid '',I5,'' (hole)''/ - '' Norm vector: '',3F10.3/ - '' First points: '',3F10.3/ - '' Discretisation: '',E12.5)') - ISOL,UN,VN,WN,U1,V1,W1,DIS END +DECK,PLATBP. SUBROUTINE PLATBP(IVOL,IOFCOL) *----------------------------------------------------------------------- * PLATBP - Surface panels of a Toblerone bar. * (Last changed on 11/ 3/10.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CONSTANTS. +SEQ,PARAMETERS. +SEQ,SOLIDS. +SEQ,GRAPHICS. +SEQ,PRINTPLOT. INTEGER IVOL,IREF,IOFCOL,ICOL,IFAIL,IRPL DOUBLE PRECISION XL,YL,XH,ZH,X0,Y0,Z0,A,B,C,CT,ST,CP,SP, - U1,V1,W1,WW,FNORM,XPL(4),YPL(4),ZPL(4),XROOF,ZROOF *** Locate the conductor. IF(IVOL.LT.1.OR.IVOL.GT.MXSOLI)THEN PRINT *,' !!!!!! PLATBP WARNING : Volume reference is out'// - ' of range ; not plotted.' RETURN ENDIF IREF=ISTART(IVOL) IF(IREF.LT.0.OR.IREF+8.GT.MXSBUF)THEN PRINT *,' !!!!!! PLATBP WARNING : Volume address is out'// - ' of range ; not plotted.' RETURN ENDIF *** Locate the cube parameters. XL=ABS(CBUF(IREF+1)) YL=ABS(CBUF(IREF+2)) ZH=ABS(CBUF(IREF+3)) X0=CBUF(IREF+4) Y0=CBUF(IREF+5) Z0=CBUF(IREF+6) XH=CBUF(IREF+14) FNORM=SQRT(CBUF(IREF+7)**2+CBUF(IREF+8)**2+CBUF(IREF+9)**2) IF(FNORM.LE.0)THEN PRINT *,' !!!!!! PLATBP WARNING : Ridge ',IVOL,' has'// - ' a zero norm direction vector; not plotted.' RETURN ENDIF A= CBUF(IREF+7)/FNORM B= CBUF(IREF+8)/FNORM C= CBUF(IREF+9)/FNORM IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLATBP DEBUG : Drawing a'', - '' ridge from address '',I4/ - 26X,''Centre= '',3E10.3/ - 26X,''Half-lengths='',2E10.3/ - 26X,''Ridge ='',2E10.3/ - 26X,''Direction= '',3E10.3)') - IREF,X0,Y0,Z0,XL,YL,XH,ZH,A,B,C * Shorthand for the rotations. CT=CBUF(IREF+10) ST=CBUF(IREF+11) CP=CBUF(IREF+12) SP=CBUF(IREF+13) *** Draw the 5 sides of the ridge, start with the floor U1=-XL V1=-YL W1=0 XPL(1)=X0+CP*CT*U1-SP*V1+CP*ST*W1 YPL(1)=Y0+SP*CT*U1+CP*V1+SP*ST*W1 ZPL(1)=Z0 -ST*U1 +CT*W1 U1=-XL V1=+YL W1=0 XPL(2)=X0+CP*CT*U1-SP*V1+CP*ST*W1 YPL(2)=Y0+SP*CT*U1+CP*V1+SP*ST*W1 ZPL(2)=Z0 -ST*U1 +CT*W1 U1=+XL V1=+YL W1=0 XPL(3)=X0+CP*CT*U1-SP*V1+CP*ST*W1 YPL(3)=Y0+SP*CT*U1+CP*V1+SP*ST*W1 ZPL(3)=Z0 -ST*U1 +CT*W1 U1=+XL V1=-YL W1=0 XPL(4)=X0+CP*CT*U1-SP*V1+CP*ST*W1 YPL(4)=Y0+SP*CT*U1+CP*V1+SP*ST*W1 ZPL(4)=Z0 -ST*U1 +CT*W1 CALL COLWGT(-CP*ST,-SP*ST,-CT,WW) IF(WW.GE.0)THEN ICOL=IOFCOL+NINT(MIN(1.0D0,WW)*(NPRCOL-1)) ELSE ICOL=IOFCOL ENDIF CALL PLABU1('STORE',IRPL,4,XPL,YPL,ZPL,-CP*ST,-SP*ST,-CT, - ICOL,IVOL,IFAIL) IF(IFAIL.NE.0)PRINT *,' !!!!!! PLATBP WARNING : Unable to'// - ' store a panel of a ridge.' * Side triangle at y=ymin U1=-XL V1=-YL W1=0 XPL(1)=X0+CP*CT*U1-SP*V1+CP*ST*W1 YPL(1)=Y0+SP*CT*U1+CP*V1+SP*ST*W1 ZPL(1)=Z0 -ST*U1 +CT*W1 U1=+XL V1=-YL W1=0 XPL(2)=X0+CP*CT*U1-SP*V1+CP*ST*W1 YPL(2)=Y0+SP*CT*U1+CP*V1+SP*ST*W1 ZPL(2)=Z0 -ST*U1 +CT*W1 U1=XH V1=-YL W1=ZH XPL(3)=X0+CP*CT*U1-SP*V1+CP*ST*W1 YPL(3)=Y0+SP*CT*U1+CP*V1+SP*ST*W1 ZPL(3)=Z0 -ST*U1 +CT*W1 CALL COLWGT(SP,-CP,0.0D0,WW) IF(WW.GE.0)THEN ICOL=IOFCOL+NINT(MIN(1.0D0,WW)*(NPRCOL-1)) ELSE ICOL=IOFCOL ENDIF CALL PLABU1('STORE',IRPL,3,XPL,YPL,ZPL,SP,-CP,0.0D0, - ICOL,IVOL,IFAIL) IF(IFAIL.NE.0)PRINT *,' !!!!!! PLATBP WARNING : Unable to'// - ' store a panel of a ridge.' * Side triangle at y=ymax U1=-XL V1=+YL W1=0 XPL(1)=X0+CP*CT*U1-SP*V1+CP*ST*W1 YPL(1)=Y0+SP*CT*U1+CP*V1+SP*ST*W1 ZPL(1)=Z0 -ST*U1 +CT*W1 U1=+XL V1=+YL W1=0 XPL(2)=X0+CP*CT*U1-SP*V1+CP*ST*W1 YPL(2)=Y0+SP*CT*U1+CP*V1+SP*ST*W1 ZPL(2)=Z0 -ST*U1 +CT*W1 U1=XH V1=+YL W1=ZH XPL(3)=X0+CP*CT*U1-SP*V1+CP*ST*W1 YPL(3)=Y0+SP*CT*U1+CP*V1+SP*ST*W1 ZPL(3)=Z0 -ST*U1 +CT*W1 CALL COLWGT(-SP,CP,0.0D0,WW) IF(WW.GE.0)THEN ICOL=IOFCOL+NINT(MIN(1.0D0,WW)*(NPRCOL-1)) ELSE ICOL=IOFCOL ENDIF CALL PLABU1('STORE',IRPL,3,XPL,YPL,ZPL,-SP,CP,0.0D0, - ICOL,IVOL,IFAIL) IF(IFAIL.NE.0)PRINT *,' !!!!!! PLATBP WARNING : Unable to'// - ' store a panel of a ridge.' * The roof, part at +x U1=+XL V1=-YL W1=0 XPL(1)=X0+CP*CT*U1-SP*V1+CP*ST*W1 YPL(1)=Y0+SP*CT*U1+CP*V1+SP*ST*W1 ZPL(1)=Z0 -ST*U1 +CT*W1 U1=+XL V1=+YL W1=0 XPL(2)=X0+CP*CT*U1-SP*V1+CP*ST*W1 YPL(2)=Y0+SP*CT*U1+CP*V1+SP*ST*W1 ZPL(2)=Z0 -ST*U1 +CT*W1 U1=XH V1=+YL W1=ZH XPL(3)=X0+CP*CT*U1-SP*V1+CP*ST*W1 YPL(3)=Y0+SP*CT*U1+CP*V1+SP*ST*W1 ZPL(3)=Z0 -ST*U1 +CT*W1 U1=XH V1=-YL W1=ZH XPL(4)=X0+CP*CT*U1-SP*V1+CP*ST*W1 YPL(4)=Y0+SP*CT*U1+CP*V1+SP*ST*W1 ZPL(4)=Z0 -ST*U1 +CT*W1 XROOF= ZH /SQRT(ZH**2+(XL-XH)**2) ZROOF=(XL-XH)/SQRT(ZH**2+(XL-XH)**2) CALL COLWGT(CP*CT*XROOF +CP*ST*ZROOF, - SP*CT*XROOF +SP*ST*ZROOF, - -ST*XROOF +CT*ZROOF,WW) IF(WW.GE.0)THEN ICOL=IOFCOL+NINT(MIN(1.0D0,WW)*(NPRCOL-1)) ELSE ICOL=IOFCOL ENDIF CALL PLABU1('STORE',IRPL,4,XPL,YPL,ZPL, - CP*CT*XROOF +CP*ST*ZROOF, - SP*CT*XROOF +SP*ST*ZROOF, - -ST*XROOF +CT*ZROOF, - ICOL,IVOL,IFAIL) IF(IFAIL.NE.0)PRINT *,' !!!!!! PLATBP WARNING : Unable to'// - ' store a panel of a ridge.' * The roof, part at -x U1=-XL V1=-YL W1=0 XPL(1)=X0+CP*CT*U1-SP*V1+CP*ST*W1 YPL(1)=Y0+SP*CT*U1+CP*V1+SP*ST*W1 ZPL(1)=Z0 -ST*U1 +CT*W1 U1=-XL V1=+YL W1=0 XPL(2)=X0+CP*CT*U1-SP*V1+CP*ST*W1 YPL(2)=Y0+SP*CT*U1+CP*V1+SP*ST*W1 ZPL(2)=Z0 -ST*U1 +CT*W1 U1=XH V1=+YL W1=ZH XPL(3)=X0+CP*CT*U1-SP*V1+CP*ST*W1 YPL(3)=Y0+SP*CT*U1+CP*V1+SP*ST*W1 ZPL(3)=Z0 -ST*U1 +CT*W1 U1=XH V1=-YL W1=ZH XPL(4)=X0+CP*CT*U1-SP*V1+CP*ST*W1 YPL(4)=Y0+SP*CT*U1+CP*V1+SP*ST*W1 ZPL(4)=Z0 -ST*U1 +CT*W1 XROOF= -ZH /SQRT(ZH**2+(XL+XH)**2) ZROOF=(XL+XH)/SQRT(ZH**2+(XL+XH)**2) CALL COLWGT(CP*CT*XROOF +CP*ST*ZROOF, - SP*CT*XROOF +SP*ST*ZROOF, - -ST*XROOF +CT*ZROOF,WW) IF(WW.GE.0)THEN ICOL=IOFCOL+NINT(MIN(1.0D0,WW)*(NPRCOL-1)) ELSE ICOL=IOFCOL ENDIF CALL PLABU1('STORE',IRPL,4,XPL,YPL,ZPL, - CP*CT*XROOF +CP*ST*ZROOF, - SP*CT*XROOF +SP*ST*ZROOF, - -ST*XROOF +CT*ZROOF, - ICOL,IVOL,IFAIL) IF(IFAIL.NE.0)PRINT *,' !!!!!! PLATBP WARNING : Unable to'// - ' store a panel of a ridge.' *** Look for intersections with the outside ridge, x=xmin. CALL PLATBC(IVOL,GXMIN,(GYMIN+GYMAX)/2,(GZMIN+GZMAX)/2, - -1.0D0,0.0D0,0.0D0,IOFCOL+1) * x=xmax. CALL PLATBC(IVOL,GXMAX,(GYMIN+GYMAX)/2,(GZMIN+GZMAX)/2, - +1.0D0,0.0D0,0.0D0,IOFCOL+1) * y=ymin. CALL PLATBC(IVOL,(GXMIN+GXMAX)/2,GYMIN,(GZMIN+GZMAX)/2, - 0.0D0,-1.0D0,0.0D0,IOFCOL+1) * y=ymax. CALL PLATBC(IVOL,(GXMIN+GXMAX)/2,GYMAX,(GZMIN+GZMAX)/2, - 0.0D0,+1.0D0,0.0D0,IOFCOL+1) * z=zmin. CALL PLATBC(IVOL,(GXMIN+GXMAX)/2,(GYMIN+GYMAX)/2,GZMIN, - 0.0D0,0.0D0,-1.0D0,IOFCOL+1) * z=zmax. CALL PLATBC(IVOL,(GXMIN+GXMAX)/2,(GYMIN+GYMAX)/2,GZMAX, - 0.0D0,0.0D0,+1.0D0,IOFCOL+1) END +DECK,PLATBC. SUBROUTINE PLATBC(IVOL,X0PL,Y0PL,Z0PL,APL,BPL,CPL,ICOL) *----------------------------------------------------------------------- * PLATBC - Cuts ridge IVOL with a plane. * (Last changed on 11/ 3/10.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CONSTANTS. +SEQ,PARAMETERS. +SEQ,SOLIDS. +SEQ,GRAPHICS. +SEQ,PRINTPLOT. INTEGER IREF,IVOL,IFAIL,NPL,ICOL,IRPL DOUBLE PRECISION X0,Y0,Z0,A,B,C,XL,YL,XH,ZH,CT,ST,CP,SP, - FNORM,U1,V1,W1,U2,V2,W2,X1,Y1,Z1,X2,Y2,Z2, - XPL(MXEDGE),YPL(MXEDGE),ZPL(MXEDGE), - X0PL,Y0PL,Z0PL,APL,BPL,CPL,XCUT,YCUT,ZCUT *** Locate the conductor. IF(ABS(IVOL).LT.1.OR.ABS(IVOL).GT.MXSOLI)THEN PRINT *,' !!!!!! PLATBC WARNING : Volume reference is out'// - ' of range ; not plotted.' RETURN ENDIF IREF=ISTART(ABS(IVOL)) IF(IREF.LT.0.OR.IREF+8.GT.MXSBUF)THEN PRINT *,' !!!!!! PLATBC WARNING : Volume address is out'// - ' of range ; not plotted.' RETURN ENDIF *** Locate the ridge parameters. XL=ABS(CBUF(IREF+1)) YL=ABS(CBUF(IREF+2)) ZH=ABS(CBUF(IREF+3)) X0=CBUF(IREF+4) Y0=CBUF(IREF+5) Z0=CBUF(IREF+6) XH=CBUF(IREF+14) FNORM=SQRT(CBUF(IREF+7)**2+CBUF(IREF+8)**2+CBUF(IREF+9)**2) IF(FNORM.LE.0)THEN PRINT *,' !!!!!! PLATBC WARNING : Ridge ',ABS(IVOL), - ' has a zero norm direction vector; not plotted.' RETURN ENDIF A= CBUF(IREF+7)/FNORM B= CBUF(IREF+8)/FNORM C= CBUF(IREF+9)/FNORM IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLATBC DEBUG : Drawing a'', - '' ridge from address '',I4/ - 26X,''Centre= '',3E10.3/ - 26X,''Half-lengths='',2E10.3/ - 26X,''Ridge ='',2E10.3/ - 26X,''Direction= '',3E10.3)') - IREF,X0,Y0,Z0,XL,YL,XH,ZH,A,B,C * Shorthand for the rotations. CT=CBUF(IREF+10) ST=CBUF(IREF+11) CP=CBUF(IREF+12) SP=CBUF(IREF+13) *** Initial number of points. NPL=0 *** Draw all 9 lines and cut, (xmin,ymin,0) to (xmax,ymin,0). U1=-XL V1=-YL W1=0 X1=X0+CP*CT*U1-SP*V1+CP*ST*W1 Y1=Y0+SP*CT*U1+CP*V1+SP*ST*W1 Z1=Z0 -ST*U1 +CT*W1 U2=+XL V2=-YL W2=0 X2=X0+CP*CT*U2-SP*V2+CP*ST*W2 Y2=Y0+SP*CT*U2+CP*V2+SP*ST*W2 Z2=Z0 -ST*U2 +CT*W2 * Cut with the plane. CALL PLALIN(X1,Y1,Z1,X2,Y2,Z2,X0PL,Y0PL,Z0PL,APL,BPL,CPL, - XCUT,YCUT,ZCUT,IFAIL) * Store the result if there is one. IF(IFAIL.EQ.0.AND.NPL.LE.MXEDGE)THEN NPL=NPL+1 XPL(NPL)=XCUT YPL(NPL)=YCUT ZPL(NPL)=ZCUT ELSEIF(NPL.GE.MXEDGE)THEN PRINT *,' !!!!!! PLATBC WARNING : Too many intersects'// - ' between ridge and plane; stopped.' RETURN ENDIF ** ... to (xmin,ymax,0). U2=-XL V2=+YL W2=0 X2=X0+CP*CT*U2-SP*V2+CP*ST*W2 Y2=Y0+SP*CT*U2+CP*V2+SP*ST*W2 Z2=Z0 -ST*U2 +CT*W2 * Cut with the plane. CALL PLALIN(X1,Y1,Z1,X2,Y2,Z2,X0PL,Y0PL,Z0PL,APL,BPL,CPL, - XCUT,YCUT,ZCUT,IFAIL) * Store the result if there is one. IF(IFAIL.EQ.0.AND.NPL.LE.MXEDGE)THEN NPL=NPL+1 XPL(NPL)=XCUT YPL(NPL)=YCUT ZPL(NPL)=ZCUT ELSEIF(NPL.GE.MXEDGE)THEN PRINT *,' !!!!!! PLATBC WARNING : Too many intersects'// - ' between ridge and plane; stopped.' RETURN ENDIF ** ... to (xh,ymin,zh). U2=XH V2=-YL W2=ZH X2=X0+CP*CT*U2-SP*V2+CP*ST*W2 Y2=Y0+SP*CT*U2+CP*V2+SP*ST*W2 Z2=Z0 -ST*U2 +CT*W2 * Cut with the plane. CALL PLALIN(X1,Y1,Z1,X2,Y2,Z2,X0PL,Y0PL,Z0PL,APL,BPL,CPL, - XCUT,YCUT,ZCUT,IFAIL) * Store the result if there is one. IF(IFAIL.EQ.0.AND.NPL.LE.MXEDGE)THEN NPL=NPL+1 XPL(NPL)=XCUT YPL(NPL)=YCUT ZPL(NPL)=ZCUT ELSEIF(NPL.GE.MXEDGE)THEN PRINT *,' !!!!!! PLATBC WARNING : Too many intersects'// - ' between ridge and plane; stopped.' RETURN ENDIF *** The line (xmax,ymax,0) to (xmin,ymax,0). U1=+XL V1=+YL W1=0 X1=X0+CP*CT*U1-SP*V1+CP*ST*W1 Y1=Y0+SP*CT*U1+CP*V1+SP*ST*W1 Z1=Z0 -ST*U1 +CT*W1 U2=-XL V2=+YL W2=0 X2=X0+CP*CT*U2-SP*V2+CP*ST*W2 Y2=Y0+SP*CT*U2+CP*V2+SP*ST*W2 Z2=Z0 -ST*U2 +CT*W2 * Cut with the plane. CALL PLALIN(X1,Y1,Z1,X2,Y2,Z2,X0PL,Y0PL,Z0PL,APL,BPL,CPL, - XCUT,YCUT,ZCUT,IFAIL) * Store the result if there is one. IF(IFAIL.EQ.0.AND.NPL.LE.MXEDGE)THEN NPL=NPL+1 XPL(NPL)=XCUT YPL(NPL)=YCUT ZPL(NPL)=ZCUT ELSEIF(NPL.GE.MXEDGE)THEN PRINT *,' !!!!!! PLATBC WARNING : Too many intersects'// - ' between ridge and plane; stopped.' RETURN ENDIF ** ... to (xmax,ymin,0). U2=+XL V2=-YL W2=0 X2=X0+CP*CT*U2-SP*V2+CP*ST*W2 Y2=Y0+SP*CT*U2+CP*V2+SP*ST*W2 Z2=Z0 -ST*U2 +CT*W2 * Cut with the plane. CALL PLALIN(X1,Y1,Z1,X2,Y2,Z2,X0PL,Y0PL,Z0PL,APL,BPL,CPL, - XCUT,YCUT,ZCUT,IFAIL) * Store the result if there is one. IF(IFAIL.EQ.0.AND.NPL.LE.MXEDGE)THEN NPL=NPL+1 XPL(NPL)=XCUT YPL(NPL)=YCUT ZPL(NPL)=ZCUT ELSEIF(NPL.GE.MXEDGE)THEN PRINT *,' !!!!!! PLATBC WARNING : Too many intersects'// - ' between ridge and plane; stopped.' RETURN ENDIF ** ... to (xh,ymax,zh). U2=XH V2=+YL W2=ZH X2=X0+CP*CT*U2-SP*V2+CP*ST*W2 Y2=Y0+SP*CT*U2+CP*V2+SP*ST*W2 Z2=Z0 -ST*U2 +CT*W2 * Cut with the plane. CALL PLALIN(X1,Y1,Z1,X2,Y2,Z2,X0PL,Y0PL,Z0PL,APL,BPL,CPL, - XCUT,YCUT,ZCUT,IFAIL) * Store the result if there is one. IF(IFAIL.EQ.0.AND.NPL.LE.MXEDGE)THEN NPL=NPL+1 XPL(NPL)=XCUT YPL(NPL)=YCUT ZPL(NPL)=ZCUT ELSEIF(NPL.GE.MXEDGE)THEN PRINT *,' !!!!!! PLATBC WARNING : Too many intersects'// - ' between ridge and plane; stopped.' RETURN ENDIF *** The line (xmin,ymax,0) to (xh,ymax,zh). U1=-XL V1=+YL W1=0 X1=X0+CP*CT*U1-SP*V1+CP*ST*W1 Y1=Y0+SP*CT*U1+CP*V1+SP*ST*W1 Z1=Z0 -ST*U1 +CT*W1 U2=XH V2=+YL W2=ZH X2=X0+CP*CT*U2-SP*V2+CP*ST*W2 Y2=Y0+SP*CT*U2+CP*V2+SP*ST*W2 Z2=Z0 -ST*U2 +CT*W2 * Cut with the plane. CALL PLALIN(X1,Y1,Z1,X2,Y2,Z2,X0PL,Y0PL,Z0PL,APL,BPL,CPL, - XCUT,YCUT,ZCUT,IFAIL) * Store the result if there is one. IF(IFAIL.EQ.0.AND.NPL.LE.MXEDGE)THEN NPL=NPL+1 XPL(NPL)=XCUT YPL(NPL)=YCUT ZPL(NPL)=ZCUT ELSEIF(NPL.GE.MXEDGE)THEN PRINT *,' !!!!!! PLATBC WARNING : Too many intersects'// - ' between ridge and plane; stopped.' RETURN ENDIF *** The line (xh,ymax,zh) to (xh,ymin,zh) U1=XH V1=+YL W1=ZH X1=X0+CP*CT*U1-SP*V1+CP*ST*W1 Y1=Y0+SP*CT*U1+CP*V1+SP*ST*W1 Z1=Z0 -ST*U1 +CT*W1 U2=XH V2=-YL W2=ZH X2=X0+CP*CT*U2-SP*V2+CP*ST*W2 Y2=Y0+SP*CT*U2+CP*V2+SP*ST*W2 Z2=Z0 -ST*U2 +CT*W2 * Cut with the plane. CALL PLALIN(X1,Y1,Z1,X2,Y2,Z2,X0PL,Y0PL,Z0PL,APL,BPL,CPL, - XCUT,YCUT,ZCUT,IFAIL) * Store the result if there is one. IF(IFAIL.EQ.0.AND.NPL.LE.MXEDGE)THEN NPL=NPL+1 XPL(NPL)=XCUT YPL(NPL)=YCUT ZPL(NPL)=ZCUT ELSEIF(NPL.GE.MXEDGE)THEN PRINT *,' !!!!!! PLATBC WARNING : Too many intersects'// - ' between ridge and plane; stopped.' RETURN ENDIF *** The line (xh,ymin,zh) to (xmax,ymin,0) U1=XH V1=-YL W1=ZH X1=X0+CP*CT*U1-SP*V1+CP*ST*W1 Y1=Y0+SP*CT*U1+CP*V1+SP*ST*W1 Z1=Z0 -ST*U1 +CT*W1 U2=+XL V2=-YL W2=0 X2=X0+CP*CT*U2-SP*V2+CP*ST*W2 Y2=Y0+SP*CT*U2+CP*V2+SP*ST*W2 Z2=Z0 -ST*U2 +CT*W2 * Cut with the plane. CALL PLALIN(X1,Y1,Z1,X2,Y2,Z2,X0PL,Y0PL,Z0PL,APL,BPL,CPL, - XCUT,YCUT,ZCUT,IFAIL) * Store the result if there is one. IF(IFAIL.EQ.0.AND.NPL.LE.MXEDGE)THEN NPL=NPL+1 XPL(NPL)=XCUT YPL(NPL)=YCUT ZPL(NPL)=ZCUT ELSEIF(NPL.GE.MXEDGE)THEN PRINT *,' !!!!!! PLATBC WARNING : Too many intersects'// - ' between ridge and plane; stopped.' RETURN ENDIF *** Get rid of butterflies. CALL BUTFLD(NPL,XPL,YPL,ZPL) *** Store the plane. IF(NPL.GE.3)THEN CALL PLABU1('STORE',IRPL,NPL,XPL,YPL,ZPL, - APL,BPL,CPL,ICOL,IVOL,IFAIL) IF(IFAIL.NE.0)PRINT *,' !!!!!! PLATBC WARNING : Failed to'// - ' store a side cut of a ridge.' ENDIF END +DECK,PLATBO. SUBROUTINE PLATBO(IVOL) *----------------------------------------------------------------------- * PLATBO - Plots the outlines of a ridge. * (Last changed on 11/ 3/10.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PARAMETERS. +SEQ,SOLIDS. +SEQ,PRINTPLOT. INTEGER IREF,IVOL DOUBLE PRECISION X0,Y0,Z0,XL,YL,XH,ZH,CT,ST,CP,SP,U,V,W, - XPL(5),YPL(5),ZPL(5) *** Locate the conductor. IF(IVOL.LT.1.OR.IVOL.GT.MXSOLI)THEN PRINT *,' !!!!!! PLATBO WARNING : Volume reference is out'// - ' of range ; not plotted.' RETURN ENDIF IREF=ISTART(IVOL) IF(IREF.LT.0.OR.IREF+13.GT.MXSBUF)THEN PRINT *,' !!!!!! PLATBO WARNING : Volume address is out'// - ' of range ; not plotted.' RETURN ENDIF *** Locate the cube parameters. XL=ABS(CBUF(IREF+1)) YL=ABS(CBUF(IREF+2)) ZH=ABS(CBUF(IREF+3)) X0=CBUF(IREF+4) Y0=CBUF(IREF+5) Z0=CBUF(IREF+6) XH=CBUF(IREF+14) IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLATBO DEBUG : Outlining'', - '' a ridge from address '',I4/ - 26X,''Centre= '',3E10.3/ - 26X,''Half-lengths='',2E10.3/ - 26X,''Ridge ='',2E10.3)') IREF,X0,Y0,Z0,XL,YL,XH,ZH * Shorthand for the rotations. CT=CBUF(IREF+10) ST=CBUF(IREF+11) CP=CBUF(IREF+12) SP=CBUF(IREF+13) *** The z=zmin face. U=-XL V=-YL W=0 XPL(1)=X0+CP*CT*U-SP*V+CP*ST*W YPL(1)=Y0+SP*CT*U+CP*V+SP*ST*W ZPL(1)=Z0 -ST*U +CT*W U=-XL V=+YL W=0 XPL(2)=X0+CP*CT*U-SP*V+CP*ST*W YPL(2)=Y0+SP*CT*U+CP*V+SP*ST*W ZPL(2)=Z0 -ST*U +CT*W U=+XL V=+YL W=0 XPL(3)=X0+CP*CT*U-SP*V+CP*ST*W YPL(3)=Y0+SP*CT*U+CP*V+SP*ST*W ZPL(3)=Z0 -ST*U +CT*W U=+XL V=-YL W=0 XPL(4)=X0+CP*CT*U-SP*V+CP*ST*W YPL(4)=Y0+SP*CT*U+CP*V+SP*ST*W ZPL(4)=Z0 -ST*U +CT*W XPL(5)=XPL(1) YPL(5)=YPL(1) ZPL(5)=ZPL(1) CALL PLAGPL(5,XPL,YPL,ZPL) *** The triangle at y=ymin U=-XL V=-YL W=0 XPL(1)=X0+CP*CT*U-SP*V+CP*ST*W YPL(1)=Y0+SP*CT*U+CP*V+SP*ST*W ZPL(1)=Z0 -ST*U +CT*W U=XH V=-YL W=ZH XPL(2)=X0+CP*CT*U-SP*V+CP*ST*W YPL(2)=Y0+SP*CT*U+CP*V+SP*ST*W ZPL(2)=Z0 -ST*U +CT*W U=+XL V=-YL W=0 XPL(3)=X0+CP*CT*U-SP*V+CP*ST*W YPL(3)=Y0+SP*CT*U+CP*V+SP*ST*W ZPL(3)=Z0 -ST*U +CT*W CALL PLAGPL(3,XPL,YPL,ZPL) *** The triangle at y=ymax U=-XL V=+YL W=0 XPL(1)=X0+CP*CT*U-SP*V+CP*ST*W YPL(1)=Y0+SP*CT*U+CP*V+SP*ST*W ZPL(1)=Z0 -ST*U +CT*W U=XH V=+YL W=ZH XPL(2)=X0+CP*CT*U-SP*V+CP*ST*W YPL(2)=Y0+SP*CT*U+CP*V+SP*ST*W ZPL(2)=Z0 -ST*U +CT*W U=+XL V=+YL W=0 XPL(3)=X0+CP*CT*U-SP*V+CP*ST*W YPL(3)=Y0+SP*CT*U+CP*V+SP*ST*W ZPL(3)=Z0 -ST*U +CT*W CALL PLAGPL(3,XPL,YPL,ZPL) *** The roof ridge U=XH V=-YL W=ZH XPL(1)=X0+CP*CT*U-SP*V+CP*ST*W YPL(1)=Y0+SP*CT*U+CP*V+SP*ST*W ZPL(1)=Z0 -ST*U +CT*W U=XH V=+YL W=ZH XPL(2)=X0+CP*CT*U-SP*V+CP*ST*W YPL(2)=Y0+SP*CT*U+CP*V+SP*ST*W ZPL(2)=Z0 -ST*U +CT*W CALL PLAGPL(2,XPL,YPL,ZPL) END +DECK,PLATBI. SUBROUTINE PLATBI(IVOL,XPOS,YPOS,ZPOS,INSIDE) *----------------------------------------------------------------------- * PLATBI - Determines whether a point is located inside a ridge. * (Last changed on 11/ 3/10.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CONSTANTS. +SEQ,SOLIDS. +SEQ,PRINTPLOT. INTEGER IVOL,IREF DOUBLE PRECISION XL,YL,XH,ZH,X0,Y0,Z0,CT,ST,CP,SP, - XPOS,YPOS,ZPOS,U,V,W LOGICAL INSIDE *** Locate the conductor. IF(IVOL.LT.1.OR.IVOL.GT.MXSOLI)THEN PRINT *,' !!!!!! PLATBI WARNING : Volume reference is out'// - ' of range ; not checked.' RETURN ENDIF IREF=ISTART(IVOL) IF(IREF.LT.0.OR.IREF+13.GT.MXSBUF)THEN PRINT *,' !!!!!! PLATBI WARNING : Volume address is out'// - ' of range ; not checked.' RETURN ENDIF *** Locate the cube parameters. XL=ABS(CBUF(IREF+1)) YL=ABS(CBUF(IREF+2)) ZH=ABS(CBUF(IREF+3)) X0=CBUF(IREF+4) Y0=CBUF(IREF+5) Z0=CBUF(IREF+6) XH=CBUF(IREF+14) IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLATBI DEBUG : Checking'', - '' ridge from address '',I4/ - 26X,''Centre= '',3E10.3/ - 26X,''Half-lengths='',2E10.3/ - 26X,''Ridge ='',2E10.3)') IREF,X0,Y0,Z0,XL,YL,XH,ZH * Shorthand for the rotations. CT=CBUF(IREF+10) ST=CBUF(IREF+11) CP=CBUF(IREF+12) SP=CBUF(IREF+13) *** Transform the point to local coordinates. U=+CP*CT*(XPOS-X0)+SP*CT*(YPOS-Y0)-ST*(ZPOS-Z0) V=-SP *(XPOS-X0)+CP* (YPOS-Y0) W=+CP*ST*(XPOS-X0)+SP*ST*(YPOS-Y0)+CT*(ZPOS-Z0) *** See whether the point is inside. IF(ABS(U).GT.XL.OR.ABS(V).GT.YL.OR.W.LT.0.OR.W.GT.ZH)THEN INSIDE=.FALSE. ELSEIF(U.GE.XH.AND. - ZH*U+(XL-XH)*V.GT.ZH*XL)THEN INSIDE=.FALSE. ELSEIF(U.LE.XH.AND. - -ZH*U+(XL+XH)*V.GT.ZH*XL)THEN INSIDE=.FALSE. ELSE INSIDE=.TRUE. ENDIF END +DECK,PLATBE. SUBROUTINE PLATBE(IVOL,XMIN,YMIN,ZMIN,XMAX,YMAX,ZMAX) *----------------------------------------------------------------------- * PLATBE - Computes an enveloping box * (Last changed on 11/ 3/10.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CONSTANTS. +SEQ,SOLIDS. +SEQ,PRINTPLOT. INTEGER IREF,IVOL DOUBLE PRECISION XL,YL,XH,ZH,X0,Y0,Z0, - XMIN,YMIN,ZMIN,XMAX,YMAX,ZMAX *** Locate the conductor. IF(IVOL.LT.1.OR.IVOL.GT.MXSOLI)THEN PRINT *,' !!!!!! PLATBE WARNING : Volume reference is out'// - ' of range ; not checked.' RETURN ENDIF IREF=ISTART(IVOL) IF(IREF.LT.0.OR.IREF+6.GT.MXSBUF)THEN PRINT *,' !!!!!! PLATBE WARNING : Volume address is out'// - ' of range ; not checked.' RETURN ENDIF *** Locate the cube parameters. XL=ABS(CBUF(IREF+1)) YL=ABS(CBUF(IREF+2)) ZH=ABS(CBUF(IREF+3)) X0=CBUF(IREF+4) Y0=CBUF(IREF+5) Z0=CBUF(IREF+6) XH=CBUF(IREF+14) IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLATBE DEBUG :'', - '' Ridge from address '',I4/ - 26X,''Centre= '',3E10.3/ - 26X,''Half-lengths='',2E10.3/ - 26X,''Ridge ='',2E10.3)') IREF,X0,Y0,Z0,XL,YL,XH,ZH *** Take the margins wide. XMIN=X0-SQRT(XL**2+YL**2+ZH**2) YMIN=Y0-SQRT(XL**2+YL**2+ZH**2) ZMIN=Z0-SQRT(XL**2+YL**2+ZH**2) XMAX=X0+SQRT(XL**2+YL**2+ZH**2) YMAX=Y0+SQRT(XL**2+YL**2+ZH**2) ZMAX=Z0+SQRT(XL**2+YL**2+ZH**2) END +DECK,PLATBD. SUBROUTINE PLATBD(ISOL,NVTX,XVTX,YVTX,ZVTX,XNORM,YNORM,ZNORM,DIS) *----------------------------------------------------------------------- * PLATBD - Returns the discretisation level required for a primitive. * (Last changed on 8/ 7/10.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CONSTANTS. +SEQ,SOLIDS. +SEQ,PRINTPLOT. INTEGER ISOL,NVTX,IREF DOUBLE PRECISION XVTX(*), YVTX(*), ZVTX(*), XNORM, YNORM, ZNORM, - CT,ST,CP,SP,U,V,W,DIS *** Locate the conductor. IF(ISOL.LT.1.OR.ISOL.GT.MXSOLI)THEN PRINT *,' !!!!!! PLATBD WARNING : Solid reference is out'// - ' of range ; not checked.' RETURN ENDIF IREF=ISTART(ISOL) IF(IREF.LT.0.OR.IREF+14.GT.MXSBUF)THEN PRINT *,' !!!!!! PLATBD WARNING : Solid address is out'// - ' of range ; not checked.' RETURN ENDIF *** Locate the cylinder rotation parameters. CT=CBUF(IREF+10) ST=CBUF(IREF+11) CP=CBUF(IREF+12) SP=CBUF(IREF+13) *** Transform the normal vector to local coordinates. U=+CP*CT*XNORM+SP*CT*YNORM-ST*ZNORM V=-SP *XNORM+CP* YNORM W=+CP*ST*XNORM+SP*ST*YNORM+CT*ZNORM C print *,' Axis vector: ',u,v,w *** Identify the vector. IF(V.GT.MAX(ABS(U),ABS(W)))THEN DIS=CBUF(IREF+21) ELSEIF(V.LT.-MAX(ABS(U),ABS(W)))THEN DIS=CBUF(IREF+22) ELSEIF(W.LT.-MAX(ABS(U),ABS(V)))THEN DIS=CBUF(IREF+23) ELSEIF(U.GT.0)THEN DIS=CBUF(IREF+19) ELSEIF(U.LT.0)THEN DIS=CBUF(IREF+20) ELSE PRINT *,' !!!!!! PLATBD WARNING : Found no match for the'// - ' ridge panel; returning 1st value.' DIS=CBUF(IREF+19) ENDIF * Debugging. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLATBD DEBUG :'', - '' Discretisation of solid '',I5,'' (box)''/ - '' Norm vector: '',3F10.3/ - '' Discretisation: '',E12.5)') - ISOL,U,V,W,DIS END +DECK,PLAEXP. SUBROUTINE PLAEXP(IVOL,IOFCOL) *----------------------------------------------------------------------- * PLAEXP - Generates a table of polygons for an extrusion. * (Last changed on 12/10/11.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CONSTANTS. +SEQ,PARAMETERS. +SEQ,SOLIDS. +SEQ,GRAPHICS. +SEQ,PRINTPLOT. INTEGER IREF,IOFCOL,N,IVOL,ICOL,IFAIL,I,IRPL,IORI DOUBLE PRECISION ZL,X0,Y0,Z0,A,B,C,CT,ST,CP,SP,FNORM,WW, - U,V,W,XPL(MXEDGE),YPL(MXEDGE),ZPL(MXEDGE), - XN,YN *** Locate the conductor. IF(IVOL.LT.1.OR.IVOL.GT.MXSOLI)THEN PRINT *,' !!!!!! PLAEXP WARNING : Volume reference is out'// - ' of range ; not plotted.' RETURN ENDIF IREF=ISTART(IVOL) IF(IREF.LT.0.OR.IREF+9.GT.MXSBUF)THEN PRINT *,' !!!!!! PLAEXP WARNING : Volume address is out'// - ' of range ; not plotted.' RETURN ENDIF *** Locate the extrusion parameters, first the half length in z. ZL=ABS(CBUF(IREF+2)) * Centre. X0=CBUF(IREF+3) Y0=CBUF(IREF+4) Z0=CBUF(IREF+5) * Direction vector. FNORM=SQRT(CBUF(IREF+6)**2+CBUF(IREF+7)**2+CBUF(IREF+8)**2) IF(FNORM.LE.0)THEN PRINT *,' !!!!!! PLAEXP WARNING : Extrusion ',IVOL,' has'// - ' a zero norm direction vector; not plotted.' RETURN ENDIF A= CBUF(IREF+6)/FNORM B= CBUF(IREF+7)/FNORM C= CBUF(IREF+8)/FNORM * Number of points N = NINT(CBUF(IREF+9)) IF(N.GT.MXEDGE.OR.IREF+23+2*N.GT.MXSBUF)THEN PRINT *,' !!!!!! PLAEXP WARNING : Volume address is out'// - ' of range ; not checked.' RETURN ENDIF * Orientation IORI=NINT(CBUF(IREF+1)) * Shorthand for the rotations. CT=CBUF(IREF+10) ST=CBUF(IREF+11) CP=CBUF(IREF+12) SP=CBUF(IREF+13) * Debugging. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLAEXP DEBUG : Drawing'', - '' an extrusion of volume '',I4/26X, - '', N='',I5,'', Half-length='',E10.3/26X,''Centre='',3E10.3/ - 26X,''Direction='',3E10.3)') IVOL,N,ZL,X0,Y0,Z0,A,B,C *** Create the top lid. IF(CBUF(IREF+22).GT.0.5)THEN DO 10 I=1,N * Local coordinates, U=CBUF(IREF+23+2*I-1) V=CBUF(IREF+23+2*I) W=ZL * Rotate into place. XPL(I)=X0+CP*CT*U-SP*V+CP*ST*W YPL(I)=Y0+SP*CT*U+CP*V+SP*ST*W ZPL(I)=Z0 -ST*U +CT*W 10 CONTINUE * Compute colour index. CALL COLWGT(A,B,C,WW) IF(WW.GT.0)THEN ICOL=IOFCOL+NINT(MIN(1.0D0,WW)*(NPRCOL-1)) ELSE ICOL=IOFCOL ENDIF * Store the plane. CALL PLABU1('STORE',IRPL,N,XPL,YPL,ZPL,A,B,C,ICOL,IVOL, - IFAIL) IF(IFAIL.NE.0)PRINT *,' !!!!!! PLAEXP WARNING : Unable'// - ' to store the top lid of an extrusion.' ENDIF *** Create the bottom lid. IF(CBUF(IREF+23).GT.0.5)THEN DO 20 I=1,N * Local coordinates, U=CBUF(IREF+23+2*I-1) V=CBUF(IREF+23+2*I) W=-ZL * Rotate into place. XPL(I)=X0+CP*CT*U-SP*V+CP*ST*W YPL(I)=Y0+SP*CT*U+CP*V+SP*ST*W ZPL(I)=Z0 -ST*U +CT*W 20 CONTINUE * Compute colour index. CALL COLWGT(-A,-B,-C,WW) IF(WW.GT.0)THEN ICOL=IOFCOL+NINT(MIN(1.0D0,WW)*(NPRCOL-1)) ELSE ICOL=IOFCOL ENDIF * Store the plane. CALL PLABU1('STORE',IRPL,N,XPL,YPL,ZPL,-A,-B,-C, - ICOL,IVOL,IFAIL) IF(IFAIL.NE.0)PRINT *,' !!!!!! PLAEXP WARNING : Unable to'// - ' store the bottom lid of an extrusion.' ENDIF *** Create the side panels. IF(ZL.GT.0)THEN U=CBUF(IREF+23+2*N-1) V=CBUF(IREF+23+2*N) W=ZL * Rotate into place. XPL(1)=X0+CP*CT*U-SP*V+CP*ST*W YPL(1)=Y0+SP*CT*U+CP*V+SP*ST*W ZPL(1)=Z0 -ST*U +CT*W XPL(2)=X0+CP*CT*U-SP*V-CP*ST*W YPL(2)=Y0+SP*CT*U+CP*V-SP*ST*W ZPL(2)=Z0 -ST*U -CT*W ** Go around the extrusion. DO 30 I=1,N * Bottom and top of the line along the axis of the extrusion. U=CBUF(IREF+23+2*I-1) V=CBUF(IREF+23+2*I) W=ZL * Rotated into place. XPL(3)=X0+CP*CT*U-SP*V-CP*ST*W YPL(3)=Y0+SP*CT*U+CP*V-SP*ST*W ZPL(3)=Z0 -ST*U -CT*W XPL(4)=X0+CP*CT*U-SP*V+CP*ST*W YPL(4)=Y0+SP*CT*U+CP*V+SP*ST*W ZPL(4)=Z0 -ST*U +CT*W * Compute the colour index for this segment. XN=CBUF(IREF+23+1+MOD(2*I-3+2*N,2*N))- - CBUF(IREF+23+1+MOD(2*I-1+2*N,2*N)) YN=CBUF(IREF+23+1+MOD(2*I-2+2*N,2*N))- - CBUF(IREF+23+1+MOD(2*I-4+2*N,2*N)) FNORM=SQRT(XN**2+YN**2) IF(FNORM.LE.0)THEN PRINT *,' !!!!!! PLAEXP WARNING : Zero norm edge'// - ' in extrusion ',IVOL ELSE XN=-IORI*XN/FNORM YN=-IORI*YN/FNORM ENDIF CALL COLWGT(CP*CT*XN-SP*YN,SP*CT*XN+CP*YN,-ST*XN,WW) IF(WW.GT.0)THEN ICOL=IOFCOL+NINT(MIN(1.0D0,WW)*(NPRCOL-1)) ELSE ICOL=IOFCOL ENDIF * Store the plane. CALL PLABU1('STORE',IRPL,4,XPL,YPL,ZPL, - CP*CT*XN-SP*YN,SP*CT*XN+CP*YN,-ST*XN,ICOL,IVOL,IFAIL) IF(IFAIL.NE.0)PRINT *,' !!!!!! PLAEXP WARNING : Unable to'// - ' store a panel of a extrusion.' * Shift the points. XPL(1)=XPL(4) YPL(1)=YPL(4) ZPL(1)=ZPL(4) XPL(2)=XPL(3) YPL(2)=YPL(3) ZPL(2)=ZPL(3) 30 CONTINUE ENDIF *** Look for intersections with the outside box, x=xmin. CALL PLAEXC(IVOL,GXMIN,(GYMIN+GYMAX)/2,(GZMIN+GZMAX)/2, - -1.0D0,0.0D0,0.0D0,IOFCOL+1) * x=xmax. CALL PLAEXC(IVOL,GXMAX,(GYMIN+GYMAX)/2,(GZMIN+GZMAX)/2, - +1.0D0,0.0D0,0.0D0,IOFCOL+1) * y=ymin. CALL PLAEXC(IVOL,(GXMIN+GXMAX)/2,GYMIN,(GZMIN+GZMAX)/2, - 0.0D0,-1.0D0,0.0D0,IOFCOL+1) * y=ymax. CALL PLAEXC(IVOL,(GXMIN+GXMAX)/2,GYMAX,(GZMIN+GZMAX)/2, - 0.0D0,+1.0D0,0.0D0,IOFCOL+1) * z=zmin. CALL PLAEXC(IVOL,(GXMIN+GXMAX)/2,(GYMIN+GYMAX)/2,GZMIN, - 0.0D0,0.0D0,-1.0D0,IOFCOL+1) * z=zmax. CALL PLAEXC(IVOL,(GXMIN+GXMAX)/2,(GYMIN+GYMAX)/2,GZMAX, - 0.0D0,0.0D0,+1.0D0,IOFCOL+1) END +DECK,PLAEXC. SUBROUTINE PLAEXC(IVOL,X0PL,Y0PL,Z0PL,APL,BPL,CPL,ICOL) *----------------------------------------------------------------------- * PLAEXC - Cuts extrusion IVOL with a plane. * (Last changed on 8/10/11.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CONSTANTS. +SEQ,PARAMETERS. +SEQ,SOLIDS. +SEQ,GRAPHICS. +SEQ,PRINTPLOT. INTEGER IREF,N,IVOL,IFAIL,I,NPL,ICOL,IRPL DOUBLE PRECISION ZL,X0,Y0,Z0,A,B,C,CT,ST,CP,SP,FNORM, - U,V,W,X1,Y1,Z1,X2,Y2,Z2,XPL(MXEDGE),YPL(MXEDGE),ZPL(MXEDGE), - X0PL,Y0PL,Z0PL,APL,BPL,CPL,XCUT,YCUT,ZCUT *** Locate the conductor. IF(IVOL.LT.1.OR.IVOL.GT.MXSOLI)THEN PRINT *,' !!!!!! PLAEXC WARNING : Volume reference is out'// - ' of range ; not plotted.' RETURN ENDIF IREF=ISTART(IVOL) IF(IREF.LT.0.OR.IREF+9.GT.MXSBUF)THEN PRINT *,' !!!!!! PLAEXC WARNING : Volume address is out'// - ' of range ; not plotted.' RETURN ENDIF *** Locate the extrusion parameters, first the half length in z. ZL=ABS(CBUF(IREF+2)) * Centre. X0=CBUF(IREF+3) Y0=CBUF(IREF+4) Z0=CBUF(IREF+5) * Direction vector. FNORM=SQRT(CBUF(IREF+6)**2+CBUF(IREF+7)**2+CBUF(IREF+8)**2) IF(FNORM.LE.0)THEN PRINT *,' !!!!!! PLAEXC WARNING : Extrusion ',IVOL,' has'// - ' a zero norm direction vector; not plotted.' RETURN ENDIF A= CBUF(IREF+6)/FNORM B= CBUF(IREF+7)/FNORM C= CBUF(IREF+8)/FNORM * Number of points N = NINT(CBUF(IREF+9)) IF(N.GT.MXEDGE.OR.IREF+23+2*N.GT.MXSBUF)THEN PRINT *,' !!!!!! PLAEXC WARNING : Volume address is out'// - ' of range ; not checked.' RETURN ENDIF * Shorthand for the rotations. CT=CBUF(IREF+10) ST=CBUF(IREF+11) CP=CBUF(IREF+12) SP=CBUF(IREF+13) * Debugging. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLAEXC DEBUG : Drawing'', - '' an extrusion of volume '',I4/26X, - '', N='',I5,'', Half-length='',E10.3/26X,''Centre='',3E10.3/ - 26X,''Direction='',3E10.3)') IVOL,N,ZL,X0,Y0,Z0,A,B,C *** Initialise the number of points. NPL=0 *** Go through the lines of the top lid, first point. U=CBUF(IREF+23+2*N-1) V=CBUF(IREF+23+2*N) W=ZL X1=X0+CP*CT*U-SP*V+CP*ST*W Y1=Y0+SP*CT*U+CP*V+SP*ST*W Z1=Z0 -ST*U +CT*W * Loop over the points. DO 10 I=1,N * Local coordinates, U=CBUF(IREF+23+2*I-1) V=CBUF(IREF+23+2*I) W=ZL * Rotate into place. X2=X0+CP*CT*U-SP*V+CP*ST*W Y2=Y0+SP*CT*U+CP*V+SP*ST*W Z2=Z0 -ST*U +CT*W * Cut with the plane. CALL PLALIN(X1,Y1,Z1,X2,Y2,Z2,X0PL,Y0PL,Z0PL,APL,BPL,CPL, - XCUT,YCUT,ZCUT,IFAIL) * Store the result if there is one. IF(IFAIL.EQ.0.AND.NPL.LE.MXEDGE)THEN NPL=NPL+1 XPL(NPL)=XCUT YPL(NPL)=YCUT ZPL(NPL)=ZCUT ELSEIF(NPL.GE.MXEDGE)THEN PRINT *,' !!!!!! PLAEXC WARNING : Too many intersects'// - ' between extrusion and plane; stopped.' RETURN ENDIF * Shift the coordinates. X1=X2 Y1=Y2 Z1=Z2 10 CONTINUE *** Go through the lines of the bottom lid, first point. IF(ZL.GT.0)THEN U=CBUF(IREF+23+2*N-1) V=CBUF(IREF+23+2*N) W=-ZL X1=X0+CP*CT*U-SP*V+CP*ST*W Y1=Y0+SP*CT*U+CP*V+SP*ST*W Z1=Z0 -ST*U +CT*W * Loop over the points. DO 20 I=1,N * Local coordinates, U=CBUF(IREF+23+2*I-1) V=CBUF(IREF+23+2*I) W=-ZL * Rotate into place. X2=X0+CP*CT*U-SP*V+CP*ST*W Y2=Y0+SP*CT*U+CP*V+SP*ST*W Z2=Z0 -ST*U +CT*W * Cut with the plane. CALL PLALIN(X1,Y1,Z1,X2,Y2,Z2,X0PL,Y0PL,Z0PL,APL,BPL,CPL, - XCUT,YCUT,ZCUT,IFAIL) * Store the result if there is one. IF(IFAIL.EQ.0.AND.NPL.LE.MXEDGE)THEN NPL=NPL+1 XPL(NPL)=XCUT YPL(NPL)=YCUT ZPL(NPL)=ZCUT ELSEIF(NPL.GE.MXEDGE)THEN PRINT *,' !!!!!! PLAEXC WARNING : Too many'// - ' intersects between extrusion and plane;'// - ' stopped.' RETURN ENDIF * Shift the coordinates. X1=X2 Y1=Y2 Z1=Z2 20 CONTINUE ENDIF *** Go through the ribs. DO 30 I=1,N * Bottom and top of the line along the axis of the extrusion. U=CBUF(IREF+23+2*N-1) V=CBUF(IREF+23+2*N) W=ZL * Rotated into place. X1=X0+CP*CT*U-SP*V-CP*ST*W Y1=Y0+SP*CT*U+CP*V-SP*ST*W Z1=Z0 -ST*U -CT*W X2=X0+CP*CT*U-SP*V+CP*ST*W Y2=Y0+SP*CT*U+CP*V+SP*ST*W Z2=Z0 -ST*U +CT*W * Cut with the plane. CALL PLALIN(X1,Y1,Z1,X2,Y2,Z2,X0PL,Y0PL,Z0PL,APL,BPL,CPL, - XCUT,YCUT,ZCUT,IFAIL) * Store the result if there is one. IF(IFAIL.EQ.0.AND.NPL.LE.MXEDGE)THEN NPL=NPL+1 XPL(NPL)=XCUT YPL(NPL)=YCUT ZPL(NPL)=ZCUT ELSEIF(NPL.GE.MXEDGE)THEN PRINT *,' !!!!!! PLAEXC WARNING : Too many intersects'// - ' between extrusion and plane; stopped.' RETURN ENDIF 30 CONTINUE *** Get rid of butterflies. CALL BUTFLD(NPL,XPL,YPL,ZPL) *** Store the plane. IF(NPL.GE.3)THEN CALL PLABU1('STORE',IRPL,NPL,XPL,YPL,ZPL, - APL,BPL,CPL,ICOL,IVOL,IFAIL) IF(IFAIL.NE.0)PRINT *,' !!!!!! PLAEXC WARNING : Failed to'// - ' store a side cut of an extrusion.' ENDIF END +DECK,PLAEXI. SUBROUTINE PLAEXI(IVOL,XPOS,YPOS,ZPOS,INSIDE) *----------------------------------------------------------------------- * PLAEXI - Determines whether a point is located inside an extrusion. * (Last changed on 8/10/11.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CONSTANTS. +SEQ,SOLIDS. +SEQ,PRINTPLOT. INTEGER IREF,IVOL,I,N DOUBLE PRECISION ZL,X0,Y0,Z0,CT,ST,CP,SP,XPOS,YPOS,ZPOS,U,V,W, - XPL(MXEDGE),YPL(MXEDGE) LOGICAL INSIDE,EDGE *** Locate the conductor. IF(IVOL.LT.1.OR.IVOL.GT.MXSOLI)THEN PRINT *,' !!!!!! PLAEXI WARNING : Volume reference is out'// - ' of range ; not checked.' RETURN ENDIF IREF=ISTART(IVOL) IF(IREF.LT.0.OR.IREF+9.GT.MXSBUF)THEN PRINT *,' !!!!!! PLAEXI WARNING : Volume address is out'// - ' of range ; not checked.' RETURN ENDIF *** Locate the extrusion parameters, first the half length in z. ZL=ABS(CBUF(IREF+2)) * Centre. X0=CBUF(IREF+3) Y0=CBUF(IREF+4) Z0=CBUF(IREF+5) IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLAEXI DEBUG : Checking'', - '' extrusion volume '',I4/26X, - '', Half-length='',E10.3/26X,''Centre= '',3E10.3)') - IVOL,ZL,X0,Y0,Z0 * Number of points N = NINT(CBUF(IREF+9)) IF(N.GT.MXEDGE.OR.IREF+23+2*N.GT.MXSBUF)THEN PRINT *,' !!!!!! PLAEXI WARNING : Volume address is out'// - ' of range ; not checked.' RETURN ENDIF * Shorthand for the rotations. CT=CBUF(IREF+10) ST=CBUF(IREF+11) CP=CBUF(IREF+12) SP=CBUF(IREF+13) *** Transform the point to local coordinates. U=+CP*CT*(XPOS-X0)+SP*CT*(YPOS-Y0)-ST*(ZPOS-Z0) V=-SP *(XPOS-X0)+CP* (YPOS-Y0) W=+CP*ST*(XPOS-X0)+SP*ST*(YPOS-Y0)+CT*(ZPOS-Z0) *** See whether the point is inside. DO 10 I=1,N XPL(I)=CBUF(IREF+23+2*I-1) YPL(I)=CBUF(IREF+23+2*I) 10 CONTINUE CALL INTERD(N,XPL,YPL,U,V,INSIDE,EDGE) END +DECK,PLAEXE. SUBROUTINE PLAEXE(IVOL,XMIN,YMIN,ZMIN,XMAX,YMAX,ZMAX) *----------------------------------------------------------------------- * PLAEXE - Computes an enveloping box of an extrusion. * (Last changed on 9/10/11.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CONSTANTS. +SEQ,SOLIDS. +SEQ,PRINTPLOT. INTEGER IREF,IVOL,I,N DOUBLE PRECISION ZL,X0,Y0,Z0,XMIN,YMIN,ZMIN,XMAX,YMAX,ZMAX, - XEMIN,YEMIN,XEMAX,YEMAX *** Locate the conductor. IF(IVOL.LT.1.OR.IVOL.GT.MXSOLI)THEN PRINT *,' !!!!!! PLAEXI WARNING : Volume reference is out'// - ' of range ; not checked.' RETURN ENDIF IREF=ISTART(IVOL) IF(IREF.LT.0.OR.IREF+9.GT.MXSBUF)THEN PRINT *,' !!!!!! PLAEXI WARNING : Volume address is out'// - ' of range ; not checked.' RETURN ENDIF *** Locate the extrusion parameters, first the half length in z. ZL=ABS(CBUF(IREF+2)) * Centre. X0=CBUF(IREF+3) Y0=CBUF(IREF+4) Z0=CBUF(IREF+5) IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLAEXE DEBUG :'', - '' Extrusion volume '',I4/26X, - '', Half-length='',E10.3/26X,''Centre= '',3E10.3)') - IVOL,ZL,X0,Y0,Z0 * Number of points N = NINT(CBUF(IREF+9)) IF(N.LT.3.OR.N.GT.MXEDGE.OR.IREF+23+2*N.GT.MXSBUF)THEN PRINT *,' !!!!!! PLAEXI WARNING : Volume address is out'// - ' of range or N is not valid ; not checked.' RETURN ENDIF *** Find range of the curve XEMIN=CBUF(IREF+24) XEMAX=CBUF(IREF+24) YEMIN=CBUF(IREF+25) YEMAX=CBUF(IREF+25) DO 10 I=2,N IF(XEMIN.GT.CBUF(IREF+23+2*I-1))XEMIN=CBUF(IREF+23+2*I-1) IF(XEMAX.LT.CBUF(IREF+23+2*I-1))XEMAX=CBUF(IREF+23+2*I-1) IF(YEMIN.GT.CBUF(IREF+23+2*I)) YEMIN=CBUF(IREF+23+2*I) IF(YEMAX.LT.CBUF(IREF+23+2*I)) YEMAX=CBUF(IREF+23+2*I) 10 CONTINUE *** Take the margins wide. XMIN=X0-SQRT(MAX(XEMIN,YEMIN,XEMAX,YEMAX)**2+ZL**2) YMIN=Y0-SQRT(MAX(XEMIN,YEMIN,XEMAX,YEMAX)**2+ZL**2) ZMIN=Z0-SQRT(MAX(XEMIN,YEMIN,XEMAX,YEMAX)**2+ZL**2) XMAX=X0+SQRT(MAX(XEMIN,YEMIN,XEMAX,YEMAX)**2+ZL**2) YMAX=Y0+SQRT(MAX(XEMIN,YEMIN,XEMAX,YEMAX)**2+ZL**2) ZMAX=Z0+SQRT(MAX(XEMIN,YEMIN,XEMAX,YEMAX)**2+ZL**2) END +DECK,PLAEXD. SUBROUTINE PLAEXD(ISOL,NVTX,XVTX,YVTX,ZVTX,XNORM,YNORM,ZNORM,DIS) *----------------------------------------------------------------------- * PLAEXD - Returns the discretisation level required for a primitive. * (Last changed on 9/ 10/11.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CONSTANTS. +SEQ,SOLIDS. +SEQ,PRINTPLOT. INTEGER ISOL,NVTX,IREF DOUBLE PRECISION XVTX(*), YVTX(*), ZVTX(*), XNORM, YNORM, ZNORM, - CT,ST,CP,SP,U,V,W,DIS *** Locate the conductor. IF(ISOL.LT.1.OR.ISOL.GT.MXSOLI)THEN PRINT *,' !!!!!! PLAEXD WARNING : Solid reference is out'// - ' of range ; not checked.' RETURN ENDIF IREF=ISTART(ISOL) IF(IREF.LT.0.OR.IREF+21.GT.MXSBUF)THEN PRINT *,' !!!!!! PLAEXD WARNING : Solid address is out'// - ' of range ; not checked.' RETURN ENDIF *** Locate the extrusion rotation parameters. CT=CBUF(IREF+10) ST=CBUF(IREF+11) CP=CBUF(IREF+12) SP=CBUF(IREF+13) *** Transform the normal vector to local coordinates. U=+CP*CT*XNORM+SP*CT*YNORM-ST*ZNORM V=-SP *XNORM+CP* YNORM W=+CP*ST*XNORM+SP*ST*YNORM+CT*ZNORM C print *,' Axis vector: ',u,v,w *** Identify the vector. IF(W.GT.MAX(ABS(U),ABS(V)))THEN DIS=CBUF(IREF+19) ELSEIF(W.LT.-MAX(ABS(U),ABS(V)))THEN DIS=CBUF(IREF+20) ELSE DIS=CBUF(IREF+21) ENDIF * Debugging. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLAEXD DEBUG :'', - '' Discretisation of solid '',I5,'' (extrusion)''/ - '' Norm vector: '',3F10.3/ - '' Discretisation: '',E12.5)') - ISOL,U,V,W,DIS END +DECK,PLATUB. SUBROUTINE PLATUB(R,NTUBE,ZMIN,ZMAX) *----------------------------------------------------------------------- * PLATUB - Cross section between a plane and a tube. * (Last changed on 19/11/97.) *----------------------------------------------------------------------- implicit none +SEQ,CONSTANTS. INTEGER NMAX PARAMETER(NMAX=200) DOUBLE PRECISION XPL(NMAX),YPL(NMAX),R,ZMIN,ZMAX, - X1,Y1,X2,Y2,XCUT,YCUT INTEGER NTUBE,NPL,I,N LOGICAL CUT *** Ensure the radius is not zero, and the number of corners reasonable. IF(R.LE.0.OR.NTUBE.LT.0)THEN PRINT *,' !!!!!! PLATUB WARNING : Receiving invalid'// - ' tube parameters; tube not plotted.' RETURN ENDIF *** Check that the receiving array is large enough. IF(NMAX.LT.NTUBE+1.AND.NTUBE.GT.0)THEN PRINT *,' !!!!!! PLATUB WARNING : Plot vector'// - ' is too small; tube not plotted.' RETURN ENDIF *** Number of corners. IF(NTUBE.EQ.0)THEN N=NMAX-1 ELSE N=NTUBE ENDIF *** Go around the polygon or circle, initialise on first edge. X1=R Y1=0 CALL PLACUT(X1,Y1,ZMIN,X1,Y1,ZMAX,XCUT,YCUT,CUT) * Loop over the edges. DO 10 I=1,N IF(CUT)THEN NPL=1 XPL(NPL)=XCUT YPL(NPL)=YCUT ELSE NPL=0 ENDIF * New edge. X2=R*COS(2.0D0*PI*DBLE(I)/DBLE(N)) Y2=R*SIN(2.0D0*PI*DBLE(I)/DBLE(N)) * Cut along the bottom lid. CALL PLACUT(X1,Y1,ZMIN,X2,Y2,ZMIN,XCUT,YCUT,CUT) IF(CUT)THEN NPL=NPL+1 XPL(NPL)=XCUT YPL(NPL)=YCUT ENDIF * Cut along the top lid. CALL PLACUT(X1,Y1,ZMAX,X2,Y2,ZMAX,XCUT,YCUT,CUT) IF(CUT)THEN NPL=NPL+1 XPL(NPL)=XCUT YPL(NPL)=YCUT ENDIF * Cut along the edge. CALL PLACUT(X2,Y2,ZMIN,X2,Y2,ZMAX,XCUT,YCUT,CUT) IF(CUT)THEN NPL=NPL+1 XPL(NPL)=XCUT YPL(NPL)=YCUT ENDIF * Plot in case a one of the lids has been crossed. IF(NPL.GE.2)CALL GRLIN2(NPL,XPL,YPL) * Shift the point. X1=X2 Y1=Y2 10 CONTINUE END +DECK,PLAPLA. SUBROUTINE PLAPLA(APL,BPL,CPL,DPL,VXMIN,VYMIN,VXMAX,VYMAX) *----------------------------------------------------------------------- * PLAPLA - Cross section between a plane and another plane. * (Last changed on 8/11/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PARAMETERS. DOUBLE PRECISION APL,BPL,CPL,DPL,XPL(2),YPL(2), - VXMIN,VXMAX,VYMIN,VYMAX,A,B,C,X1,Y1,X2,Y2 *** See whether the 2 planes are parallel. IF(ABS(APL*FPROJ(1,1)+BPL*FPROJ(1,2)+CPL*FPROJ(1,3)).LT. - 1D-6*SQRT(APL**2+BPL**2+CPL**2).AND. - ABS(APL*FPROJ(2,1)+BPL*FPROJ(2,2)+CPL*FPROJ(2,3)).LT. - 1D-6*SQRT(APL**2+BPL**2+CPL**2))THEN RETURN *** For non-parallel planes, establish crossing points. ELSE * Intersection equation parameters. A=FPROJ(1,1)*APL+FPROJ(1,2)*BPL+FPROJ(1,3)*CPL B=FPROJ(2,1)*APL+FPROJ(2,2)*BPL+FPROJ(2,3)*CPL C=DPL-FPROJ(3,1)*APL-FPROJ(3,2)*BPL-FPROJ(3,3)*CPL * Two points on the line. IF(A.EQ.0.AND.B.EQ.0)THEN PRINT *,' !!!!!! PLAPLA WARNING : Unable to compute'// - ' intersect between 2 lines; line not plotted.' RETURN ELSEIF(ABS(A).GT.ABS(B))THEN CALL PLACOO( - FPROJ(3,1)+C*FPROJ(1,1)/A, - FPROJ(3,2)+C*FPROJ(1,2)/A, - FPROJ(3,3)+C*FPROJ(1,3)/A, - X1,Y1) CALL PLACOO( - FPROJ(3,1)+FPROJ(2,1)+(C-B)*FPROJ(1,1)/A, - FPROJ(3,2)+FPROJ(2,2)+(C-B)*FPROJ(1,2)/A, - FPROJ(3,3)+FPROJ(2,3)+(C-B)*FPROJ(1,3)/A, - X2,Y2) ELSE CALL PLACOO( - FPROJ(3,1)+C*FPROJ(2,1)/B, - FPROJ(3,2)+C*FPROJ(2,2)/B, - FPROJ(3,3)+C*FPROJ(2,3)/B, - X1,Y1) CALL PLACOO( - FPROJ(3,1)+FPROJ(1,1)+(C-A)*FPROJ(2,1)/B, - FPROJ(3,2)+FPROJ(1,2)+(C-A)*FPROJ(2,2)/B, - FPROJ(3,3)+FPROJ(1,3)+(C-A)*FPROJ(2,3)/B, - X2,Y2) ENDIF * Extend the line to the full area. IF(X1.EQ.X2.AND.Y1.EQ.Y2)THEN PRINT *,' !!!!!! PLAPLA WARNING : Intersect line'// - ' is point-like; line not plotted.' RETURN ELSEIF(ABS(X1-X2).GT.ABS(Y1-Y2))THEN XPL(1)=VXMIN YPL(1)=Y1+(VXMIN-X1)*(Y2-Y1)/(X2-X1) XPL(2)=VXMAX YPL(2)=Y1+(VXMAX-X1)*(Y2-Y1)/(X2-X1) ELSE XPL(1)=X1+(VYMIN-Y1)*(X2-X1)/(Y2-Y1) YPL(1)=VYMIN XPL(2)=X1+(VYMAX-Y1)*(X2-X1)/(Y2-Y1) YPL(2)=VYMAX ENDIF ENDIF *** Seems to have worked, plot the line. CALL GRLIN2(2,XPL,YPL) END +DECK,PLAPOL. SUBROUTINE PLAPOL(XMIN,YMIN,ZMIN,XMAX,YMAX,ZMAX,XIN,YIN,ZIN,NIN, - A,B,C,XPL,YPL,ZPL,NPL) *----------------------------------------------------------------------- * PLAPOL - Cuts a box with a polygon. * (Last changed on 30/ 9/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PARAMETERS. INTEGER NIN,NPL,IFAIL,NBOX,I,J DOUBLE PRECISION XMIN,YMIN,ZMIN,XMAX,YMAX,ZMAX, - XIN(NIN),YIN(NIN),ZIN(NIN), - A,B,C,EPSX,EPSY,EPSZ,ZAUX1,ZAUX2, - XPOL(MXEDGE),YPOL(MXEDGE),ZPOL(MXEDGE),XAUX,YAUX,ZAUX, - XBOX(12),YBOX(12),ZBOX(12), - XPL(MXEDGE),YPL(MXEDGE),ZPL(MXEDGE), - X0,Y0,Z0,X1,Y1,Z1 LOGICAL ONLIND,ADD,SKIP,INSIDE,EDGE EXTERNAL ONLIND C print *,' PLAPOL - Number of points: ',NIN C do i=1,nin C print '(3f12.5)',xin(i),yin(i),zin(i) C enddo C print *,' PLAPOL - Plane: ',a,b,c *** Make sure there is at least 1 input point. IF(NIN.LT.0)THEN NPL=0 RETURN * Check that there is enough storage space. ELSEIF(NIN.GT.MXEDGE)THEN PRINT *,' !!!!!! PLAPOL WARNING : Array dimensions are'// - ' not sufficient ; no plot vector returned.' NPL=0 RETURN ENDIF *** Compute the, at most, 6 distinct crossings between plane and box. NBOX=0 CALL PLALIN(XMIN,YMIN,ZMIN,XMAX,YMIN,ZMIN,XIN(1),YIN(1),ZIN(1), - A,B,C,XAUX,YAUX,ZAUX,IFAIL) IF(IFAIL.EQ.0)THEN NBOX=NBOX+1 CALL PLACO3(XAUX,YAUX,ZAUX,XBOX(NBOX),YBOX(NBOX),ZBOX(NBOX)) ENDIF CALL PLALIN(XMIN,YMIN,ZMIN,XMIN,YMAX,ZMIN,XIN(1),YIN(1),ZIN(1), - A,B,C,XAUX,YAUX,ZAUX,IFAIL) IF(IFAIL.EQ.0)THEN NBOX=NBOX+1 CALL PLACO3(XAUX,YAUX,ZAUX,XBOX(NBOX),YBOX(NBOX),ZBOX(NBOX)) ENDIF CALL PLALIN(XMIN,YMIN,ZMIN,XMIN,YMIN,ZMAX,XIN(1),YIN(1),ZIN(1), - A,B,C,XAUX,YAUX,ZAUX,IFAIL) IF(IFAIL.EQ.0)THEN NBOX=NBOX+1 CALL PLACO3(XAUX,YAUX,ZAUX,XBOX(NBOX),YBOX(NBOX),ZBOX(NBOX)) ENDIF CALL PLALIN(XMAX,YMAX,ZMIN,XMAX,YMIN,ZMIN,XIN(1),YIN(1),ZIN(1), - A,B,C,XAUX,YAUX,ZAUX,IFAIL) IF(IFAIL.EQ.0)THEN NBOX=NBOX+1 CALL PLACO3(XAUX,YAUX,ZAUX,XBOX(NBOX),YBOX(NBOX),ZBOX(NBOX)) ENDIF CALL PLALIN(XMAX,YMAX,ZMIN,XMIN,YMAX,ZMIN,XIN(1),YIN(1),ZIN(1), - A,B,C,XAUX,YAUX,ZAUX,IFAIL) IF(IFAIL.EQ.0)THEN NBOX=NBOX+1 CALL PLACO3(XAUX,YAUX,ZAUX,XBOX(NBOX),YBOX(NBOX),ZBOX(NBOX)) ENDIF CALL PLALIN(XMAX,YMAX,ZMIN,XMAX,YMAX,ZMAX,XIN(1),YIN(1),ZIN(1), - A,B,C,XAUX,YAUX,ZAUX,IFAIL) IF(IFAIL.EQ.0)THEN NBOX=NBOX+1 CALL PLACO3(XAUX,YAUX,ZAUX,XBOX(NBOX),YBOX(NBOX),ZBOX(NBOX)) ENDIF CALL PLALIN(XMAX,YMIN,ZMAX,XMAX,YMIN,ZMIN,XIN(1),YIN(1),ZIN(1), - A,B,C,XAUX,YAUX,ZAUX,IFAIL) IF(IFAIL.EQ.0)THEN NBOX=NBOX+1 CALL PLACO3(XAUX,YAUX,ZAUX,XBOX(NBOX),YBOX(NBOX),ZBOX(NBOX)) ENDIF CALL PLALIN(XMAX,YMIN,ZMAX,XMAX,YMAX,ZMAX,XIN(1),YIN(1),ZIN(1), - A,B,C,XAUX,YAUX,ZAUX,IFAIL) IF(IFAIL.EQ.0)THEN NBOX=NBOX+1 CALL PLACO3(XAUX,YAUX,ZAUX,XBOX(NBOX),YBOX(NBOX),ZBOX(NBOX)) ENDIF CALL PLALIN(XMAX,YMIN,ZMAX,XMIN,YMIN,ZMAX,XIN(1),YIN(1),ZIN(1), - A,B,C,XAUX,YAUX,ZAUX,IFAIL) IF(IFAIL.EQ.0)THEN NBOX=NBOX+1 CALL PLACO3(XAUX,YAUX,ZAUX,XBOX(NBOX),YBOX(NBOX),ZBOX(NBOX)) ENDIF CALL PLALIN(XMIN,YMAX,ZMAX,XMIN,YMAX,ZMIN,XIN(1),YIN(1),ZIN(1), - A,B,C,XAUX,YAUX,ZAUX,IFAIL) IF(IFAIL.EQ.0)THEN NBOX=NBOX+1 CALL PLACO3(XAUX,YAUX,ZAUX,XBOX(NBOX),YBOX(NBOX),ZBOX(NBOX)) ENDIF CALL PLALIN(XMIN,YMAX,ZMAX,XMIN,YMIN,ZMAX,XIN(1),YIN(1),ZIN(1), - A,B,C,XAUX,YAUX,ZAUX,IFAIL) IF(IFAIL.EQ.0)THEN NBOX=NBOX+1 CALL PLACO3(XAUX,YAUX,ZAUX,XBOX(NBOX),YBOX(NBOX),ZBOX(NBOX)) ENDIF CALL PLALIN(XMIN,YMAX,ZMAX,XMAX,YMAX,ZMAX,XIN(1),YIN(1),ZIN(1), - A,B,C,XAUX,YAUX,ZAUX,IFAIL) IF(IFAIL.EQ.0)THEN NBOX=NBOX+1 CALL PLACO3(XAUX,YAUX,ZAUX,XBOX(NBOX),YBOX(NBOX),ZBOX(NBOX)) ENDIF *** If there are no box points, there can't be an intersect. IF(NBOX.LE.0)THEN C print *,' Polygon plane does not cross the box' NPL=0 RETURN ENDIF *** Ensure there is no butterfly. C print *,' Box before butterfly: ' C do i=1,nbox C print '(3e12.5)',xbox(i),ybox(i),zbox(i) C enddo CALL BUTFLD(NBOX,XBOX,YBOX,ZBOX) C call gsln(2) C call gpl2(nbox,xbox,ybox) C call guwk(0,1) C print *,' Number of box points: ',nbox *** Set tolerances. IF(LEPSG)THEN EPSX=EPSGX EPSY=EPSGY EPSZ=EPSGZ ELSE EPSX=1.0D-8*ABS(XMAX-XMIN) EPSY=1.0D-8*ABS(YMAX-YMIN) EPSZ=1.0D-8*ABS(ZMAX-ZMIN) IF(EPSX.LE.0)EPSX=1.0E-8 IF(EPSY.LE.0)EPSY=1.0E-8 IF(EPSZ.LE.0)EPSZ=1.0E-8 ENDIF *** Compute projections of the input points. DO 20 I=1,NIN CALL PLACO3(XIN(I),YIN(I),ZIN(I),XPOL(I),YPOL(I),ZPOL(I)) 20 CONTINUE C call gpl2(nin,xpol,ypol) C call guwk(0,1) *** Next find the intersections between the two sets. NPL=0 DO 40 J=1,NIN C print *,' Polygon corner ',J,' : ',xpol(j),ypol(j) * Set flag to see whether we search for mid-line intersects. SKIP=.FALSE. * Scan the box. DO 30 I=1,NBOX * See whether the polygon start is on any of the box edges. IF(ONLIND(XBOX(1+MOD(I-1,NBOX)),YBOX(1+MOD(I-1,NBOX)), - XBOX(1+MOD(I,NBOX)),YBOX(1+MOD(I,NBOX)), - XPOL(J),YPOL(J)).AND. - XIN(J).GE.XMIN-EPSX.AND.XIN(J).LE.XMAX+EPSX.AND. - YIN(J).GE.YMIN-EPSY.AND.YIN(J).LE.YMAX+EPSY.AND. - ZIN(J).GE.ZMIN-EPSZ.AND.ZIN(J).LE.ZMAX+EPSZ)THEN NPL=NPL+1 XPL(NPL)=XPOL(J) YPL(NPL)=YPOL(J) ZPL(NPL)=ZPOL(J) C print *,' Polygon corner on box line: ',xpl(npl),ypl(npl), C - zpl(npl) SKIP=.TRUE. ENDIF * See whether a box corner is on this polygon segment. IF(ONLIND(XPOL(1+MOD(J-1,NIN)),YPOL(1+MOD(J-1,NIN)), - XPOL(1+MOD(J,NIN)),YPOL(1+MOD(J,NIN)), - XBOX(I),YBOX(I)))THEN NPL=NPL+1 XPL(NPL)=XBOX(I) YPL(NPL)=YBOX(I) ZPL(NPL)=ZBOX(I) C print *,' Box corner on polygon line: ',xpl(npl),ypl(npl), C - zpl(npl) SKIP=.TRUE. ENDIF 30 CONTINUE * Make sure that the polygon segment at least crosses the box. X0=XIN(1+MOD(J-1,NIN)) Y0=YIN(1+MOD(J-1,NIN)) Z0=ZIN(1+MOD(J-1,NIN)) X1=XIN(1+MOD(J ,NIN)) Y1=YIN(1+MOD(J ,NIN)) Z1=ZIN(1+MOD(J ,NIN)) IF(.NOT.(((ABS(X0-XMIN).LT.EPSX.AND.ABS(X1-XMIN).LT.EPSX).OR. - (ABS(X0-XMAX).LT.EPSX.AND.ABS(X1-XMAX).LT.EPSX)).AND. - ((YMIN-Y0)*(Y0-YMAX).GE.0.OR.(YMIN-Y1)*(Y1-YMAX).GE.0).AND. - ((ZMIN-Z0)*(Z0-ZMAX).GE.0.OR.(ZMIN-Z1)*(Z1-ZMAX).GE.0).OR. - ((ABS(Y0-YMIN).LT.EPSY.AND.ABS(Y1-YMIN).LT.EPSY).OR. - (ABS(Y0-YMAX).LT.EPSY.AND.ABS(Y1-YMAX).LT.EPSY)).AND. - ((XMIN-X0)*(X0-XMAX).GE.0.OR.(XMIN-X1)*(X1-XMAX).GE.0).AND. - ((ZMIN-Z0)*(Z0-ZMAX).GE.0.OR.(ZMIN-Z1)*(Z1-ZMAX).GE.0).OR. - ((ABS(Z0-ZMIN).LT.EPSZ.AND.ABS(Z1-ZMIN).LT.EPSZ).OR. - (ABS(Z0-ZMAX).LT.EPSZ.AND.ABS(Z1-ZMAX).LT.EPSZ)).AND. - ((XMIN-X0)*(X0-XMAX).GE.0.OR.(XMIN-X1)*(X1-XMAX).GE.0).AND. - ((YMIN-Y0)*(Y0-YMAX).GE.0.OR.(YMIN-Y1)*(Y1-YMAX).GE.0)))THEN CALL CLIP3D(X0,Y0,Z0,X1,Y1,Z1,XMIN,YMIN,ZMIN,XMAX,YMAX,ZMAX, - IFAIL) C if(ifail.ne.0)print *,' Segment not through volume.' C if(ifail.ne.0)print '(2x,3f12.5)',x0,y0,z0 C if(ifail.ne.0)print '(2x,3f12.5)',x1,y1,z1 IF(IFAIL.NE.0)SKIP=.TRUE. C else C print *,' Line segment on outer box.' ENDIF * If neither of this happened, look for mid-line intersects. IF(.NOT.SKIP)THEN DO 100 I=1,NBOX CALL CRSPND(XBOX(1+MOD(I-1,NBOX)),YBOX(1+MOD(I-1,NBOX)), - XBOX(1+MOD(I ,NBOX)),YBOX(1+MOD(I ,NBOX)), - XPOL(1+MOD(J-1,NIN )),YPOL(1+MOD(J-1,NIN )), - XPOL(1+MOD(J ,NIN )),YPOL(1+MOD(J ,NIN )), - XAUX,YAUX,ADD) IF(ADD)THEN NPL=NPL+1 XPL(NPL)=XAUX YPL(NPL)=YAUX IF(XBOX(1+MOD(I,NBOX)).EQ.XBOX(1+MOD(I-1,NBOX)).AND. - YBOX(1+MOD(I,NBOX)).EQ.YBOX(1+MOD(I-1,NBOX)))THEN PRINT *,' !!!!!! PLAPOL WARNING : Unable to'// - ' compute intersect offset ; skipped.' NPL=NPL-1 GOTO 100 ELSEIF(ABS(XBOX(1+MOD(I,NBOX))- - XBOX(1+MOD(I-1,NBOX))).GT. - ABS(YBOX(1+MOD(I,NBOX))- - YBOX(1+MOD(I-1,NBOX))))THEN ZAUX1=ZBOX(1+MOD(I-1,NBOX))+ - (XAUX-XBOX(1+MOD(I-1,NBOX)))* - (ZBOX(1+MOD(I,NBOX))-ZBOX(1+MOD(I-1,NBOX)))/ - (XBOX(1+MOD(I,NBOX))-XBOX(1+MOD(I-1,NBOX))) ELSE ZAUX1=ZBOX(1+MOD(I-1,NBOX))+ - (YAUX-YBOX(1+MOD(I-1,NBOX)))* - (ZBOX(1+MOD(I,NBOX))-ZBOX(1+MOD(I-1,NBOX)))/ - (YBOX(1+MOD(I,NBOX))-YBOX(1+MOD(I-1,NBOX))) ENDIF IF(XPOL(1+MOD(J,NIN)).EQ.XPOL(1+MOD(J-1,NIN)).AND. - YPOL(1+MOD(J,NIN)).EQ.YPOL(1+MOD(J-1,NIN)))THEN PRINT *,' !!!!!! PLAPOL WARNING : Unable to'// - ' compute intersect offset ; skipped.' NPL=NPL-1 GOTO 100 ELSEIF(ABS(XPOL(1+MOD(J,NIN))-XPOL(1+MOD(J-1,NIN))).GT. - ABS(YPOL(1+MOD(J,NIN))-YPOL(1+MOD(J-1,NIN))))THEN ZAUX2=ZPOL(1+MOD(J-1,NIN))+ - (XAUX-XPOL(1+MOD(J-1,NIN)))* - (ZPOL(1+MOD(J,NIN))-ZPOL(1+MOD(J-1,NIN)))/ - (XPOL(1+MOD(J,NIN))-XPOL(1+MOD(J-1,NIN))) ELSE ZAUX2=ZPOL(1+MOD(J-1,NIN))+ - (YAUX-YPOL(1+MOD(J-1,NIN)))* - (ZPOL(1+MOD(J,NIN))-ZPOL(1+MOD(J-1,NIN)))/ - (YPOL(1+MOD(J,NIN))-YPOL(1+MOD(J-1,NIN))) ENDIF ZPL(NPL)=0.5*(ZAUX1+ZAUX2) C print *,' Offsets: ',zaux1,zaux2,zpl(npl) C print *,' Line crossing: ',xpl(npl),ypl(npl),zpl(npl) ENDIF 100 CONTINUE ENDIF 40 CONTINUE *** Find the vertices of the box internal to the polygon. DO 50 I=1,NBOX C print *,' Box ',i,':',xbox(i),ybox(i),zbox(i) CALL INTERD(NIN,XPOL,YPOL,XBOX(I),YBOX(I),INSIDE,EDGE) * Skip box corners on the polygon. IF(EDGE)GOTO 50 * Add internal points. IF(INSIDE)THEN NPL=NPL+1 XPL(NPL)=XBOX(I) YPL(NPL)=YBOX(I) ZPL(NPL)=ZBOX(I) C print *,' box in polygon: ',xpl(npl),ypl(npl),zpl(npl) ENDIF 50 CONTINUE *** Find the vertices of the polygon internal to the box. DO 70 I=1,NIN C print *,' Pol ',i,':',xpol(i),ypol(i),zpol(i) * Skip points which were not inside the box. IF(XIN(I).LT.XMIN-EPSX.OR.XIN(I).GT.XMAX+EPSX.OR. - YIN(I).LT.YMIN-EPSY.OR.YIN(I).GT.YMAX+EPSY.OR. - ZIN(I).LT.ZMIN-EPSZ.OR.ZIN(I).GT.ZMAX+EPSZ)GOTO 70 * Check whether the point is internal. CALL INTERD(NBOX,XBOX,YBOX,XPOL(I),YPOL(I),INSIDE,EDGE) * Skip polygon corners on the box. IF(EDGE)GOTO 70 * Add internal points. IF(INSIDE)THEN NPL=NPL+1 XPL(NPL)=XPOL(I) YPL(NPL)=YPOL(I) ZPL(NPL)=ZPOL(I) C print *,' polygon in box: ',xpl(npl),ypl(npl),zpl(npl) ENDIF 70 CONTINUE *** Ensure there is no butterfly. C print *,' Checking for butterfly' CALL BUTFLD(NPL,XPL,YPL,ZPL) C print *,' Continue ? Enter an integer.' C read *,j C call gsln(1) C call gpl2(npl,xpl,ypl) C call guwk(0,1) C print *,' PLAPOL - Final result, NPL=',npl C do i=1,npl C print '(3f12.5)',xpl(i),ypl(i),zpl(i) C enddo END +DECK,PLACUT. SUBROUTINE PLACUT(X1,Y1,Z1,X2,Y2,Z2,XCUT,YCUT,CUT) *----------------------------------------------------------------------- * PLACUT - Cuts a plane with a line. * (Last changed on 7/11/97.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PARAMETERS. DOUBLE PRECISION X1,Y1,Z1,X2,Y2,Z2,XCUT,YCUT,A(3,3),B(3) INTEGER IR(3),IFAIL LOGICAL CUT *** Initial settings. XCUT=0 YCUT=0 CUT=.FALSE. *** Fill the matrices. A(1,1)=FPROJ(1,1) A(2,1)=FPROJ(1,2) A(3,1)=FPROJ(1,3) A(1,2)=FPROJ(2,1) A(2,2)=FPROJ(2,2) A(3,2)=FPROJ(2,3) A(1,3)=X1-X2 A(2,3)=Y1-Y2 A(3,3)=Z1-Z2 B(1)=X1-FPROJ(3,1) B(2)=Y1-FPROJ(3,2) B(3)=Z1-FPROJ(3,3) *** Solve the equation. CALL DEQN(3,A,3,IR,IFAIL,1,B) *** Immediate return if there is no solution. IF(IFAIL.NE.0)RETURN *** If there is a solution, ensure it is between point 1 and 2. IF(B(3).LT.0.OR.B(3).GT.1)RETURN *** Otherwise it is a bonafide solution. XCUT=B(1) YCUT=B(2) CUT=.TRUE. END +DECK,PLACOO. SUBROUTINE PLACOO(X1,Y1,Z1,XCUT,YCUT) *----------------------------------------------------------------------- * PLACOO - Determines plane coordinates. * (Last changed on 29/ 9/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PARAMETERS. DOUBLE PRECISION X1,Y1,Z1,XCUT,YCUT,B(3) *** Fill the vector. B(1)=X1 B(2)=Y1 B(3)=Z1 *** Solve the equation. CALL DFEQN(3,FPRMAT,3,IPRMAT,1,B) *** Return the solution. XCUT=B(1) YCUT=B(2) END +DECK,PLACO3. SUBROUTINE PLACO3(X1,Y1,Z1,XCUT,YCUT,ZCUT) *----------------------------------------------------------------------- * PLACO3 - Determines plane coordinates. * (Last changed on 29/ 9/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PARAMETERS. DOUBLE PRECISION X1,Y1,Z1,XCUT,YCUT,ZCUT,B(3) *** Fill the vector. B(1)=X1 B(2)=Y1 B(3)=Z1 *** Solve the equation. CALL DFEQN(3,FPRMAT,3,IPRMAT,1,B) *** Return the solution. XCUT=B(1) YCUT=B(2) ZCUT=(FPROJA*X1+FPROJB*Y1+FPROJC*Z1)/FPROJN END +DECK,PLALIN. SUBROUTINE PLALIN(X1,Y1,Z1,X2,Y2,Z2,X0,Y0,Z0,A,B,C, - XCUT,YCUT,ZCUT,IFAIL) *----------------------------------------------------------------------- * PLALIN - Cuts an arbitrary plane with a line. * Variables : (X1,Y1,Z1) : starting point of the line * (X2,Y2,Z2) : end point of the line * (X0,Y0,Z0) : point on the plane * (A,B,C) : parameters of the plane * (Last changed on 31/ 1/98.) *----------------------------------------------------------------------- implicit none DOUBLE PRECISION X1,Y1,Z1,X2,Y2,Z2,X0,Y0,Z0,A,B,C, - XCUT,YCUT,ZCUT,XLAM,PROD1,PROD2,EPS INTEGER IFAIL *** Initial values for the return parameters. XCUT=0 YCUT=0 ZCUT=0 *** Form the two products. PROD1=(X0-X1)*A+(Y0-Y1)*B+(Z0-Z1)*C PROD2=(X2-X1)*A+(Y2-Y1)*B+(Z2-Z1)*C *** Set a tolerance for lambda. EPS=1.0D-5 *** Check the products are non-zero. IF(ABS(PROD2).GT.1.0D-6*SQRT((A**2+B**2+C**2)* - (X2-X1)**2+(Y2-Y1)**2+(Z2-Z1)**2))THEN XLAM=PROD1/PROD2 IF(XLAM.GE.-EPS.AND.XLAM.LE.1.0D0+EPS)THEN IFAIL=0 ELSE IFAIL=1 ENDIF XLAM=MAX(0.0D0,MIN(1.0D0,XLAM)) XCUT=X1+XLAM*(X2-X1) YCUT=Y1+XLAM*(Y2-Y1) ZCUT=Z1+XLAM*(Z2-Z1) C print *,' PLALIN - Line crosses plane' C print *,' abc =',a,b,c C print *,' line =',x1,y1,z1 C print *,' line =',x2,y2,z2 C print *,' prod2=',prod2 ELSE XCUT=0 YCUT=0 ZCUT=0 IFAIL=1 C print *,' PLALIN - Line does not cross plane' ENDIF END +DECK,PLACHK. SUBROUTINE PLACHK(NPL,XPL,YPL,ZPL,IFAIL) *----------------------------------------------------------------------- * PLACHK - Checks whether a set of points builds a non-trivial * polygon in the (x,y) plane. * (Last changed on 14/ 4/10.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PARAMETERS. +SEQ,PRINTPLOT. INTEGER NPL,IFAIL,I1,I2,I DOUBLE PRECISION XPL(NPL),YPL(NPL),ZPL(NPL),X1,Y1,X2,Y2, - DIST,XMIN,YMIN,XMAX,YMAX,EPSX,EPSY *** First check number of points. IF(NPL.LT.3)THEN IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLACHK DEBUG :'', - '' Rejected - Not enough points: '',I5)') NPL IFAIL=1 RETURN ENDIF *** Find a second point at maximum distance of the first. DIST=0 I1=0 XMIN=XPL(1) YMIN=YPL(1) XMAX=XPL(1) YMAX=YPL(1) DO 10 I=2,NPL XMIN=MIN(XMIN,XPL(I)) YMIN=MIN(YMIN,YPL(I)) XMAX=MAX(XMAX,XPL(I)) YMAX=MAX(YMAX,YPL(I)) IF((XPL(I)-XPL(1))**2+(YPL(I)-YPL(1))**2.GT.DIST)THEN X1=XPL(I)-XPL(1) Y1=YPL(I)-YPL(1) DIST=X1**2+Y1**2 I1=I ENDIF 10 CONTINUE *** Set tolerances. IF(LEPSG)THEN EPSX=EPSGX EPSY=EPSGY ELSE EPSX=1.0D-6*(ABS(XMAX)+ABS(XMIN)) EPSY=1.0D-6*(ABS(YMAX)+ABS(YMIN)) IF(EPSX.LE.0)EPSX=1.0D-6 IF(EPSY.LE.0)EPSY=1.0D-6 ENDIF *** See whether there is a range at all. IF(ABS(XMAX-XMIN).LE.EPSX.AND.ABS(YMAX-YMIN).LE.EPSY)THEN IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLACHK DEBUG :'', - '' Rejected - is a single point.'')') IFAIL=1 RETURN ENDIF *** See whether there is a second point. IF(DIST.LE.EPSX**2+EPSY**2.OR.I1.LE.0)THEN IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLACHK DEBUG :'', - '' Rejected - No second point.'')') IFAIL=1 RETURN ENDIF *** Find a third point maximising the external product. DIST=0 I2=0 DO 20 I=2,NPL IF(I.EQ.I1)GOTO 20 IF(ABS(X1*(YPL(I)-YPL(1))-Y1*(XPL(I)-XPL(1))).GT.DIST)THEN X2=XPL(I)-XPL(1) Y2=YPL(I)-YPL(1) DIST=ABS(X1*Y2-Y1*X2) I2=I ENDIF 20 CONTINUE IF(DIST.LE.EPSX*EPSY.OR.I2.LE.0)THEN IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLACHK DEBUG :'', - '' Rejected - No third point, DIST2 = '',F10.3, - '' EPS = '',2F10.3)') DIST,EPSX,EPSY IFAIL=1 RETURN ENDIF *** Seems to be OK. IFAIL=0 END +DECK,PLASEP. SUBROUTINE PLASEP( - NPL1,XPL1,YPL1,ZPL1,A1,B1,C1,D1, - NPL2,XPL2,YPL2,ZPL2,A2,B2,C2,D2, - X0,Y0,Z0,AI,BI,CI,IFAIL) *----------------------------------------------------------------------- * PLASEP - Computes a plane that includes the crossing between plane * 1 and 2 and doesn't coincide with either. * them for plotting. * (Last changed on 29/ 9/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PARAMETERS. +SEQ,PRINTPLOT. INTEGER IFAIL,NPL1,NPL2,NCOM,I,J,K DOUBLE PRECISION A1,B1,C1,D1,A2,B2,C2,D2,XC,YC,ZC,XL, - X0,Y0,Z0,AI,BI,CI,FNORM, - EPSX,EPSY,EPSZ,XMIN,YMIN,ZMIN,XMAX,YMAX,ZMAX, - XPL1(NPL1),YPL1(NPL1),ZPL1(NPL1), - XPL2(NPL2),YPL2(NPL2),ZPL2(NPL2), - XCOM(MXEDGE),YCOM(MXEDGE),ZCOM(MXEDGE) *** Set tolerances. IF(LEPSG)THEN EPSX=EPSGX EPSY=EPSGY EPSZ=EPSGZ ELSE XMIN=XPL1(1) XMAX=XPL1(1) YMIN=YPL1(1) YMAX=YPL1(1) ZMIN=ZPL1(1) ZMAX=ZPL1(1) DO 10 I=2,NPL1 XMIN=MIN(XMIN,XPL1(I)) XMAX=MAX(XMAX,XPL1(I)) YMIN=MIN(YMIN,YPL1(I)) YMAX=MAX(YMAX,YPL1(I)) ZMIN=MIN(ZMIN,ZPL1(I)) ZMAX=MAX(ZMAX,ZPL1(I)) 10 CONTINUE DO 20 I=1,NPL2 XMIN=MIN(XMIN,XPL2(I)) XMAX=MAX(XMAX,XPL2(I)) YMIN=MIN(YMIN,YPL2(I)) YMAX=MAX(YMAX,YPL2(I)) ZMIN=MIN(ZMIN,ZPL2(I)) ZMAX=MAX(ZMAX,ZPL2(I)) 20 CONTINUE EPSX=1.0D-8*ABS(XMAX-XMIN) EPSY=1.0D-8*ABS(YMAX-YMIN) EPSZ=1.0D-8*ABS(ZMAX-ZMIN) IF(EPSX.LE.0)EPSX=1.0D-8 IF(EPSY.LE.0)EPSY=1.0D-8 IF(EPSZ.LE.0)EPSZ=1.0D-8 ENDIF *** Initial values for the return parameters. X0=0 Y0=0 Z0=0 AI=0 BI=0 CI=0 *** See whether the planes are parallel. IF((B1*C2-B2*C1)**2+(C1*A2-C2*A1)**2+(A1*B2-A2*B1)**2.LT. - 1.0D-6*SQRT((A1**2+B1**2+C1**2)*(A2**2+B2**2+C2**2)))THEN IFAIL=1 RETURN ENDIF *** See how many common points there are between the curves. NCOM=0 DO 100 I=1,NPL1 DO 110 J=1,NPL2 IF(ABS(XPL1(I)-XPL2(J)).LE.EPSX.AND. - ABS(YPL1(I)-YPL2(J)).LE.EPSY.AND. - ABS(ZPL1(I)-ZPL2(J)).LE.EPSZ)THEN DO 120 K=1,NCOM IF(ABS(XPL1(I)+XPL2(J)-2*XCOM(K)).LE.EPSX.AND. - ABS(YPL1(I)+YPL2(J)-2*YCOM(K)).LE.EPSY.AND. - ABS(ZPL1(I)+ZPL2(J)-2*ZCOM(K)).LE.EPSZ)GOTO 110 120 CONTINUE NCOM=NCOM+1 IF(NCOM.GE.MXEDGE)GOTO 110 XCOM(NCOM)=(XPL1(I)+XPL2(J))/2 YCOM(NCOM)=(YPL1(I)+YPL2(J))/2 ZCOM(NCOM)=(ZPL1(I)+ZPL2(J))/2 ENDIF 110 CONTINUE 100 CONTINUE *** Debugging output. IF(LDEBUG)THEN WRITE(LUNOUT,'('' ++++++ PLASEP DEBUG : Number of'', - '' common points: '',I3)') NCOM DO 130 I=1,NCOM WRITE(LUNOUT,'(26X,''Point '',I3,'' (x,y,z)='',3F12.5)') - I,XCOM(I),YCOM(I),ZCOM(I) 130 CONTINUE ENDIF *** No common points. IF(NCOM.EQ.0)THEN * Compute a point on the separation line. IF(ABS(B1*C2-B2*C1).GT.ABS(C1*A2-C2*A1).AND. - ABS(B1*C2-B2*C1).GT.ABS(A1*B2-A2*B1))THEN X0=0 Y0=+(D1*C2-D2*C1)/(B1*C2-B2*C1) Z0=-(D1*B2-D2*B1)/(B1*C2-B2*C1) ELSEIF(ABS(C1*A2-C2*A1).GT.ABS(A1*B2-A2*B1))THEN X0=+(D1*C2-D2*C1)/(A1*C2-A2*C1) Y0=0 Z0=-(D1*A2-D2*A1)/(A1*C2-A2*C1) ELSE X0=+(D1*B2-D2*B1)/(A1*B2-A2*B1) Y0=-(D1*A2-D2*A1)/(A1*B2-A2*B1) Z0=0 ENDIF * Establish the parameters along the separation line. AI=B1*C2-C1*B2 BI=C1*A2-A1*C2 CI=A1*B2-B1*A2 FNORM=SQRT(AI**2+BI**2+CI**2) IF(FNORM.LE.0)THEN PRINT *,' !!!!!! PLASEP WARNING : Intersect line'// - ' not found; no separation plane.' IFAIL=1 RETURN ENDIF AI=AI/FNORM BI=BI/FNORM CI=CI/FNORM *** A single point in common. ELSEIF(NCOM.EQ.1)THEN * Use the point as reference. X0=XCOM(1) Y0=YCOM(1) Z0=ZCOM(1) * Still compute the parameters of the separation line. AI=B1*C2-C1*B2 BI=C1*A2-A1*C2 CI=A1*B2-B1*A2 FNORM=SQRT(AI**2+BI**2+CI**2) IF(FNORM.LE.0)THEN PRINT *,' !!!!!! PLASEP WARNING : Intersect line'// - ' not found; no separation plane.' IFAIL=1 RETURN ENDIF AI=AI/FNORM BI=BI/FNORM CI=CI/FNORM *** Two points in common. ELSEIF(NCOM.EQ.2)THEN * Use the first point as reference. X0=XCOM(1) Y0=YCOM(1) Z0=ZCOM(1) * Compute the separation line from the other point. AI=XCOM(2)-XCOM(1) BI=YCOM(2)-YCOM(1) CI=ZCOM(2)-ZCOM(1) FNORM=SQRT(AI**2+BI**2+CI**2) IF(FNORM.LE.0)THEN PRINT *,' !!!!!! PLASEP WARNING : Intersect line'// - ' not found; no separation plane.' IFAIL=1 RETURN ENDIF AI=AI/FNORM BI=BI/FNORM CI=CI/FNORM *** More than 2 points in common. ELSE * Use the first point as reference. X0=XCOM(1) Y0=YCOM(1) Z0=ZCOM(1) * Compute the separation line from the other point. AI=XCOM(2)-XCOM(1) BI=YCOM(2)-YCOM(1) CI=ZCOM(2)-ZCOM(1) FNORM=SQRT(AI**2+BI**2+CI**2) IF(FNORM.LE.0)THEN PRINT *,' !!!!!! PLASEP WARNING : Intersect line'// - ' not found; no separation plane.' IFAIL=1 RETURN ENDIF AI=AI/FNORM BI=BI/FNORM CI=CI/FNORM * See whether the other points are on the line. DO 200 I=3,NCOM XL=((XCOM(I)-X0)*AI+(YCOM(I)-Y0)*BI+(ZCOM(I)-Z0)*CI)/FNORM XC=X0+XL*AI YC=Y0+XL*BI ZC=Z0+XL*CI IF(ABS(XCOM(I)-XC).GT.EPSX.OR. - ABS(YCOM(I)-YC).GT.EPSY.OR. - ABS(ZCOM(I)-ZC).GT.EPSZ)THEN PRINT *,' !!!!!! PLASEP WARNING : Found non-colinear'// - ' common points; no separation plane.' IFAIL=1 RETURN ENDIF 200 CONTINUE ENDIF *** Debugging result. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLASEP DEBUG : Point: '', - 4X,3F12.5/26X,''Direction: '',3F12.5)') X0,Y0,Z0,AI,BI,CI *** Seems to have worked. IFAIL=0 END +DECK,PLARED. SUBROUTINE PLARED(NPL,XPL,YPL,ZPL,A,B,C,D) *----------------------------------------------------------------------- * PLARED - Removes duplicate branches from a curve. * (Last changed on 2/ 2/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PARAMETERS. INTEGER NPL,I,J,NNEW,JCUT DOUBLE PRECISION XPL(NPL),YPL(NPL),ZPL(NPL),EPSX,EPSY, - XSHIFT,YSHIFT,EPS,A,B,C,D,XMIN,YMIN,XMAX,YMAX LOGICAL MARK(MXEDGE),ONLIND EXTERNAL ONLIND *** Check number of points. IF(NPL.GT.MXEDGE)THEN PRINT *,' !!!!!! PLARED WARNING : Too many points.' RETURN ELSEIF(NPL.LT.3)THEN RETURN ENDIF *** Set tolerances. IF(LEPSG)THEN EPSX=EPSGX EPSY=EPSGY ELSE * Compute range. XMIN=XPL(1) XMAX=XPL(1) YMIN=YPL(1) YMAX=YPL(1) DO 90 I=2,NPL XMIN=MIN(XMIN,XPL(I)) XMAX=MAX(XMAX,XPL(I)) YMIN=MIN(YMIN,YPL(I)) YMAX=MAX(YMAX,YPL(I)) 90 CONTINUE * Set epsilons accordingly. EPSX=1.0D-8*ABS(XMAX-XMIN) EPSY=1.0D-8*ABS(YMAX-YMIN) IF(EPSX.LE.0)EPSX=1.0D-8 IF(EPSY.LE.0)EPSY=1.0D-8 ENDIF *** Make a first marker list. 100 CONTINUE DO 10 I=1,NPL MARK(I)=.FALSE. 10 CONTINUE *** Find a point that is surrounded on both side by equal points. DO 20 I=1,NPL JCUT=0 DO 30 J=1,NPL/2 IF( ABS(XPL(1+MOD(I+J-1 ,NPL))- - XPL(1+MOD(I-J-1+NPL,NPL))).GT.EPSX.OR. - ABS(YPL(1+MOD(I+J-1 ,NPL))- - YPL(1+MOD(I-J-1+NPL,NPL))).GT.EPSY)GOTO 40 JCUT=J 30 CONTINUE 40 CONTINUE * See whether we found one. IF(JCUT.GT.0)THEN C print *,' Cutting a tail of ',JCUT,' points.' DO 70 J=I-JCUT+1,I+JCUT MARK(1+MOD(J-1+NPL,NPL))=.TRUE. 70 CONTINUE GOTO 50 ENDIF 20 CONTINUE *** See whether there are partial returns. DO 80 I=1,NPL IF(ONLIND( - XPL(1+MOD(I-1 ,NPL)),YPL(1+MOD(I-1 ,NPL)), - XPL(1+MOD(I ,NPL)),YPL(1+MOD(I ,NPL)), - XPL(1+MOD(I-2+NPL,NPL)),YPL(1+MOD(I-2+NPL,NPL))).OR. - ONLIND( - XPL(1+MOD(I-1 ,NPL)),YPL(1+MOD(I-1 ,NPL)), - XPL(1+MOD(I-2+NPL,NPL)),YPL(1+MOD(I-2+NPL,NPL)), - XPL(1+MOD(I ,NPL)),YPL(1+MOD(I ,NPL))))THEN MARK(1+MOD(I-1 ,NPL))=.TRUE. C print *,' Cutting a partial return.' GOTO 50 ENDIF 80 CONTINUE *** No further cuts, move points which appear twice. DO 120 I=1,NPL DO 110 J=I+1,NPL * Identify the points. IF(ABS(XPL(I)-XPL(J)).LT.100*EPSX.AND. - ABS(YPL(I)-YPL(J)).LT.100*EPSY)THEN * Find the axis along which to displace the points. XSHIFT=(XPL(1+MOD(I-2+NPL,NPL))+XPL(1+MOD(I,NPL)))/2- - XPL(I) YSHIFT=(YPL(1+MOD(I-2+NPL,NPL))+YPL(1+MOD(I,NPL)))/2- - YPL(I) IF(SQRT(XSHIFT**2+YSHIFT**2).LE.SQRT(EPSX**2+EPSY**2))THEN PRINT *,' !!!!!! PLARED WARNING : Curve is too'// - ' small ; eliminated.' NPL=0 RETURN ENDIF EPS=1000*SQRT(EPSX**2+EPSY**2)/SQRT(XSHIFT**2+YSHIFT**2) XPL(I)=XPL(I)+XSHIFT*EPS YPL(I)=YPL(I)+YSHIFT*EPS ZPL(I)=(D-A*XPL(I)-B*YPL(I))/C XSHIFT=(XPL(1+MOD(J-2+NPL,NPL))+XPL(1+MOD(J,NPL)))/2- - XPL(J) YSHIFT=(YPL(1+MOD(J-2+NPL,NPL))+YPL(1+MOD(J,NPL)))/2- - YPL(J) IF(SQRT(XSHIFT**2+YSHIFT**2).LE.SQRT(EPSX**2+EPSY**2))THEN PRINT *,' !!!!!! PLARED WARNING : Curve is too'// - ' small ; eliminated.' NPL=0 RETURN ENDIF EPS=1000*SQRT(EPSX**2+EPSY**2)/SQRT(XSHIFT**2+YSHIFT**2) XPL(J)=XPL(J)+XSHIFT*EPS YPL(J)=YPL(J)+YSHIFT*EPS ZPL(J)=(D-A*XPL(J)-B*YPL(J))/C C print *,' Shifting a point to avoid overlaps.' ENDIF 110 CONTINUE 120 CONTINUE RETURN *** Eliminate the piece. 50 CONTINUE NNEW=0 DO 60 I=1,NPL IF(MARK(I))GOTO 60 NNEW=NNEW+1 XPL(NNEW)=XPL(I) YPL(NNEW)=YPL(I) ZPL(NNEW)=ZPL(I) 60 CONTINUE NPL=NNEW GOTO 100 END +DECK,PLASPL. SUBROUTINE PLASPL(IREF1,IREF2,NREF,IREFO,KEEP,IFAIL) *----------------------------------------------------------------------- * PLASPL - Isolates the parts of plane 1 that are not hidden by 2. * (Last changed on 20/10/10.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. +SEQ,CONSTANTS. +SEQ,PARAMETERS. INTEGER MXCORN PARAMETER(MXCORN=3*MXEDGE) DOUBLE PRECISION - XPL1(MXEDGE),YPL1(MXEDGE),ZPL1(MXEDGE),APL1,BPL1,CPL1,DPL1, - XPL2(MXEDGE),YPL2(MXEDGE),ZPL2(MXEDGE),APL2,BPL2,CPL2,DPL2, - XINT,YINT,ZINT,AINT,BINT,CDUM,EPSD, - XSEPA,YSEPA,XSEPB,YSEPB,XMEAN,YMEAN, - XPL(MXEDGE),YPL(MXEDGE),ZPL(MXEDGE), - XCUT(MXCORN),YCUT(MXCORN),ZCUT(MXCORN), - XL(MXCORN,3),YL(MXCORN,3),ZL(MXCORN,3), - Q(MXCORN,3),QMIN,XAUX,YAUX,ZAUX,QAUX, - XC,YC,ZC,EPSX,EPSY,EPSZ,XMIN,YMIN,ZMIN,XMAX,YMAX,ZMAX, - ZAUX1,ZAUX2,ZAUX3,ZAUX4, - XMIN1,YMIN1,ZMIN1,XMAX1,YMAX1,ZMAX1, - XMIN2,YMIN2,ZMIN2,XMAX2,YMAX2,ZMAX2, - X1,Y1,PHI0,PHI1,PHI2,PHI3,PHI4,PHI5,PHI6,PHIOPT,DX,DY,STEP INTEGER NPL1,NPL2,IFAIL1,IFAIL2,IFAIL,I,J,K,N1,N2,NS, - M1,M2,IQMIN,IAUX,IT(MXCORN,3),IREF(MXCORN,3,3), - NPL,IL,JL,IP,JP,JP2,JP3,NP,IDIR,JDIR,NFOUND,NFOUN1,NFOUN2, - INITP,INITD,INITL,NCUT,J0,J1,K0,K1,IREFO(MXPLAN), - IREF1,IREF2,NREF,ICOL1,ICOL2,IR, - ISIDE0,ISIDE1,ISIDE2,ISIDE3,ISIDE4,ISIDE5,ISIDE6, - N1L,N1R,N2L,N2R LOGICAL ADD,INSIDE,IN1,IN2,IN3,IN4,EDGE,EDGE1,EDGE2,EDGE3,EDGE4, - ONLIND,CROSSD,START,OK,LSEP,MARK1(MXCORN),MARK2(MXCORN), - SWAP,KEEP,HOLE EXTERNAL ONLIND,CROSSD *** Initial setting of the number of produced planes. NREF=0 *** Retrieve both planes. CALL PLABU2('READ',IREF1,NPL1,XPL1,YPL1,ZPL1,APL1,BPL1,CPL1,DPL1, - ICOL1,IFAIL1) CALL PLABU2('READ',IREF2,NPL2,XPL2,YPL2,ZPL2,APL2,BPL2,CPL2,DPL2, - ICOL2,IFAIL2) IF(IFAIL1.NE.0.OR.IFAIL2.NE.0)THEN PRINT *,' !!!!!! PLASPL WARNING : Unable to retrieve a'// - ' projected polygon; skipped.' IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLASPL DEBUG :''// - '' Reference numbers: '',2I4)') IREF1,IREF2 IFAIL=1 RETURN ENDIF *** If the size of either is 0, simply return. IF(NPL1.LE.2.OR.NPL2.LE.2)THEN KEEP=.TRUE. IFAIL=0 RETURN ENDIF * Don't process planes that have no z-component. IF(CPL1**2.LT.1.0D-6*(APL1**2+BPL1**2).OR.CPL1.EQ.0.OR. - CPL2**2.LT.1.0D-6*(APL2**2+BPL2**2).OR.CPL2.EQ.0)THEN IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLASPL DEBUG :'', - '' No z-component found; return with IFAIL=1.'')') IFAIL=1 RETURN ENDIF *** Don't try to split parallel planes. IF((BPL1*CPL2-BPL2*CPL1)**2+(CPL1*APL2-CPL2*APL1)**2+ - (APL1*BPL2-APL2*BPL1)**2.LT. - 1.0D-4*SQRT((APL1**2+BPL1**2+CPL1**2)* - (APL2**2+BPL2**2+CPL2**2)))THEN LSEP=.FALSE. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLASPL DEBUG :'', - '' Parallel planes, no separation computed.'')') * Otherwise compute separation plane. ELSE CALL PLASEP( - NPL1,XPL1,YPL1,ZPL1,APL1,BPL1,CPL1,DPL1, - NPL2,XPL2,YPL2,ZPL2,APL2,BPL2,CPL2,DPL2, - XINT,YINT,ZINT,AINT,BINT,CDUM,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! PLASPL WARNING : Unable to compute'// - ' a separation plane; plot may be incorrect.' KEEP=.TRUE. IFAIL=1 RETURN ENDIF LSEP=.TRUE. ENDIF *** Compute the various tolerances. EPSD=0 XMIN1=XPL1(1) YMIN1=YPL1(1) ZMIN1=ZPL1(1) XMAX1=XPL1(1) YMAX1=YPL1(1) ZMAX1=ZPL1(1) XMEAN=0 YMEAN=0 DO 10 I=1,NPL1 EPSD=MAX(EPSD,ABS(APL2*XPL1(I)+BPL2*YPL1(I)+CPL2*ZPL1(I))) XMIN1=MIN(XMIN1,XPL1(I)) YMIN1=MIN(YMIN1,YPL1(I)) ZMIN1=MIN(ZMIN1,ZPL1(I)) XMAX1=MAX(XMAX1,XPL1(I)) YMAX1=MAX(YMAX1,YPL1(I)) ZMAX1=MAX(ZMAX1,ZPL1(I)) XMEAN=XMEAN+XPL1(I) YMEAN=YMEAN+YPL1(I) 10 CONTINUE XMIN2=XPL2(1) YMIN2=YPL2(1) ZMIN2=ZPL2(1) XMAX2=XPL2(1) YMAX2=YPL2(1) ZMAX2=ZPL2(1) DO 20 I=1,NPL2 EPSD=MAX(EPSD,ABS(APL1*XPL2(I)+BPL1*YPL2(I)+CPL1*ZPL2(I))) XMIN2=MIN(XMIN2,XPL2(I)) YMIN2=MIN(YMIN2,YPL2(I)) ZMIN2=MIN(ZMIN2,ZPL2(I)) XMAX2=MAX(XMAX2,XPL2(I)) YMAX2=MAX(YMAX2,YPL2(I)) ZMAX2=MAX(ZMAX2,ZPL2(I)) XMEAN=XMEAN+XPL2(I) YMEAN=YMEAN+YPL2(I) 20 CONTINUE XMIN=MIN(XMIN1,XMIN2) YMIN=MIN(YMIN1,YMIN2) ZMIN=MIN(ZMIN1,ZMIN2) XMAX=MAX(XMAX1,XMAX2) YMAX=MAX(YMAX1,YMAX2) ZMAX=MAX(ZMAX1,ZMAX2) EPSD=1.0D-6*EPSD IF(LEPSG)THEN EPSX=EPSGX EPSY=EPSGY EPSZ=EPSGZ ELSE EPSX=1.0D-6*MAX(ABS(XMAX),ABS(XMIN)) EPSY=1.0D-6*MAX(ABS(YMAX),ABS(YMIN)) EPSZ=1.0D-6*MAX(ABS(ZMAX),ABS(ZMIN)) ENDIF XMEAN=XMEAN/DBLE(NPL1+NPL2) YMEAN=YMEAN/DBLE(NPL1+NPL2) * Override the z-tolerance. EPSD=EPSZ * Debugging output. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLASPL DEBUG :'', - '' Tolerances: x='',E12.5,'', y='',E12.5/38X, - ''z='',E12.5,'', d='',E12.5)') EPSX,EPSY,EPSZ,EPSD * If curve 1 is entirely above 2, simply keep. IF(ZMIN1.GE.ZMAX2)THEN KEEP=.TRUE. IFAIL=0 RETURN * If the curves don't overlap at all, simply keep. ELSEIF(XMIN1.GE.XMAX2.OR.XMIN2.GE.XMAX1.OR. - YMIN1.GE.YMAX2.OR.YMIN2.GE.YMAX1)THEN KEEP=.TRUE. IFAIL=0 RETURN * Otherwise, try to eliminate pieces of curve 1. ELSE KEEP=.FALSE. ENDIF * Compute start and end point of a separation line. XAUX=ABS(XMAX-XMIN) XMIN=XMIN-XAUX XMAX=XMAX+XAUX YAUX=ABS(YMAX-YMIN) YMIN=YMIN-YAUX YMAX=YMAX+YAUX IF(LSEP.AND.ABS(AINT).GT.ABS(BINT).AND.AINT.NE.0)THEN XSEPA=XMIN YSEPA=YINT+(XMIN-XINT)*BINT/AINT XSEPB=XMAX YSEPB=YINT+(XMAX-XINT)*BINT/AINT CALL CLIP2D(XSEPA,YSEPA,XSEPB,YSEPB,XMIN,YMIN,XMAX,YMAX, - IFAIL1) IF(IFAIL1.NE.0)THEN XSEPA=XMAX YSEPA=YMAX XSEPB=XMAX YSEPB=YMAX ENDIF ELSEIF(LSEP.AND.BINT.NE.0)THEN XSEPA=XINT+(YMIN-YINT)*AINT/BINT YSEPA=YMIN XSEPB=XINT+(YMAX-YINT)*AINT/BINT YSEPB=YMAX CALL CLIP2D(XSEPA,YSEPA,XSEPB,YSEPB,XMIN,YMIN,XMAX,YMAX, - IFAIL1) IF(IFAIL1.NE.0)THEN XSEPA=XMAX YSEPA=YMAX XSEPB=XMAX YSEPB=YMAX ENDIF ELSE XSEPA=XMAX YSEPA=YMAX XSEPB=XMAX YSEPB=YMAX ENDIF * Show the separation line in debugging mode. IF(LDEBUG.AND.LSEP)THEN XPL(1)=XSEPA YPL(1)=YSEPA XPL(2)=XSEPB YPL(2)=YSEPB CALL GSLN(2) CALL GSPLCI(8) CALL GPL2(2,XPL,YPL) ENDIF *** Check whether we have to do anything, first non-parallel planes. IF(LSEP)THEN N1L=0 N1R=0 N2L=0 N2R=0 DO 30 I=1,NPL1 IF((XPL1(I)-XINT)*BINT-(YPL1(I)-YINT)*AINT.GT.EPSD)THEN N1L=N1L+1 ELSEIF((XPL1(I)-XINT)*BINT-(YPL1(I)-YINT)*AINT.LT.-EPSD)THEN N1R=N1R+1 ENDIF MARK1(I)=.FALSE. 30 CONTINUE DO 40 I=1,NPL2 IF((XPL2(I)-XINT)*BINT-(YPL2(I)-YINT)*AINT.GT.EPSD)THEN N2L=N2L+1 ELSEIF((XPL2(I)-XINT)*BINT-(YPL2(I)-YINT)*AINT.LT.-EPSD)THEN N2R=N2R+1 ENDIF MARK2(I)=.FALSE. 40 CONTINUE IF((N1L.EQ.0.AND.N2R.EQ.0).OR.(N1R.EQ.0.AND.N2L.EQ.0))THEN KEEP=.TRUE. IFAIL=0 RETURN ELSE KEEP=.FALSE. ENDIF * Next parallel planes. ELSE IF((DPL1-APL1*XMEAN-BPL1*YMEAN)/CPL1.GE. - (DPL2-APL2*XMEAN-BPL2*YMEAN)/CPL2-EPSD)THEN KEEP=.TRUE. IFAIL=0 RETURN ELSE KEEP=.FALSE. ENDIF ENDIF *** Establish the list of special points around polygon 1. N1=0 NS=0 OK=.TRUE. DO 100 I=1,NPL1 * Add the vertex. IF(N1+1.GT.MXCORN)THEN PRINT *,' !!!!!! PLASPL WARNING : Too many special'// - ' points around a polygon ; list reduced.' OK=.FALSE. GOTO 150 ENDIF N1=N1+1 XL(N1,1)=XPL1(I) YL(N1,1)=YPL1(I) ZL(N1,1)=ZPL1(I) IT(N1,1)=1 Q(N1,1)=0 * If also on 2 or vertex of 2, flag it as crossing or foreign. DO 160 J=1,NPL2 IF(ABS(XPL2(J)-XPL1(I)).LT.EPSX.AND. - ABS(YPL2(J)-YPL1(I)).LT.EPSY)IT(N1,1)=2 IF(ONLIND(XPL2(1+MOD(J-1,NPL2)),YPL2(1+MOD(J-1,NPL2)), - XPL2(1+MOD(J ,NPL2)),YPL2(1+MOD(J ,NPL2)), - XPL1(I ),YPL1(I) ).AND. - (ABS(XPL2(1+MOD(J-1,NPL2))-XPL1(I)).GT.EPSX.OR. - ABS(YPL2(1+MOD(J-1,NPL2))-YPL1(I)).GT.EPSY).AND. - (ABS(XPL2(1+MOD(J ,NPL2))-XPL1(I)).GT.EPSX.OR. - ABS(YPL2(1+MOD(J ,NPL2))-YPL1(I)).GT.EPSY))IT(N1,1)=3 160 CONTINUE * Remember the starting point for the next list. M1=N1+1 * Preset HOLE to False, i.e. do look for intersect crossings. HOLE=.FALSE. * See whether this line segment crosses plane 2. C print *,' PLASPL case 1 call to PLALIN' CALL PLALIN(XPL1(1+MOD(I-1,NPL1)),YPL1(1+MOD(I-1,NPL1)), - ZPL1(1+MOD(I-1,NPL1)),XPL1(1+MOD(I ,NPL1)), - YPL1(1+MOD(I ,NPL1)),ZPL1(1+MOD(I ,NPL1)), - XPL2(1),YPL2(1),ZPL2(1),APL2,BPL2,CPL2,XC,YC,ZC,IFAIL1) IF(IFAIL1.EQ.0.AND. - (ABS(XPL1(1+MOD(I-1,NPL1))-XC).GT.EPSX.OR. - ABS(YPL1(1+MOD(I-1,NPL1))-YC).GT.EPSY).AND. - (ABS(XPL1(1+MOD(I ,NPL1))-XC).GT.EPSX.OR. - ABS(YPL1(1+MOD(I ,NPL1))-YC).GT.EPSY))THEN * Shouldn't be a located anywhere on the foreign curve. CALL INTERD(NPL2,XPL2,YPL2,XC,YC,INSIDE,EDGE) ADD=.NOT.EDGE * Add it to the list, if it remains. IF(ADD)THEN IF(N1+1.GT.MXCORN)THEN PRINT *,' !!!!!! PLASPL WARNING : Too many'// - ' points around a polygon ; list reduced.' OK=.FALSE. GOTO 150 ENDIF N1=N1+1 XL(N1,1)=XC YL(N1,1)=YC ZL(N1,1)=ZC IF(INSIDE)THEN IT(N1,1)=4 ELSE IT(N1,1)=5 ENDIF * If added, don't add the corners to the separation line. MARK1(1+MOD(I-1,NPL1))=.TRUE. MARK1(1+MOD(I ,NPL1))=.TRUE. * Seems to be a hole. HOLE=.TRUE. ENDIF * See whether the point is already in the separation list. DO 180 J=1,NS IF(ABS(XC-XL(J,3)).LT.EPSX.AND. - ABS(YC-YL(J,3)).LT.EPSY)ADD=.FALSE. 180 CONTINUE * Add this to the separation points, if not already in it. IF(ADD)THEN IF(NS+1.GT.MXCORN)THEN PRINT *,' !!!!!! PLASPL WARNING : Too many'// - ' points around a polygon ; list reduced.' OK=.FALSE. GOTO 150 ENDIF NS=NS+1 XL(NS,3)=XC YL(NS,3)=YC ZL(NS,3)=ZC IF(INSIDE.AND..NOT.EDGE)THEN IT(NS,3)=4 ELSE IT(NS,3)=5 ENDIF ENDIF ENDIF * Go over the line segments of the other polygon. DO 110 J=1,NPL2 * Add vertices of 2 that are on this line. IF(ONLIND(XPL1(1+MOD(I-1,NPL1)),YPL1(1+MOD(I-1,NPL1)), - XPL1(1+MOD(I,NPL1)),YPL1(1+MOD(I,NPL1)), - XPL2(J),YPL2(J)).AND. - (ABS(XPL1(1+MOD(I-1,NPL1))-XPL2(J)).GT.EPSX.OR. - ABS(YPL1(1+MOD(I-1,NPL1))-YPL2(J)).GT.EPSY).AND. - (ABS(XPL1(1+MOD(I ,NPL1))-XPL2(J)).GT.EPSX.OR. - ABS(YPL1(1+MOD(I ,NPL1))-YPL2(J)).GT.EPSY))THEN IF(N1+1.GT.MXCORN)THEN PRINT *,' !!!!!! PLASPL WARNING : Too many special'// - ' points around a polygon ; list reduced.' OK=.FALSE. GOTO 150 ENDIF N1=N1+1 XL(N1,1)=XPL2(J) YL(N1,1)=YPL2(J) ZL(N1,1)=(DPL1-APL1*XPL2(J)-BPL1*YPL2(J))/CPL1 IT(N1,1)=2 ENDIF * Add crossing points. CALL CRSPND( - XPL1(1+MOD(I-1,NPL1)),YPL1(1+MOD(I-1,NPL1)), - XPL1(1+MOD(I ,NPL1)),YPL1(1+MOD(I ,NPL1)), - XPL2(1+MOD(J-1,NPL2)),YPL2(1+MOD(J-1,NPL2)), - XPL2(1+MOD(J ,NPL2)),YPL2(1+MOD(J ,NPL2)), - XC,YC,ADD) IF(ADD)THEN IF((ABS(XPL1(1+MOD(I-1,NPL1))-XC).LT.EPSX.AND. - ABS(YPL1(1+MOD(I-1,NPL1))-YC).LT.EPSY).OR. - (ABS(XPL1(1+MOD(I ,NPL1))-XC).LT.EPSX.AND. - ABS(YPL1(1+MOD(I ,NPL1))-YC).LT.EPSY))ADD=.FALSE. IF((ABS(XPL2(1+MOD(J-1,NPL2))-XC).LT.EPSX.AND. - ABS(YPL2(1+MOD(J-1,NPL2))-YC).LT.EPSY).OR. - (ABS(XPL2(1+MOD(J ,NPL2))-XC).LT.EPSX.AND. - ABS(YPL2(1+MOD(J ,NPL2))-YC).LT.EPSY))ADD=.FALSE. IF((ABS(XPL1(1+MOD(I-1,NPL1))- - XPL2(1+MOD(J-1,NPL2))).LT.EPSX.AND. - ABS(YPL1(1+MOD(I-1,NPL1))- - YPL2(1+MOD(J-1,NPL2))).LT.EPSY).OR. - (ABS(XPL1(1+MOD(I-1,NPL1))- - XPL2(1+MOD(J ,NPL2))).LT.EPSX.AND. - ABS(YPL1(1+MOD(I-1,NPL1))- - YPL2(1+MOD(J ,NPL2))).LT.EPSY).OR. - (ABS(XPL1(1+MOD(I ,NPL1))- - XPL2(1+MOD(J-1,NPL2))).LT.EPSX.AND. - ABS(YPL1(1+MOD(I ,NPL1))- - YPL2(1+MOD(J-1,NPL2))).LT.EPSY).OR. - (ABS(XPL1(1+MOD(I-1,NPL1))- - XPL2(1+MOD(J-1,NPL2))).LT.EPSX.AND. - ABS(YPL1(1+MOD(I-1,NPL1))- - YPL2(1+MOD(J-1,NPL2))).LT.EPSY))ADD=.FALSE. ENDIF IF(ADD)THEN IF(N1+1.GT.MXCORN)THEN PRINT *,' !!!!!! PLASPL WARNING : Too many special'// - ' points around a polygon ; list reduced.' OK=.FALSE. GOTO 150 ENDIF N1=N1+1 XL(N1,1)=XC YL(N1,1)=YC ZL(N1,1)=(DPL1-APL1*XC-BPL1*YC)/CPL1 IT(N1,1)=3 ENDIF * Perhaps also add to the separation list. IF(ADD.AND.ONLIND(XSEPA,YSEPA,XSEPB,YSEPB,XC,YC))THEN IF(NS+1.GT.MXCORN)THEN PRINT *,' !!!!!! PLASPL WARNING : Too many special'// - ' points around a polygon ; list reduced.' OK=.FALSE. GOTO 150 ENDIF NS=NS+1 XL(NS,3)=XC YL(NS,3)=YC ZL(NS,3)=(DPL1-APL1*XC-BPL1*YC)/CPL1 IT(NS,3)=3 ENDIF 110 CONTINUE * See whether this segment crosses the separation line. IF(.NOT.HOLE)THEN CALL CRSPND( - XPL1(1+MOD(I-1,NPL1)),YPL1(1+MOD(I-1,NPL1)), - XPL1(1+MOD(I ,NPL1)),YPL1(1+MOD(I ,NPL1)), - XSEPA,YSEPA,XSEPB,YSEPB,XC,YC,ADD) IF(ADD)THEN IF((ABS(XPL1(1+MOD(I-1,NPL1))-XC).LT.EPSX.AND. - ABS(YPL1(1+MOD(I-1,NPL1))-YC).LT.EPSY).OR. - (ABS(XPL1(1+MOD(I ,NPL1))-XC).LT.EPSX.AND. - ABS(YPL1(1+MOD(I ,NPL1))-YC).LT.EPSY))ADD=.FALSE. ENDIF IF(ADD)THEN DO 195 J=1,NPL2 IF(ABS(XC-XPL2(J)).LT.EPSX.AND. - ABS(YC-YPL2(J)).LT.EPSY)ADD=.FALSE. 195 CONTINUE ENDIF IF(ADD)THEN ADD=.TRUE. DO 190 J=M1,N1 IF(ABS(XC-XL(J,1)).LT.EPSX.AND. - ABS(YC-YL(J,1)).LT.EPSY)ADD=.FALSE. 190 CONTINUE IF(ADD)THEN IF(N1+1.GT.MXCORN)THEN PRINT *,' !!!!!! PLASPL WARNING : Too many'// - ' special points around a polygon ;'// - ' list reduced.' OK=.FALSE. GOTO 150 ENDIF N1=N1+1 XL(N1,1)=XC YL(N1,1)=YC ZL(N1,1)=(DPL1-APL1*XC-BPL1*YC)/CPL1 IT(N1,1)=1 ENDIF ADD=.TRUE. DO 170 J=1,NS IF(ABS(XC-XL(J,3)).LT.EPSX.AND. - ABS(YC-YL(J,3)).LT.EPSY)ADD=.FALSE. 170 CONTINUE IF(ADD)THEN IF(NS+1.GT.MXCORN)THEN PRINT *,' !!!!!! PLASPL WARNING : Too many'// - ' special points around a polygon ;'// - ' list reduced.' OK=.FALSE. GOTO 150 ENDIF NS=NS+1 XL(NS,3)=XC YL(NS,3)=YC ZL(NS,3)=(DPL1-APL1*XC-BPL1*YC)/CPL1 IT(NS,3)=1 ENDIF ENDIF ENDIF * Compute the lambda's for these points. DO 120 J=M1,N1 CALL PLALAM(XPL1(1+MOD(I-1,NPL1)),XL(J,1),XPL1(1+MOD(I,NPL1)), - YPL1(1+MOD(I-1,NPL1)),YL(J,1),YPL1(1+MOD(I,NPL1)),Q(J,1)) C if(q(j,1).gt.1.5.and.lgstop)then C print *,' Case 1' C do k=1,npl1 C print *,' 1: ',xpl1(k),ypl1(k),zpl1(k) C enddo C print *,' ' C do k=1,npl2 C print *,' 2: ',xpl2(k),ypl2(k),zpl2(k) C enddo C endif 120 CONTINUE * Sort the list by using the lambda's. DO 140 J=M1,N1 QMIN=Q(J,1) IQMIN=J DO 130 K=J+1,N1 IF(Q(K,1).LT.QMIN)THEN IQMIN=K QMIN=Q(K,1) ENDIF 130 CONTINUE IF(J.NE.IQMIN)THEN XAUX=XL(J,1) YAUX=YL(J,1) ZAUX=ZL(J,1) QAUX=Q (J,1) IAUX=IT(J,1) XL(J,1)=XL(IQMIN,1) YL(J,1)=YL(IQMIN,1) ZL(J,1)=ZL(IQMIN,1) Q (J,1)=Q (IQMIN,1) IT(J,1)=IT(IQMIN,1) XL(IQMIN,1)=XAUX YL(IQMIN,1)=YAUX ZL(IQMIN,1)=ZAUX Q (IQMIN,1)=QAUX IT(IQMIN,1)=IAUX ENDIF 140 CONTINUE * Next vertex. 100 CONTINUE *** Establish the list of special points around polygon 2. 150 CONTINUE N2=0 DO 200 I=1,NPL2 * Add the vertex. IF(N2+1.GT.MXCORN)THEN PRINT *,' !!!!!! PLASPL WARNING : Too many special'// - ' points around a polygon ; list reduced.' OK=.FALSE. GOTO 250 ENDIF N2=N2+1 XL(N2,2)=XPL2(I) YL(N2,2)=YPL2(I) ZL(N2,2)=ZPL2(I) IT(N2,2)=1 Q(N2,2)=0 * If also on 1 or a vertex of 1, flag it as crossing or foreign. DO 260 J=1,NPL1 IF(ABS(XPL1(J)-XPL2(I)).LT.EPSX.AND. - ABS(YPL1(J)-YPL2(I)).LT.EPSY)IT(N2,2)=2 IF(ONLIND(XPL1(1+MOD(J-1,NPL1)),YPL1(1+MOD(J-1,NPL1)), - XPL1(1+MOD(J ,NPL1)),YPL1(1+MOD(J ,NPL1)), - XPL2(I ),YPL2(I) ).AND. - (ABS(XPL1(1+MOD(J-1,NPL1))-XPL2(I)).GT.EPSX.OR. - ABS(YPL1(1+MOD(J-1,NPL1))-YPL2(I)).GT.EPSY).AND. - (ABS(XPL1(1+MOD(J ,NPL1))-XPL2(I)).GT.EPSX.OR. - ABS(YPL1(1+MOD(J ,NPL1))-YPL2(I)).GT.EPSY))IT(N2,2)=3 260 CONTINUE * Remember the starting point for the next list. M2=N2+1 * See whether this line segment crosses plane 1. C print *,' PLASPL case 2 call to PLALIN' CALL PLALIN(XPL2(1+MOD(I-1,NPL2)),YPL2(1+MOD(I-1,NPL2)), - ZPL2(1+MOD(I-1,NPL2)),XPL2(1+MOD(I ,NPL2)), - YPL2(1+MOD(I ,NPL2)),ZPL2(1+MOD(I ,NPL2)), - XPL1(1),YPL1(1),ZPL1(1),APL1,BPL1,CPL1,XC,YC,ZC,IFAIL1) IF(IFAIL1.EQ.0.AND. - (ABS(XPL2(1+MOD(I-1,NPL2))-XC).GT.EPSX.OR. - ABS(YPL2(1+MOD(I-1,NPL2))-YC).GT.EPSY).AND. - (ABS(XPL2(1+MOD(I ,NPL2))-XC).GT.EPSX.OR. - ABS(YPL2(1+MOD(I ,NPL2))-YC).GT.EPSY))THEN * Shouldn't be a located anywhere on the foreign curve. CALL INTERD(NPL1,XPL1,YPL1,XC,YC,INSIDE,EDGE) ADD=.NOT.EDGE * Add this point to the list if not a vertex. IF(ADD)THEN IF(N2+1.GT.MXCORN)THEN PRINT *,' !!!!!! PLASPL WARNING : Too many'// - ' points around a polygon ; list reduced.' OK=.FALSE. GOTO 250 ENDIF N2=N2+1 XL(N2,2)=XC YL(N2,2)=YC ZL(N2,2)=ZC IF(INSIDE)THEN IT(N2,2)=4 ELSE IT(N2,2)=5 ENDIF * If added, don't add the corners to the separation line. MARK2(1+MOD(I-1,NPL2))=.TRUE. MARK2(1+MOD(I ,NPL2))=.TRUE. ENDIF * See whether the point is already in the separation list. DO 280 J=1,NS IF(ABS(XC-XL(J,3)).LT.EPSX.AND. - ABS(YC-YL(J,3)).LT.EPSY)ADD=.FALSE. 280 CONTINUE * Add this to the separation points, if not already in it. IF(ADD)THEN IF(NS+1.GT.MXCORN)THEN PRINT *,' !!!!!! PLASPL WARNING : Too many'// - ' points around a polygon ; list reduced.' OK=.FALSE. GOTO 250 ENDIF NS=NS+1 XL(NS,3)=XC YL(NS,3)=YC ZL(NS,3)=ZC IF(INSIDE)THEN IT(NS,3)=4 ELSE IT(NS,3)=5 ENDIF ENDIF ENDIF * Go over the line segments of the other polygon. DO 210 J=1,NPL1 * Add vertices of 1 that are on this line. IF(ONLIND(XPL2(1+MOD(I-1,NPL2)),YPL2(1+MOD(I-1,NPL2)), - XPL2(1+MOD(I,NPL2)),YPL2(1+MOD(I,NPL2)), - XPL1(J),YPL1(J)).AND. - (ABS(XPL2(1+MOD(I-1,NPL2))-XPL1(J)).GT.EPSX.OR. - ABS(YPL2(1+MOD(I-1,NPL2))-YPL1(J)).GT.EPSY).AND. - (ABS(XPL2(1+MOD(I ,NPL2))-XPL1(J)).GT.EPSX.OR. - ABS(YPL2(1+MOD(I ,NPL2))-YPL1(J)).GT.EPSY))THEN IF(N2+1.GT.MXCORN)THEN PRINT *,' !!!!!! PLASPL WARNING : Too many special'// - ' points around a polygon ; list reduced.' OK=.FALSE. GOTO 250 ENDIF N2=N2+1 XL(N2,2)=XPL1(J) YL(N2,2)=YPL1(J) ZL(N2,2)=(DPL2-APL2*XPL1(J)-BPL2*YPL1(J))/CPL2 IT(N2,2)=2 ENDIF * Add crossing points. CALL CRSPND( - XPL2(1+MOD(I-1,NPL2)),YPL2(1+MOD(I-1,NPL2)), - XPL2(1+MOD(I ,NPL2)),YPL2(1+MOD(I ,NPL2)), - XPL1(1+MOD(J-1,NPL1)),YPL1(1+MOD(J-1,NPL1)), - XPL1(1+MOD(J ,NPL1)),YPL1(1+MOD(J ,NPL1)), - XC,YC,ADD) IF(ADD)THEN IF((ABS(XPL2(1+MOD(I-1,NPL2))-XC).LT.EPSX.AND. - ABS(YPL2(1+MOD(I-1,NPL2))-YC).LT.EPSY).OR. - (ABS(XPL2(1+MOD(I,NPL2))-XC).LT.EPSX.AND. - ABS(YPL2(1+MOD(I,NPL2))-YC).LT.EPSY))ADD=.FALSE. IF((ABS(XPL1(1+MOD(J-1,NPL1))-XC).LT.EPSX.AND. - ABS(YPL1(1+MOD(J-1,NPL1))-YC).LT.EPSY).OR. - (ABS(XPL1(1+MOD(J,NPL1))-XC).LT.EPSX.AND. - ABS(YPL1(1+MOD(J,NPL1))-YC).LT.EPSY))ADD=.FALSE. IF((ABS(XPL1(1+MOD(J-1,NPL1))- - XPL2(1+MOD(I-1,NPL2))).LT.EPSX.AND. - ABS(YPL1(1+MOD(J-1,NPL1))- - YPL2(1+MOD(I-1,NPL2))).LT.EPSY).OR. - (ABS(XPL1(1+MOD(J-1,NPL1))- - XPL2(1+MOD(I ,NPL2))).LT.EPSX.AND. - ABS(YPL1(1+MOD(J-1,NPL1))- - YPL2(1+MOD(I ,NPL2))).LT.EPSY).OR. - (ABS(XPL1(1+MOD(J ,NPL1))- - XPL2(1+MOD(I-1,NPL2))).LT.EPSX.AND. - ABS(YPL1(1+MOD(J ,NPL1))- - YPL2(1+MOD(I-1,NPL2))).LT.EPSY).OR. - (ABS(XPL1(1+MOD(J-1,NPL1))- - XPL2(1+MOD(I-1,NPL2))).LT.EPSX.AND. - ABS(YPL1(1+MOD(J-1,NPL1))- - YPL2(1+MOD(I-1,NPL2))).LT.EPSY))ADD=.FALSE. ENDIF IF(ADD)THEN IF(N2+1.GT.MXCORN)THEN PRINT *,' !!!!!! PLASPL WARNING : Too many special'// - ' points around a polygon ; list reduced.' OK=.FALSE. GOTO 250 ENDIF N2=N2+1 XL(N2,2)=XC YL(N2,2)=YC ZL(N2,2)=(DPL2-APL2*XC-BPL2*YC)/CPL2 IT(N2,2)=3 ENDIF 210 CONTINUE * Compute the lambda's for these points. DO 220 J=M2,N2 CALL PLALAM(XPL2(1+MOD(I-1,NPL2)),XL(J,2),XPL2(1+MOD(I,NPL2)), - YPL2(1+MOD(I-1,NPL2)),YL(J,2),YPL2(1+MOD(I,NPL2)),Q(J,2)) C if(q(j,2).gt.1.5.and.lgstop)then C print *,' Case 2' C do k=1,npl1 C print *,' 1: ',xpl1(k),ypl1(k),zpl1(k) C enddo C print *,' ' C do k=1,npl2 C print *,' 2: ',xpl2(k),ypl2(k),zpl2(k) C enddo C endif 220 CONTINUE * Sort the list by using the lambda's. DO 240 J=M2,N2 QMIN=Q(J,2) IQMIN=J DO 230 K=J+1,N2 IF(Q(K,2).LT.QMIN)THEN IQMIN=K QMIN=Q(K,2) ENDIF 230 CONTINUE IF(J.NE.IQMIN)THEN XAUX=XL(J,2) YAUX=YL(J,2) ZAUX=ZL(J,2) QAUX=Q (J,2) IAUX=IT(J,2) XL(J,2)=XL(IQMIN,2) YL(J,2)=YL(IQMIN,2) ZL(J,2)=ZL(IQMIN,2) Q (J,2)=Q (IQMIN,2) IT(J,2)=IT(IQMIN,2) XL(IQMIN,2)=XAUX YL(IQMIN,2)=YAUX ZL(IQMIN,2)=ZAUX Q (IQMIN,2)=QAUX IT(IQMIN,2)=IAUX ENDIF 240 CONTINUE * Next vertex. 200 CONTINUE *** Establish the list of special points along the separation line. 250 CONTINUE * Add the vertices of plane 1 that are on the separation line. DO 300 I=1,NPL1 IF(.NOT.MARK1(I).AND. - ONLIND(XSEPA,YSEPA,XSEPB,YSEPB,XPL1(I),YPL1(I)))THEN IF(NS+1.GT.MXCORN)THEN PRINT *,' !!!!!! PLASPL WARNING : Too many special'// - ' points along separation ; list reduced.' OK=.FALSE. GOTO 350 ENDIF NS=NS+1 XL(NS,3)=XPL1(I) YL(NS,3)=YPL1(I) ZL(NS,3)=ZPL1(I) IT(NS,3)=1 ENDIF 300 CONTINUE * Add the vertices of plane 2 which are not also vertices of 1. DO 310 I=1,NPL2 DO 360 J=1,NPL1 IF(ABS(XPL2(I)-XPL1(J)).LT.EPSX.AND. - ABS(YPL2(I)-YPL1(J)).LT.EPSY)GOTO 310 360 CONTINUE IF(.NOT.MARK2(I).AND. - ONLIND(XSEPA,YSEPA,XSEPB,YSEPB,XPL2(I),YPL2(I)))THEN IF(NS+1.GT.MXCORN)THEN PRINT *,' !!!!!! PLASPL WARNING : Too many special'// - ' points along separation ; list reduced.' OK=.FALSE. GOTO 350 ENDIF NS=NS+1 XL(NS,3)=XPL2(I) YL(NS,3)=YPL2(I) ZL(NS,3)=ZPL2(I) CALL INTERD(NPL1,XPL1,YPL1,XPL2(I),YPL2(I),INSIDE,EDGE) IF(EDGE)THEN IT(NS,3)=1 ELSE IT(NS,3)=2 ENDIF ENDIF 310 CONTINUE * Compute the lambda's for these points. DO 320 I=1,NS CALL PLALAM(XSEPA,XL(I,3),XSEPB,YSEPA,YL(I,3),YSEPB,Q(I,3)) if(q(i,3).gt.1.5.and.lgstop)then print *,' Case 3' do k=1,npl1 print *,' 1: ',xpl1(k),ypl1(k),zpl1(k) enddo print *,' ' do k=1,npl2 print *,' 2: ',xpl2(k),ypl2(k),zpl2(k) enddo print *,' List of special points:' do k=1,ns print *,xl(k,3),yl(k,3) enddo print *,' Epsilons:' print *,epsx,epsy,epsz endif 320 CONTINUE * Sort the list by using the lambda's. DO 340 J=1,NS QMIN=Q(J,3) IQMIN=J DO 330 K=J+1,NS IF(Q(K,3).LT.QMIN)THEN IQMIN=K QMIN=Q(K,3) ENDIF 330 CONTINUE IF(J.NE.IQMIN)THEN XAUX=XL(J,3) YAUX=YL(J,3) ZAUX=ZL(J,3) QAUX=Q (J,3) IAUX=IT(J,3) XL(J,3)=XL(IQMIN,3) YL(J,3)=YL(IQMIN,3) ZL(J,3)=ZL(IQMIN,3) Q (J,3)=Q (IQMIN,3) IT(J,3)=IT(IQMIN,3) XL(IQMIN,3)=XAUX YL(IQMIN,3)=YAUX ZL(IQMIN,3)=ZAUX Q (IQMIN,3)=QAUX IT(IQMIN,3)=IAUX ENDIF 340 CONTINUE *** Look up the cross-links. 350 CONTINUE ** Links from plane 1 to plane 2. DO 500 I=1,N1 IREF(I,1,1)=I NFOUND=0 IREF(I,1,2)=0 DO 510 J=1,N2 IF(ABS(XL(I,1)-XL(J,2)).LT.EPSX.AND. - ABS(YL(I,1)-YL(J,2)).LT.EPSY)THEN NFOUND=NFOUND+1 IREF(I,1,2)=J ENDIF 510 CONTINUE IF(NFOUND.EQ.0.AND.(IT(I,1).EQ.2.OR.IT(I,1).EQ.3))THEN PRINT *,' !!!!!! PLASPL WARNING : Expected match not'// - ' found (1-2)' OK=.FALSE. IREF(I,1,2)=0 ELSEIF(NFOUND.GT.1)THEN PRINT *,' !!!!!! PLASPL WARNING : More than 1 match'// - ' found (1-2).' OK=.FALSE. IREF(I,1,2)=0 ENDIF * Links from plane 1 to the separation line. NFOUND=0 IREF(I,1,3)=0 DO 530 J=1,NS IF(ABS(XL(I,1)-XL(J,3)).LT.EPSX.AND. - ABS(YL(I,1)-YL(J,3)).LT.EPSY)THEN NFOUND=NFOUND+1 IREF(I,1,3)=J ENDIF 530 CONTINUE IF(NFOUND.EQ.0.AND.(IT(I,1).EQ.4.OR.IT(I,1).EQ.5))THEN PRINT *,' !!!!!! PLASPL WARNING : Expected match not'// - ' found (1-S).' OK=.FALSE. IREF(I,1,3)=0 ELSEIF(NFOUND.GT.1)THEN PRINT *,' !!!!!! PLASPL WARNING : More than 1 match'// - ' found (1-S).' OK=.FALSE. IREF(I,1,3)=0 ENDIF 500 CONTINUE ** Links from plane 2 to plane 1. DO 540 I=1,N2 IREF(I,2,2)=I NFOUND=0 IREF(I,2,1)=0 DO 550 J=1,N1 IF(ABS(XL(I,2)-XL(J,1)).LT.EPSX.AND. - ABS(YL(I,2)-YL(J,1)).LT.EPSY)THEN NFOUND=NFOUND+1 IREF(I,2,1)=J ENDIF 550 CONTINUE IF(NFOUND.EQ.0.AND.(IT(I,2).EQ.2.OR.IT(I,2).EQ.3))THEN PRINT *,' !!!!!! PLASPL WARNING : Expected match not'// - ' found (2-1).' OK=.FALSE. IREF(I,2,1)=0 ELSEIF(NFOUND.GT.1)THEN PRINT *,' !!!!!! PLASPL WARNING : More than 1 match'// - ' found (2-1).' OK=.FALSE. IREF(I,2,1)=0 ENDIF * Links from plane 2 to the separation line. NFOUND=0 IREF(I,2,3)=0 DO 560 J=1,NS IF(ABS(XL(I,2)-XL(J,3)).LT.EPSX.AND. - ABS(YL(I,2)-YL(J,3)).LT.EPSY)THEN NFOUND=NFOUND+1 IREF(I,2,3)=J ENDIF 560 CONTINUE IF(NFOUND.EQ.0.AND.(IT(I,2).EQ.4.OR.IT(I,2).EQ.5))THEN PRINT *,' !!!!!! PLASPL WARNING : Expected match not'// - ' found (2-S).' OK=.FALSE. IREF(I,2,3)=0 ELSEIF(NFOUND.GT.1)THEN PRINT *,' !!!!!! PLASPL WARNING : More than 1 match'// - ' found (2-S).' OK=.FALSE. IREF(I,2,3)=0 ENDIF 540 CONTINUE ** Links from the separation line to planes 1 and 2. DO 570 I=1,NS IREF(I,3,3)=I NFOUN1=0 IREF(I,3,1)=0 DO 580 J=1,N1 IF(ABS(XL(I,3)-XL(J,1)).LT.EPSX.AND. - ABS(YL(I,3)-YL(J,1)).LT.EPSY)THEN NFOUN1=NFOUN1+1 IREF(I,3,1)=J ENDIF 580 CONTINUE IREF(I,3,2)=0 NFOUN2=0 DO 590 J=1,N2 IF(ABS(XL(I,3)-XL(J,2)).LT.EPSX.AND. - ABS(YL(I,3)-YL(J,2)).LT.EPSY)THEN NFOUN2=NFOUN2+1 IREF(I,3,2)=J ENDIF 590 CONTINUE IF(NFOUN1.EQ.0.AND.NFOUN2.EQ.0)THEN PRINT *,' !!!!!! PLASPL WARNING : Expected match not'// - ' found (S-1,2).' OK=.FALSE. IREF(I,3,1)=0 IREF(I,3,2)=0 ELSEIF(NFOUN1.GT.1.OR.NFOUN2.GT.1)THEN PRINT *,' !!!!!! PLASPL WARNING : More than 1 match'// - ' found (S-1,2).' OK=.FALSE. IREF(I,3,1)=0 IREF(I,3,2)=0 ENDIF 570 CONTINUE * List the points for debugging. IF(LDEBUG)THEN DO 610 J=1,3 WRITE(LUNOUT,'('' ++++++ PLASPL DEBUG : Polygon '',I1, - '':''/'' No Type x y'', - '' z Q links'')') J CALL GSMK(2) IF(J.EQ.1)THEN NP=N1 CALL GSMK(2) ELSEIF(J.EQ.2)THEN NP=N2 CALL GSMK(4) ELSEIF(J.EQ.3)THEN NP=NS CALL GSMK(5) ENDIF DO 600 I=1,NP WRITE(LUNOUT,'(2X,I3,I5,3F13.6,F10.3,3I3)') I,IT(I,J), - XL(I,J),YL(I,J),ZL(I,J),Q(I,J),(IREF(I,J,K),K=1,3) CALL GPM2(1,XL(I,J),YL(I,J)) 600 CONTINUE C call testtest(np,xl(1,J),yl(1,j),zl(1,j)) 610 CONTINUE ENDIF *** If a mistake was found, simply draw the curve. IF(.NOT.OK)THEN PRINT *,' !!!!!! PLASPL WARNING : No further processing'// - ' because of the above errors ; please report.' LGSIG=.TRUE. DO 2020 I=1,NREF CALL PLABU2('DELETE',IREFO(I),NPL1,XPL1,YPL1,ZPL1, - APL1,BPL1,CPL1,DPL1,ICOL1,IFAIL1) 2020 CONTINUE NREF=0 IFAIL=1 KEEP=.TRUE. RETURN ENDIF *** Draw the visible part of 1, first locate visible points. DO 400 I=1,N1 IF(IREF(I,1,3).NE.0)THEN MARK1(I)=.TRUE. ELSEIF(IT(I,1).EQ.1)THEN CALL INTERD(NPL2,XPL2,YPL2,XL(I,1),YL(I,1),INSIDE,EDGE) IF(INSIDE.OR.EDGE)THEN IF((DPL1-APL1*XL(I,1)-BPL1*YL(I,1))/CPL1.GE. - (DPL2-APL2*XL(I,1)-BPL2*YL(I,1))/CPL2)THEN MARK1(I)=.FALSE. ELSE MARK1(I)=.TRUE. ENDIF ELSE MARK1(I)=.FALSE. ENDIF ELSE MARK1(I)=.FALSE. ENDIF 400 CONTINUE *** Resume from here for the next piece of curve. 410 CONTINUE *** Find a point that still hasn't been marked. DO 420 I=1,N1 * Skip points that are marked. C if(MARK1(i))print *,' Search skips point ',i,' (marked)' IF(MARK1(I))GOTO 420 * Set reference variables. IP=I IL=1 * See which side of the surve is visible. CALL INTERD(NPL2,XPL2,YPL2, - 0.5*(XL(IP,IL)+XL(1+MOD(IP,N1),IL)), - 0.5*(YL(IP,IL)+YL(1+MOD(IP,N1),IL)),IN1,EDGE1) ZAUX1=(DPL1- - APL1*0.5*(XL(IP,IL)+XL(1+MOD(IP,N1),IL))- - BPL1*0.5*(YL(IP,IL)+YL(1+MOD(IP,N1),IL)))/CPL1 ZAUX2=(DPL2- - APL2*0.5*(XL(IP,IL)+XL(1+MOD(IP,N1),IL))- - BPL2*0.5*(YL(IP,IL)+YL(1+MOD(IP,N1),IL)))/CPL2 CALL INTERD(NPL2,XPL2,YPL2, - 0.5*(XL(IP,IL)+XL(1+MOD(IP-2+N1,N1),IL)), - 0.5*(YL(IP,IL)+YL(1+MOD(IP-2+N1,N1),IL)),IN2,EDGE2) ZAUX3=(DPL1- - APL1*0.5*(XL(IP,IL)+XL(1+MOD(IP-2+N1,N1),IL))- - BPL1*0.5*(YL(IP,IL)+YL(1+MOD(IP-2+N1,N1),IL)))/CPL1 ZAUX4=(DPL2- - APL2*0.5*(XL(IP,IL)+XL(1+MOD(IP-2+N1,N1),IL))- - BPL2*0.5*(YL(IP,IL)+YL(1+MOD(IP-2+N1,N1),IL)))/CPL2 * Find the direction in which to move. IF(.NOT.(IN1.OR.EDGE1))THEN IDIR=+1 ELSEIF(.NOT.(IN2.OR.EDGE2))THEN IDIR=-1 ELSEIF(ZAUX1.GT.ZAUX2+EPSD)THEN IDIR=+1 ELSEIF(ZAUX3.GT.ZAUX4+EPSD)THEN IDIR=-1 ELSE C print *,' Search skips point ',i,' (no visible way out)' MARK1(I)=.TRUE. GOTO 410 ENDIF * Leave the loop, we found a point. GOTO 440 420 CONTINUE *** No point found anymore, continue with the cut-outs. GOTO 1000 *** Initial settings for the curve. 440 CONTINUE INITP=IP INITD=IDIR INITL=IL XPL(1)=XL(IP,1) YPL(1)=YL(IP,1) ZPL(1)=ZL(IP,1) MARK1(IP)=.TRUE. IP=1+MOD(IP+IDIR-1+N1,N1) NPL=1 START=.TRUE. IF(LDEBUG)WRITE(LUNOUT,'('' Starting from list '',I3, - '' point '',I3,'' direction '',I2)') INITL,INITP,INITD ** Make a step along the edges. 430 CONTINUE IF(IL.EQ.1.AND.IDIR.NE.INITD)THEN PRINT *,' !!!!!! PLASPL WARNING : Change in direction on'// - ' main curve ; abandoned.' DO 2040 I=1,NREF CALL PLABU2('DELETE',IREFO(I),NPL1,XPL1,YPL1,ZPL1, - APL1,BPL1,CPL1,DPL1,ICOL1,IFAIL1) 2040 CONTINUE NREF=0 KEEP=.TRUE. IFAIL=1 LGSIG=.TRUE. RETURN ENDIF *** See whether we are back where we started. IF((.NOT.START).AND. - ABS(XL(IP,IL)-XL(INITP,INITL)).LT.EPSX.AND. - ABS(YL(IP,IL)-YL(INITP,INITL)).LT.EPSY)THEN * Store the plane. IF(NREF+1.LE.MXPLAN)THEN CALL PLARED(NPL,XPL,YPL,ZPL,APL1,BPL1,CPL1,DPL1) IF(NPL.GE.3)THEN NREF=NREF+1 CALL PLABU2('STORE',IREFO(NREF),NPL,XPL,YPL,ZPL, - APL1,BPL1,CPL1,DPL1,ICOL1,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! PLASPL WARNING : Unable'// - ' to store a plane ; plot probably'// - ' incomplete.' NREF=NREF-1 ENDIF ENDIF ELSE PRINT *,' !!!!!! PLASPL WARNING : Unable to store'// - ' a plane ; plot probably incomplete.' ENDIF * And resume search. GOTO 410 ENDIF *** Now we have really started. START=.FALSE. * Mark the current point if we're in plane 1. IF(IREF(IP,IL,1).NE.0)MARK1(IREF(IP,IL,1))=.TRUE. * Set the number of points in the current list. IF(IL.EQ.1)THEN NP=N1 ELSEIF(IL.EQ.2)THEN NP=N2 ELSE NP=NS ENDIF * Add this point to the list if there still is room. IF(NPL+1.GT.MXEDGE)THEN PRINT *,' !!!!!! PLASPL WARNING : Curve exceeds maximum'// - ' length ; truncated.' LGSIG=.TRUE. DO 2010 I=1,NREF CALL PLABU2('DELETE',IREFO(I),NPL1,XPL1,YPL1,ZPL1, - APL1,BPL1,CPL1,DPL1,ICOL1,IFAIL1) 2010 CONTINUE NREF=0 KEEP=.TRUE. IFAIL=1 RETURN ENDIF IF(NPL.GE.2)THEN IF(.NOT.ONLIND(XPL(NPL-1),YPL(NPL-1),XL(IP,IL),YL(IP,IL), - XPL(NPL),YPL(NPL)))NPL=NPL+1 ELSE NPL=NPL+1 ENDIF XPL(NPL)=XL(IP,IL) YPL(NPL)=YL(IP,IL) ZPL(NPL)=(DPL1-APL1*XL(IP,IL)-BPL1*YL(IP,IL))/CPL1 ** In debugging mode, print where we are now. IF(LDEBUG)WRITE(LUNOUT,'('' Currently at list '',I3, - '' point '',I3,'' direction '',I2,'' type '',I1)') - IL,IP,IDIR,IT(IP,IL) ** If a private vertex, simply move on. IF(IT(IP,IL).EQ.1.AND.IL.NE.3)THEN IF(LDEBUG)WRITE(LUNOUT,'('' Own vertex.'')') IP=1+MOD(IP+IDIR-1+NP,NP) GOTO 430 ** If this is a triple intersect. ELSEIF(IREF(IP,IL,1).NE.0.AND.IREF(IP,IL,2).NE.0.AND. - IREF(IP,IL,3).NE.0)THEN IF(LDEBUG)WRITE(LUNOUT,'('' Triple intersect, list 1: '', - I3,'', list 2: '',I3,'' list 3: '',I3)') - IREF(IP,IL,1),IREF(IP,IL,2),IREF(IP,IL,3) * Step size check, also used for side determination. STEP=SQRT( - (XL(1+MOD(IP-IDIR-1+NP,NP),IL)-XL(IP,IL))**2+ - (YL(1+MOD(IP-IDIR-1+NP,NP),IL)-YL(IP,IL))**2) IF(STEP.LE.0.OR. - (IL.EQ.3.AND.IP.EQ. 1.AND.IDIR.EQ.+1).OR. - (IL.EQ.3.AND.IP.EQ.NP.AND.IDIR.EQ.-1))THEN PRINT *,' !!!!!! PLASPL WARNING : Not a valid'// - ' step into crossing ; skipped.' LGSIG=.TRUE. IP=1+MOD(IP+IDIR-1+NP,NP) GOTO 1200 ENDIF * Compute the incidence angle. PHI0=ATAN2( - YL(1+MOD(IP-IDIR-1+NP,NP),IL)-YL(IP,IL), - XL(1+MOD(IP-IDIR-1+NP,NP),IL)-XL(IP,IL)) * See on which side of this line we enter into 1. X1= (XL(1+MOD(IP-IDIR-1+NP,NP),IL)+XL(IP,IL))/2 Y1= (YL(1+MOD(IP-IDIR-1+NP,NP),IL)+YL(IP,IL))/2 DO 1210 K=3,10 DX=-(YL(1+MOD(IP-IDIR-1+NP,NP),IL)-YL(IP,IL))* - (2**K)*SQRT(EPSX**2+EPSY**2)/STEP DY=+(XL(1+MOD(IP-IDIR-1+NP,NP),IL)-XL(IP,IL))* - (2**K)*SQRT(EPSX**2+EPSY**2)/STEP CALL INTERD(NPL1,XPL1,YPL1,X1+DX,Y1+DY,IN1,EDGE1) CALL INTERD(NPL1,XPL1,YPL1,X1-DX,Y1-DY,IN2,EDGE2) IF((IN1.OR.IN2).AND..NOT.(EDGE1.OR.EDGE2))THEN CALL INTERD(NPL2,XPL2,YPL2,X1+DX,Y1+DY,IN3,EDGE3) ZAUX1=(DPL1-APL1*(X1+DX)-BPL1*(Y1+DY))/CPL1 ZAUX2=(DPL2-APL2*(X1+DX)-BPL2*(Y1+DY))/CPL2 CALL INTERD(NPL2,XPL2,YPL2,X1-DX,Y1-DY,IN4,EDGE4) ZAUX3=(DPL1-APL1*(X1-DX)-BPL1*(Y1-DY))/CPL1 ZAUX4=(DPL2-APL2*(X1-DX)-BPL2*(Y1-DY))/CPL2 IF(IN1.AND.(.NOT.(IN3.OR.EDGE3).OR. - ZAUX1.GT.ZAUX2-EPSD))THEN ISIDE0=+1 ELSEIF(IN2.AND.(.NOT.(IN4.OR.EDGE4).OR. - ZAUX3.GT.ZAUX4-EPSD))THEN ISIDE0=-1 ELSE PRINT *,' !!!!!! PLASPL WARNING : Line does'// - ' not seem to follow a visible part of'// - ' plane 1 ; skipped.' DO 2030 I=1,NREF CALL PLABU2('DELETE',IREFO(I), - NPL1,XPL1,YPL1,ZPL1,APL1,BPL1,CPL1,DPL1, - ICOL1,IFAIL1) 2030 CONTINUE NREF=0 IFAIL=1 KEEP=.TRUE. ENDIF GOTO 1220 ENDIF 1210 CONTINUE PRINT *,' !!!!!! PLASPL WARNING : Line doesn''t seem'// - ' to follow plane 1 ; abandoning overlap test.' LGSIG=.TRUE. DO 2000 I=1,NREF CALL PLABU2('DELETE',IREFO(I),NPL1,XPL1,YPL1,ZPL1, - APL1,BPL1,CPL1,DPL1,ICOL1,IFAIL1) 2000 CONTINUE NREF=0 KEEP=.TRUE. IFAIL=0 RETURN 1220 CONTINUE * Check each branch for angle and 1-side, start with plane 1-. JP=IREF(IP,IL,1) * Compute the incidence angle. PHI1=MOD(ATAN2( - YL(1+MOD(JP-2+N1,N1),1)-YL(IP,IL), - XL(1+MOD(JP-2+N1,N1),1)-XL(IP,IL))-PHI0,2.0D0*PI) IF(PHI1.LT.-PI)PHI1=PHI1+2.0D0*PI IF(PHI1.GT.+PI)PHI1=PHI1-2.0D0*PI IF(ISIDE0.EQ.+1.AND.PHI1.LT.0)PHI1=PHI1+2.0D0*PI IF(ISIDE0.EQ.-1.AND.PHI1.GT.0)PHI1=PHI1-2.0D0*PI * See on which side of this line we enter visibly into 1. X1= (XL(1+MOD(JP-2+N1,N1),1)+XL(IP,IL))/2 Y1= (YL(1+MOD(JP-2+N1,N1),1)+YL(IP,IL))/2 STEP=SQRT( - (XL(1+MOD(JP-2+N1,N1),1)-XL(IP,IL))**2+ - (YL(1+MOD(JP-2+N1,N1),1)-YL(IP,IL))**2) DO 1230 K=3,10 DX=-(YL(1+MOD(JP-2+N1,N1),1)-YL(IP,IL))* - (2**K)*SQRT(EPSX**2+EPSY**2)/STEP DY=+(XL(1+MOD(JP-2+N1,N1),1)-XL(IP,IL))* - (2**K)*SQRT(EPSX**2+EPSY**2)/STEP CALL INTERD(NPL1,XPL1,YPL1,X1+DX,Y1+DY,IN1,EDGE1) CALL INTERD(NPL1,XPL1,YPL1,X1-DX,Y1-DY,IN2,EDGE2) CALL INTERD(NPL2,XPL2,YPL2,X1+DX,Y1+DY,IN3,EDGE3) CALL INTERD(NPL2,XPL2,YPL2,X1-DX,Y1-DY,IN4,EDGE4) IF(IN1.AND..NOT.(EDGE1.OR.IN2.OR.EDGE2))THEN ZAUX1=(DPL1-APL1*(X1+DX)-BPL1*(Y1+DY))/CPL1 ZAUX2=(DPL2-APL2*(X1+DX)-BPL2*(Y1+DY))/CPL2 IF(.NOT.(IN3.OR.EDGE3).OR.ZAUX1.GT.ZAUX2-EPSD)THEN ISIDE1=+1 ELSE ISIDE1=0 ENDIF GOTO 1240 ELSEIF(IN2.AND..NOT.(EDGE2.OR.IN1.OR.EDGE1))THEN ZAUX1=(DPL1-APL1*(X1-DX)-BPL1*(Y1-DY))/CPL1 ZAUX2=(DPL2-APL2*(X1-DX)-BPL2*(Y1-DY))/CPL2 IF(.NOT.(IN4.OR.EDGE4).OR.ZAUX1.GT.ZAUX2-EPSD)THEN ISIDE1=-1 ELSE ISIDE1=0 ENDIF GOTO 1240 ENDIF 1230 CONTINUE ISIDE1=0 1240 CONTINUE * Verify whether this branch is at all visible. CALL INTERD(NPL2,XPL2,YPL2,X1,Y1,IN1,EDGE1) ZAUX1=(DPL1-APL1*X1-BPL1*Y1)/CPL1 ZAUX2=(DPL2-APL2*X1-BPL2*Y1)/CPL2 IF((IN1.OR.EDGE1).AND.ZAUX1.LT.ZAUX2-EPSD)ISIDE1=0 * Check plane 1+, compute the incidence angle. PHI2=MOD(ATAN2( - YL(1+MOD(JP,N1),1)-YL(IP,IL), - XL(1+MOD(JP,N1),1)-XL(IP,IL))-PHI0,2.0D0*PI) IF(PHI2.LT.-PI)PHI2=PHI2+2.0D0*PI IF(PHI2.GT.+PI)PHI2=PHI2-2.0D0*PI IF(ISIDE0.EQ.+1.AND.PHI2.LT.0)PHI2=PHI2+2.0D0*PI IF(ISIDE0.EQ.-1.AND.PHI2.GT.0)PHI2=PHI2-2.0D0*PI * See on which side of this line we enter visibly into 1. X1= (XL(1+MOD(JP,N1),1)+XL(IP,IL))/2 Y1= (YL(1+MOD(JP,N1),1)+YL(IP,IL))/2 STEP=SQRT( - (XL(1+MOD(JP,N1),1)-XL(IP,IL))**2+ - (YL(1+MOD(JP,N1),1)-YL(IP,IL))**2) DO 1250 K=3,10 DX=-(YL(1+MOD(JP,N1),1)-YL(IP,IL))* - (2**K)*SQRT(EPSX**2+EPSY**2)/STEP DY=+(XL(1+MOD(JP,N1),1)-XL(IP,IL))* - (2**K)*SQRT(EPSX**2+EPSY**2)/STEP CALL INTERD(NPL1,XPL1,YPL1,X1+DX,Y1+DY,IN1,EDGE1) CALL INTERD(NPL1,XPL1,YPL1,X1-DX,Y1-DY,IN2,EDGE2) CALL INTERD(NPL2,XPL2,YPL2,X1+DX,Y1+DY,IN3,EDGE3) CALL INTERD(NPL2,XPL2,YPL2,X1-DX,Y1-DY,IN4,EDGE4) IF(IN1.AND..NOT.(EDGE1.OR.IN2.OR.EDGE2))THEN ZAUX1=(DPL1-APL1*(X1+DX)-BPL1*(Y1+DY))/CPL1 ZAUX2=(DPL2-APL2*(X1+DX)-BPL2*(Y1+DY))/CPL2 IF(.NOT.(IN3.OR.EDGE3).OR.ZAUX1.GT.ZAUX2-EPSD)THEN ISIDE2=+1 ELSE ISIDE2=0 ENDIF GOTO 1260 ELSEIF(IN2.AND..NOT.(EDGE2.OR.IN1.OR.EDGE1))THEN ZAUX1=(DPL1-APL1*(X1-DX)-BPL1*(Y1-DY))/CPL1 ZAUX2=(DPL2-APL2*(X1-DX)-BPL2*(Y1-DY))/CPL2 IF(.NOT.(IN4.OR.EDGE4).OR.ZAUX1.GT.ZAUX2-EPSD)THEN ISIDE2=-1 ELSE ISIDE2=0 ENDIF GOTO 1260 ENDIF 1250 CONTINUE ISIDE2=0 1260 CONTINUE * Verify whether this branch is at all visible. CALL INTERD(NPL2,XPL2,YPL2,X1,Y1,IN1,EDGE1) ZAUX1=(DPL1-APL1*X1-BPL1*Y1)/CPL1 ZAUX2=(DPL2-APL2*X1-BPL2*Y1)/CPL2 IF((IN1.OR.EDGE1).AND.ZAUX1.LT.ZAUX2-EPSD)ISIDE2=0 * Plane 2-. JP=IREF(IP,IL,2) * Compute the incidence angle. PHI3=MOD(ATAN2( - YL(1+MOD(JP-2+N2,N2),2)-YL(IP,IL), - XL(1+MOD(JP-2+N2,N2),2)-XL(IP,IL))-PHI0,2.0D0*PI) IF(PHI3.LT.-PI)PHI3=PHI3+2.0D0*PI IF(PHI3.GT.+PI)PHI3=PHI3-2.0D0*PI IF(ISIDE0.EQ.+1.AND.PHI3.LT.0)PHI3=PHI3+2.0D0*PI IF(ISIDE0.EQ.-1.AND.PHI3.GT.0)PHI3=PHI3-2.0D0*PI * See on which side of this line we enter visibly into 1. X1= (XL(1+MOD(JP-2+N2,N2),2)+XL(IP,IL))/2 Y1= (YL(1+MOD(JP-2+N2,N2),2)+YL(IP,IL))/2 STEP=SQRT( - (XL(1+MOD(JP-2+N2,N2),2)-XL(IP,IL))**2+ - (YL(1+MOD(JP-2+N2,N2),2)-YL(IP,IL))**2) DO 1270 K=3,10 DX=-(YL(1+MOD(JP-2+N2,N2),2)-YL(IP,IL))* - (2**K)*SQRT(EPSX**2+EPSY**2)/STEP DY=+(XL(1+MOD(JP-2+N2,N2),2)-XL(IP,IL))* - (2**K)*SQRT(EPSX**2+EPSY**2)/STEP CALL INTERD(NPL1,XPL1,YPL1,X1+DX,Y1+DY,IN1,EDGE1) CALL INTERD(NPL1,XPL1,YPL1,X1-DX,Y1-DY,IN2,EDGE2) IF((IN1.OR.IN2).AND..NOT.(EDGE1.OR.EDGE2))THEN CALL INTERD(NPL2,XPL2,YPL2,X1+DX,Y1+DY,IN3,EDGE3) ZAUX1=(DPL1-APL1*(X1+DX)-BPL1*(Y1+DY))/CPL1 ZAUX2=(DPL2-APL2*(X1+DX)-BPL2*(Y1+DY))/CPL2 CALL INTERD(NPL2,XPL2,YPL2,X1-DX,Y1-DY,IN4,EDGE4) ZAUX3=(DPL1-APL1*(X1-DX)-BPL1*(Y1-DY))/CPL1 ZAUX4=(DPL2-APL2*(X1-DX)-BPL2*(Y1-DY))/CPL2 IF((IN1.AND.(.NOT.(IN3.OR.EDGE3).OR. - ZAUX1.GT.ZAUX2-EPSD)).AND. - (IN2.AND.(.NOT.(IN4.OR.EDGE4).OR. - ZAUX3.GT.ZAUX4-EPSD)))THEN ISIDE3=2 ELSEIF(IN1.AND.(.NOT.(IN3.OR.EDGE3).OR. - ZAUX1.GT.ZAUX2-EPSD))THEN ISIDE3=+1 ELSEIF(IN2.AND.(.NOT.(IN4.OR.EDGE4).OR. - ZAUX3.GT.ZAUX4-EPSD))THEN ISIDE3=-1 ELSE ISIDE3=0 ENDIF GOTO 1280 ENDIF 1270 CONTINUE ISIDE3=0 1280 CONTINUE * Verify whether this branch is at all visible. ZAUX1=(DPL1-APL1*X1-BPL1*Y1)/CPL1 ZAUX2=(DPL2-APL2*X1-BPL2*Y1)/CPL2 IF(ZAUX2.LT.ZAUX1-EPSD)ISIDE3=0 * Check plane 2+, compute the incidence angle. PHI4=MOD(ATAN2( - YL(1+MOD(JP,N2),2)-YL(IP,IL), - XL(1+MOD(JP,N2),2)-XL(IP,IL))-PHI0,2.0D0*PI) IF(PHI4.LT.-PI)PHI4=PHI4+2.0D0*PI IF(PHI4.GT.+PI)PHI4=PHI4-2.0D0*PI IF(ISIDE0.EQ.+1.AND.PHI4.LT.0)PHI4=PHI4+2.0D0*PI IF(ISIDE0.EQ.-1.AND.PHI4.GT.0)PHI4=PHI4-2.0D0*PI * See on which side of this line we enter visibly into 1. X1= (XL(1+MOD(JP,N2),2)+XL(IP,IL))/2 Y1= (YL(1+MOD(JP,N2),2)+YL(IP,IL))/2 STEP=SQRT( - (XL(1+MOD(JP,N2),2)-XL(IP,IL))**2+ - (YL(1+MOD(JP,N2),2)-YL(IP,IL))**2) DO 1290 K=3,10 DX=-(YL(1+MOD(JP,N2),2)-YL(IP,IL))* - (2**K)*SQRT(EPSX**2+EPSY**2)/STEP DY=+(XL(1+MOD(JP,N2),2)-XL(IP,IL))* - (2**K)*SQRT(EPSX**2+EPSY**2)/STEP CALL INTERD(NPL1,XPL1,YPL1,X1+DX,Y1+DY,IN1,EDGE1) CALL INTERD(NPL1,XPL1,YPL1,X1-DX,Y1-DY,IN2,EDGE2) IF((IN1.OR.IN2).AND..NOT.(EDGE1.OR.EDGE2))THEN CALL INTERD(NPL2,XPL2,YPL2,X1+DX,Y1+DY,IN3,EDGE3) ZAUX1=(DPL1-APL1*(X1+DX)-BPL1*(Y1+DY))/CPL1 ZAUX2=(DPL2-APL2*(X1+DX)-BPL2*(Y1+DY))/CPL2 CALL INTERD(NPL2,XPL2,YPL2,X1-DX,Y1-DY,IN4,EDGE4) ZAUX3=(DPL1-APL1*(X1-DX)-BPL1*(Y1-DY))/CPL1 ZAUX4=(DPL2-APL2*(X1-DX)-BPL2*(Y1-DY))/CPL2 IF((IN1.AND.(.NOT.(IN3.OR.EDGE3).OR. - ZAUX1.GT.ZAUX2-EPSD)).AND. - (IN2.AND.(.NOT.(IN4.OR.EDGE4).OR. - ZAUX3.GT.ZAUX4-EPSD)))THEN ISIDE4=2 ELSEIF(IN1.AND.(.NOT.(IN3.OR.EDGE3).OR. - ZAUX1.GT.ZAUX2-EPSD))THEN ISIDE4=+1 ELSEIF(IN2.AND.(.NOT.(IN4.OR.EDGE4).OR. - ZAUX3.GT.ZAUX4-EPSD))THEN ISIDE4=-1 ELSE ISIDE4=0 ENDIF GOTO 1300 ENDIF 1290 CONTINUE ISIDE4=0 1300 CONTINUE * Verify whether this branch is at all visible. ZAUX1=(DPL1-APL1*X1-BPL1*Y1)/CPL1 ZAUX2=(DPL2-APL2*X1-BPL2*Y1)/CPL2 IF(ZAUX2.LT.ZAUX1-EPSD)ISIDE4=0 * Check separation line - side. JP=IREF(IP,IL,3) * Make sure we are at all allowed to go in this direction. IF(JP.LE.1)THEN ISIDE5=0 PHI5=3*PI GOTO 1320 ENDIF * Compute the incidence angle. PHI5=MOD(ATAN2( - YL(1+MOD(JP-2+NS,NS),3)-YL(IP,IL), - XL(1+MOD(JP-2+NS,NS),3)-XL(IP,IL))-PHI0,2.0D0*PI) IF(PHI5.LT.-PI)PHI5=PHI5+2.0D0*PI IF(PHI5.GT.+PI)PHI5=PHI5-2.0D0*PI IF(ISIDE0.EQ.+1.AND.PHI5.LT.0)PHI5=PHI5+2.0D0*PI IF(ISIDE0.EQ.-1.AND.PHI5.GT.0)PHI5=PHI5-2.0D0*PI * See on which side of this line we enter visibly into 1. X1= (XL(1+MOD(JP-2+NS,NS),3)+XL(IP,IL))/2 Y1= (YL(1+MOD(JP-2+NS,NS),3)+YL(IP,IL))/2 STEP=SQRT( - (XL(1+MOD(JP-2+NS,NS),3)-XL(IP,IL))**2+ - (YL(1+MOD(JP-2+NS,NS),3)-YL(IP,IL))**2) DO 1310 K=3,10 DX=-(YL(1+MOD(JP-2+NS,NS),3)-YL(IP,IL))* - (2**K)*SQRT(EPSX**2+EPSY**2)/STEP DY=+(XL(1+MOD(JP-2+NS,NS),3)-XL(IP,IL))* - (2**K)*SQRT(EPSX**2+EPSY**2)/STEP CALL INTERD(NPL1,XPL1,YPL1,X1+DX,Y1+DY,IN1,EDGE1) CALL INTERD(NPL1,XPL1,YPL1,X1-DX,Y1-DY,IN2,EDGE2) IF((IN1.OR.IN2).AND..NOT.(EDGE1.OR.EDGE2))THEN CALL INTERD(NPL2,XPL2,YPL2,X1+DX,Y1+DY,IN3,EDGE3) ZAUX1=(DPL1-APL1*(X1+DX)-BPL1*(Y1+DY))/CPL1 ZAUX2=(DPL2-APL2*(X1+DX)-BPL2*(Y1+DY))/CPL2 CALL INTERD(NPL2,XPL2,YPL2,X1-DX,Y1-DY,IN4,EDGE4) ZAUX3=(DPL1-APL1*(X1-DX)-BPL1*(Y1-DY))/CPL1 ZAUX4=(DPL2-APL2*(X1-DX)-BPL2*(Y1-DY))/CPL2 IF((IN1.AND.(.NOT.(IN3.OR.EDGE3).OR. - ZAUX1.GT.ZAUX2-EPSD)).AND. - (IN2.AND.(.NOT.(IN4.OR.EDGE4).OR. - ZAUX3.GT.ZAUX4-EPSD)))THEN ISIDE5=2 ELSEIF(IN1.AND.(.NOT.(IN3.OR.EDGE3).OR. - ZAUX1.GT.ZAUX2-EPSD))THEN ISIDE5=+1 ELSEIF(IN2.AND.(.NOT.(IN4.OR.EDGE4).OR. - ZAUX3.GT.ZAUX4-EPSD))THEN ISIDE5=-1 ELSE ISIDE5=0 ENDIF GOTO 1320 ENDIF 1310 CONTINUE ISIDE5=0 1320 CONTINUE * Separation line, + side, can we go in this direction. IF(JP.GE.NS)THEN ISIDE6=0 PHI6=3*PI GOTO 1340 ENDIF * Compute the incidence angle. PHI6=MOD(ATAN2( - YL(1+MOD(JP,NS),3)-YL(IP,IL), - XL(1+MOD(JP,NS),3)-XL(IP,IL))-PHI0,2.0D0*PI) IF(PHI6.LT.-PI)PHI6=PHI6+2.0D0*PI IF(PHI6.GT.+PI)PHI6=PHI6-2.0D0*PI IF(ISIDE0.EQ.+1.AND.PHI6.LT.0)PHI6=PHI6+2.0D0*PI IF(ISIDE0.EQ.-1.AND.PHI6.GT.0)PHI6=PHI6-2.0D0*PI * See on which side of this line we enter visibly into 1. X1= (XL(1+MOD(JP,NS),3)+XL(IP,IL))/2 Y1= (YL(1+MOD(JP,NS),3)+YL(IP,IL))/2 STEP=SQRT( - (XL(1+MOD(JP,NS),3)-XL(IP,IL))**2+ - (YL(1+MOD(JP,NS),3)-YL(IP,IL))**2) DO 1330 K=3,10 DX=-(YL(1+MOD(JP,NS),3)-YL(IP,IL))* - (2**K)*SQRT(EPSX**2+EPSY**2)/STEP DY=+(XL(1+MOD(JP,NS),3)-XL(IP,IL))* - (2**K)*SQRT(EPSX**2+EPSY**2)/STEP CALL INTERD(NPL1,XPL1,YPL1,X1+DX,Y1+DY,IN1,EDGE1) CALL INTERD(NPL1,XPL1,YPL1,X1-DX,Y1-DY,IN2,EDGE2) IF((IN1.OR.IN2).AND..NOT.(EDGE1.OR.EDGE2))THEN CALL INTERD(NPL2,XPL2,YPL2,X1+DX,Y1+DY,IN3,EDGE3) ZAUX1=(DPL1-APL1*(X1+DX)-BPL1*(Y1+DY))/CPL1 ZAUX2=(DPL2-APL2*(X1+DX)-BPL2*(Y1+DY))/CPL2 CALL INTERD(NPL2,XPL2,YPL2,X1-DX,Y1-DY,IN4,EDGE4) ZAUX3=(DPL1-APL1*(X1-DX)-BPL1*(Y1-DY))/CPL1 ZAUX4=(DPL2-APL2*(X1-DX)-BPL2*(Y1-DY))/CPL2 IF((IN1.AND.(.NOT.(IN3.OR.EDGE3).OR. - ZAUX1.GT.ZAUX2-EPSD)).AND. - (IN2.AND.(.NOT.(IN4.OR.EDGE4).OR. - ZAUX3.GT.ZAUX4-EPSD)))THEN ISIDE6=2 ELSEIF(IN1.AND.(.NOT.(IN3.OR.EDGE3).OR. - ZAUX1.GT.ZAUX2-EPSD))THEN ISIDE6=+1 ELSEIF(IN2.AND.(.NOT.(IN4.OR.EDGE4).OR. - ZAUX3.GT.ZAUX4-EPSD))THEN ISIDE6=-1 ELSE ISIDE6=0 ENDIF GOTO 1340 ENDIF 1330 CONTINUE ISIDE6=0 1340 CONTINUE * Make sure we are at all allowed to go in this direction. IF(JP.GE.NS)ISIDE6=0 * Don't follow 2+ or 2- is degenerate with s+ or s-. JP2=IREF(IP,IL,2) JP3=IREF(IP,IL,3) IF(IREF(1+MOD(JP2-2+N2,N2),2,3).EQ.1+MOD(JP3-2+NS,NS).AND. - IREF(1+MOD(JP2-2+N2,N2),2,3).NE.0.AND. - (ISIDE3*ISIDE5.EQ.-1.OR.ABS(ISIDE3*ISIDE5).GE.2).AND. - ABS(PHI3-PHI5).LT.0.001)THEN ISIDE3=0 ISIDE5=0 C print *,' Eliminated 2-/s- degeneracy' ENDIF IF(IREF(1+MOD(JP2-2+N2,N2),2,3).EQ.1+MOD(JP3 ,NS).AND. - IREF(1+MOD(JP2-2+N2,N2),2,3).NE.0.AND. - (ISIDE3*ISIDE6.EQ.-1.OR.ABS(ISIDE3*ISIDE6).GE.2).AND. - ABS(PHI3-PHI6).LT.0.001)THEN ISIDE3=0 ISIDE6=0 C print *,' Eliminated 2-/s+ degeneracy' ENDIF IF(IREF(1+MOD(JP2 ,N2),2,3).EQ.1+MOD(JP3-2+NS,NS).AND. - IREF(1+MOD(JP2 ,N2),2,3).NE.0.AND. - (ISIDE4*ISIDE5.EQ.-1.OR.ABS(ISIDE4*ISIDE5).GE.2).AND. - ABS(PHI4-PHI5).LT.0.001)THEN ISIDE4=0 ISIDE5=0 C print *,' Eliminated 2+/s- degeneracy' ENDIF IF(IREF(1+MOD(JP2 ,N2),2,3).EQ.1+MOD(JP3 ,NS).AND. - IREF(1+MOD(JP2 ,N2),2,3).NE.0.AND. - (ISIDE4*ISIDE6.EQ.-1.OR.ABS(ISIDE4*ISIDE6).GE.2).AND. - ABS(PHI4-PHI6).LT.0.001)THEN ISIDE4=0 ISIDE6=0 C print *,' Eliminated 2+/s+ degeneracy' ENDIF * Find the optimal branch to take. PHIOPT=3*PI IF(ISIDE0*ISIDE1.EQ.-1.AND.ISIDE0*PHI1.LT.PHIOPT-0.001)THEN JDIR=-1 JP=1+MOD(IREF(IP,IL,1)+JDIR-1+N1,N1) JL=1 PHIOPT=ISIDE0*PHI1 ENDIF IF(ISIDE0*ISIDE2.EQ.-1.AND.ISIDE0*PHI2.LT.PHIOPT-0.001)THEN JDIR=+1 JP=1+MOD(IREF(IP,IL,1)+JDIR-1+N1,N1) JL=1 PHIOPT=ISIDE0*PHI2 ENDIF IF(ISIDE0*ISIDE3.EQ.-1.AND.ISIDE0*PHI3.LT.PHIOPT-0.001)THEN JDIR=-1 JP=1+MOD(IREF(IP,IL,2)+JDIR-1+N2,N2) JL=2 PHIOPT=ISIDE0*PHI3 ENDIF IF(ISIDE0*ISIDE4.EQ.-1.AND.ISIDE0*PHI4.LT.PHIOPT-0.001)THEN JDIR=+1 JP=1+MOD(IREF(IP,IL,2)+JDIR-1+N2,N2) JL=2 PHIOPT=ISIDE0*PHI4 ENDIF IF(ISIDE0*ISIDE5.EQ.-1.AND.ISIDE0*PHI5.LT.PHIOPT-0.001)THEN JDIR=-1 JP=1+MOD(IREF(IP,IL,3)+JDIR-1+NS,NS) JL=3 PHIOPT=ISIDE0*PHI5 ENDIF IF(ISIDE0*ISIDE6.EQ.-1.AND.ISIDE0*PHI6.LT.PHIOPT-0.001)THEN JDIR=+1 JP=1+MOD(IREF(IP,IL,3)+JDIR-1+NS,NS) JL=3 PHIOPT=ISIDE0*PHI6 ENDIF IF(LDEBUG)WRITE(LUNOUT,'( - 5X,''Incoming, side='',I2,'' angle= '',F10.3/ - 5X,''List 1 -, side='',I2,'' relative angle='',F10.3/ - 5X,''List 1 +, side='',I2,'' relative angle='',F10.3/ - 5X,''List 2 -, side='',I2,'' relative angle='',F10.3/ - 5X,''List 2 +, side='',I2,'' relative angle='',F10.3/ - 5X,''Split -, side='',I2,'' relative angle='',F10.3/ - 5X,''Split +, side='',I2,'' relative angle='',F10.3/ - 5X,''Selected list '',I3,'' point '',I3, - '' direction '',I3)') - ISIDE0,PHI0,ISIDE1,PHI1,ISIDE2,PHI2,ISIDE3,PHI3, - ISIDE4,PHI4,ISIDE5,PHI5,ISIDE6,PHI6,JL,JP,JDIR * See whether a solution has been found. IF(PHIOPT.GT.2.0D0*PI)THEN PRINT *,' !!!!!! PLASPL WARNING : Did not find a'// - ' way out of the triple crossing ; skipping.' LGSIG=.TRUE. IP=1+MOD(IP+IDIR-1+NP,NP) ELSE IP=JP IL=JL IDIR=JDIR ENDIF 1200 CONTINUE ** If this is an intersect or a vertex of the other plane. ELSEIF((IT(IP,IL).EQ.2.OR.IT(IP,IL).EQ.3).AND.IL.NE.3)THEN IF(LDEBUG)WRITE(LUNOUT,'('' Crossing / foreign vertex'')') * Compute offsets for plane 1 (ZAUX1) and for plane 2 (ZAUX2). ZAUX1=(DPL1-APL1*XL(IP,IL)-BPL1*YL(IP,IL))/CPL1 ZAUX2=(DPL2-APL2*XL(IP,IL)-BPL2*YL(IP,IL))/CPL2 * If on plane 2 and crossing under 1, follow 1 in old direction. IF(IL.EQ.2.AND.ZAUX1.GT.ZAUX2-EPSD)THEN IF(LDEBUG)WRITE(LUNOUT,'(5X,''On 2, going under 1'')') IL=1 IDIR=INITD IP=1+MOD(IREF(IP,2,1)+IDIR-1+N1,N1) * If on plane 2 and crossing over 1, follow visible part of 1. ELSEIF(IL.EQ.2)THEN IF(LDEBUG)WRITE(LUNOUT,'(5X,''On 2, going over 1'')') JP=IREF(IP,IL,3-IL) CALL INTERD(NPL2,XPL2,YPL2, - 0.5*(XL(1+MOD(JP-2+N1,N1),1)+ - XL(1+MOD(JP-1 ,N1),1)), - 0.5*(YL(1+MOD(JP-2+N1,N1),1)+ - YL(1+MOD(JP-1 ,N1),1)),IN1,EDGE1) CALL INTERD(NPL2,XPL2,YPL2, - 0.5*(XL(1+MOD(JP ,N1),1)+ - XL(1+MOD(JP-1 ,N1),1)), - 0.5*(YL(1+MOD(JP ,N1),1)+ - YL(1+MOD(JP-1 ,N1),1)),IN2,EDGE2) IF(.NOT.(IN1.OR.IN2.OR.EDGE1.OR.EDGE2))THEN PHI0=ATAN2( - YL(1+MOD(IP-IDIR-1+NP,NP),IL)-YL(IP,IL), - XL(1+MOD(IP-IDIR-1+NP,NP),IL)-XL(IP,IL)) PHI1=MOD(ATAN2( - YL(1+MOD(IP+IDIR-1+NP,NP),IL)-YL(IP,IL), - XL(1+MOD(IP+IDIR-1+NP,NP),IL)-XL(IP,IL))- - PHI0,2.0D0*PI) IF(PHI1.LT.-PI)PHI1=PHI1+2*PI IF(PHI1.GT.+PI)PHI1=PHI1-2*PI PHI2=MOD(ATAN2( - YL(1+MOD(JP-2+N1,N1),1)-YL(IP,IL), - XL(1+MOD(JP-2+N1,N1),1)-XL(IP,IL))- - PHI0,2.0D0*PI) IF(PHI2.LT.-PI)PHI2=PHI2+2*PI IF(PHI2.GT.+PI)PHI2=PHI2-2*PI PHI3=MOD(ATAN2( - YL(1+MOD(JP ,N1),1)-YL(IP,IL), - XL(1+MOD(JP ,N1),1)-XL(IP,IL))- - PHI0,2.0D0*PI) IF(PHI3.LT.-PI)PHI3=PHI3+2*PI IF(PHI3.GT.+PI)PHI3=PHI3-2*PI IF((ABS(PHI2).LT.ABS(PHI1).AND. - PHI1*PHI2.GE.0).OR. - (ABS(PHI3).LT.ABS(PHI1).AND. - PHI1*PHI3.GE.0))THEN IF(ABS(PHI2).LT.ABS(PHI3))THEN IP=1+MOD(JP-2+N1,N1) IDIR=-1 ELSE IP=1+MOD(JP ,N1) IDIR=+1 ENDIF ELSE IF(PHI1.GT.0)THEN IF(PHI2.LT.0)PHI2=PHI2+2*PI IF(PHI3.LT.0)PHI3=PHI3+2*PI ELSE IF(PHI2.GT.0)PHI2=PHI2-2*PI IF(PHI3.GT.0)PHI3=PHI3-2*PI ENDIF IF(ABS(PHI2).GT.ABS(PHI3))THEN IP=1+MOD(JP-2+N1,N1) IDIR=-1 ELSE IP=1+MOD(JP ,N1) IDIR=+1 ENDIF ENDIF IL=1 ELSEIF(.NOT.(IN1.OR.EDGE1))THEN IL=1 IDIR=-1 IP=1+MOD(JP+IDIR-1+N1,N1) ELSEIF(.NOT.(IN2.OR.EDGE2))THEN IL=1 IDIR=+1 IP=1+MOD(JP+IDIR-1+N1,N1) ELSE IL=2 IP=1+MOD(IP+IDIR-1+N2,N2) ENDIF * If on plane 1 and crossing under 2, follow part of 2 entering 1. ELSEIF(IL.EQ.1.AND.ZAUX1.LT.ZAUX2-EPSD)THEN IF(LDEBUG)WRITE(LUNOUT,'(5X,''On 1, going under 2'')') JP=IREF(IP,IL,3-IL) CALL INTERD(NPL1,XPL1,YPL1, - 0.5*(XL(1+MOD(JP-2+N2,N2),2)+ - XL(1+MOD(JP-1 ,N2),2)), - 0.5*(YL(1+MOD(JP-2+N2,N2),2)+ - YL(1+MOD(JP-1 ,N2),2)),IN1,EDGE1) CALL INTERD(NPL1,XPL1,YPL1, - 0.5*(XL(1+MOD(JP ,N2),2)+ - XL(1+MOD(JP-1 ,N2),2)), - 0.5*(YL(1+MOD(JP ,N2),2)+ - YL(1+MOD(JP-1 ,N2),2)),IN2,EDGE2) IF(IN1.AND.IN2)THEN PHI0=ATAN2( - YL(1+MOD(IP-IDIR-1+NP,NP),IL)-YL(IP,IL), - XL(1+MOD(IP-IDIR-1+NP,NP),IL)-XL(IP,IL)) PHI1=MOD(ATAN2( - YL(1+MOD(IP+IDIR-1+NP,NP),IL)-YL(IP,IL), - XL(1+MOD(IP+IDIR-1+NP,NP),IL)-XL(IP,IL))- - PHI0,2.0D0*PI) IF(PHI1.LT.-PI)PHI1=PHI1+2*PI IF(PHI1.GT.+PI)PHI1=PHI1-2*PI PHI2=MOD(ATAN2( - YL(1+MOD(JP-2+N2,N2),2)-YL(IP,IL), - XL(1+MOD(JP-2+N2,N2),2)-XL(IP,IL))- - PHI0,2.0D0*PI) IF(PHI2.LT.-PI)PHI2=PHI2+2*PI IF(PHI2.GT.+PI)PHI2=PHI2-2*PI PHI3=MOD(ATAN2( - YL(1+MOD(JP ,N2),2)-YL(IP,IL), - XL(1+MOD(JP ,N2),2)-XL(IP,IL))- - PHI0,2.0D0*PI) IF(PHI3.LT.-PI)PHI3=PHI3+2*PI IF(PHI3.GT.+PI)PHI3=PHI3-2*PI IF((ABS(PHI2).LT.ABS(PHI1).AND. - PHI1*PHI2.GE.0).OR. - (ABS(PHI3).LT.ABS(PHI1).AND. - PHI1*PHI3.GE.0))THEN IF(ABS(PHI2).LT.ABS(PHI3))THEN IP=1+MOD(JP-2+N2,N2) IDIR=-1 ELSE IP=1+MOD(JP ,N2) IDIR=+1 ENDIF ELSE IF(PHI1.GT.0)THEN IF(PHI2.LT.0)PHI2=PHI2+2*PI IF(PHI3.LT.0)PHI3=PHI3+2*PI ELSE IF(PHI2.GT.0)PHI2=PHI2-2*PI IF(PHI3.GT.0)PHI3=PHI3-2*PI ENDIF IF(ABS(PHI2).GT.ABS(PHI3))THEN IP=1+MOD(JP-2+N2,N2) IDIR=-1 ELSE IP=1+MOD(JP ,N2) IDIR=+1 ENDIF ENDIF IL=2 ELSEIF(IN1)THEN IL=2 IDIR=-1 IP=1+MOD(JP+IDIR-1+N2,N2) ELSEIF(IN2)THEN IL=2 IDIR=+1 IP=1+MOD(JP+IDIR-1+N2,N2) ELSE IL=1 IP=1+MOD(IP+IDIR-1+N1,N1) ENDIF * If on plane 1 and crossing above 2, simply continue. ELSEIF(IL.EQ.1)THEN IF(LDEBUG)WRITE(LUNOUT,'(5X,''On 1, going over 2'')') IP=1+MOD(IP+IDIR-1+NP,NP) ENDIF ** If this is a vertex lying on the intersection line. ELSEIF((IT(IP,IL).EQ.1.OR.IT(IP,IL).EQ.2).AND.IL.EQ.3)THEN IF(LDEBUG)WRITE(LUNOUT,'('' Crossing or vertex of list '', - I3,'' on the separation line.'')') IT(IP,IL) * Check visibility ZAUX1/3 on plane 1, ZAUX2/4 on plane 2. IF(IT(IP,IL).EQ.1)THEN JP=IREF(IP,3,1) ZAUX1=(DPL1- - APL1*(XL(IP,IL)+XL(1+MOD(JP-2+N1,N1),1))/2- - BPL1*(YL(IP,IL)+YL(1+MOD(JP-2+N1,N1),1))/2)/CPL1 ZAUX2=(DPL2- - APL2*(XL(IP,IL)+XL(1+MOD(JP-2+N1,N1),1))/2- - BPL2*(YL(IP,IL)+YL(1+MOD(JP-2+N1,N1),1))/2)/CPL2 ZAUX3=(DPL1- - APL1*(XL(IP,IL)+XL(1+MOD(JP,N1),1))/2- - BPL1*(YL(IP,IL)+YL(1+MOD(JP,N1),1))/2)/CPL1 ZAUX4=(DPL2- - APL2*(XL(IP,IL)+XL(1+MOD(JP,N1),1))/2- - BPL2*(YL(IP,IL)+YL(1+MOD(JP,N1),1))/2)/CPL2 CALL INTERD(NPL2,XPL2,YPL2, - (XL(IP,IL)+XL(1+MOD(JP-2+N1,N1),1))/2, - (YL(IP,IL)+YL(1+MOD(JP-2+N1,N1),1))/2, - IN1,EDGE1) CALL INTERD(NPL2,XPL2,YPL2, - (XL(IP,IL)+XL(1+MOD(JP,N1),1))/2, - (YL(IP,IL)+YL(1+MOD(JP,N1),1))/2, - IN2,EDGE2) IF(.NOT.(IN1.OR.IN2.OR.EDGE1.OR.EDGE2))THEN IF(((XL(1+MOD(JP-2+N1 ,N1),1 )-XL(IP,IL))* - (XL(1+MOD(IP-IDIR-1+NP,NP),IL)-XL(IP,IL))+ - (YL(1+MOD(JP-2+N1 ,N1),1 )-YL(IP,IL))* - (YL(1+MOD(IP-IDIR-1+NP,NP),IL)-YL(IP,IL)))* - SQRT((XL(1+MOD(JP ,N1),1 )-XL(IP,IL))**2+ - (YL(1+MOD(JP ,N1),1 )-YL(IP,IL))**2) - .LT. - ((XL(1+MOD(JP ,N1),1 )-XL(IP,IL))* - (XL(1+MOD(IP-IDIR-1+NP,NP),IL)-XL(IP,IL))+ - (YL(1+MOD(JP ,N1),1 )-YL(IP,IL))* - (YL(1+MOD(IP-IDIR-1+NP,NP),IL)-YL(IP,IL)))* - SQRT((XL(1+MOD(JP-2+N1,N1),1 )-XL(IP,IL))**2+ - (YL(1+MOD(JP-2+N1,N1),1 )-YL(IP,IL))**2) - )THEN IDIR=-1 ELSE IDIR=+1 ENDIF C print *,' Both ways visible, choosing ',IDIR IL=1 IP=1+MOD(JP+IDIR-1+N1,N1) ELSEIF((.NOT.(IN1.OR.EDGE1).OR.ZAUX1.GE.ZAUX2).AND. - (.NOT.(IN2.OR.EDGE2).OR.ZAUX3.GE.ZAUX4))THEN C print *,' Choosing initial direction.' IL=1 IDIR=INITD IP=1+MOD(JP+IDIR-1+N1,N1) ELSEIF(.NOT.(IN1.OR.EDGE1))THEN C print *,' Choosing -' IL=1 IDIR=-1 IP=1+MOD(JP+IDIR-1+N1,N1) ELSEIF(.NOT.(IN2.OR.EDGE2))THEN C print *,' Choosing +' IL=1 IDIR=+1 IP=1+MOD(JP+IDIR-1+N1,N1) ELSEIF(ZAUX1.GE.ZAUX2)THEN C print *,' Choosing -' IL=1 IDIR=-1 IP=1+MOD(JP+IDIR-1+N1,N1) ELSEIF(ZAUX3.GE.ZAUX4)THEN C print *,' Choosing +' IL=1 IDIR=+1 IP=1+MOD(JP+IDIR-1+N1,N1) ELSE PRINT *,' !!!!!! PLASPL WARNING : Found no way'// - ' out of a vertex on intersect.' LGSIG=.TRUE. IP=1+MOD(IP+IDIR-1+NP,NP) ENDIF * Continue via plane 2. ELSEIF(IT(IP,IL).EQ.2)THEN PRINT *,' !!!!!! PLASPL WARNING : Crossed plane 2', - ' via the separation line; skipped.' IP=1+MOD(IP+IDIR-1+NP,NP) ENDIF ** If this is a hole in the other plane. ELSEIF(IT(IP,IL).EQ.4)THEN IF(LDEBUG)WRITE(LUNOUT,'('' Hole in other plane.'')') * If on plane 1, follow separation line entering plane 1. IF(IL.EQ.1)THEN JP=IREF(IP,IL,3) CALL INTERD(NPL1,XPL1,YPL1, - 0.5*(XL(1+MOD(JP-2+NS,NS),3)+ - XL(1+MOD(JP-1 ,NS),3)), - 0.5*(YL(1+MOD(JP-2+NS,NS),3)+ - YL(1+MOD(JP-1 ,NS),3)),IN1,EDGE1) CALL INTERD(NPL1,XPL1,YPL1, - 0.5*(XL(1+MOD(JP ,NS),3)+ - XL(1+MOD(JP-1 ,NS),3)), - 0.5*(YL(1+MOD(JP ,NS),3)+ - YL(1+MOD(JP-1 ,NS),3)),IN2,EDGE2) IF(JP.LE.1)THEN IP=1 IDIR=+1 IL=3 IP=1+MOD(IP+IDIR-1+NS,NS) ELSEIF(JP.GE.NS)THEN IP=NS IDIR=-1 IL=3 IP=1+MOD(IP+IDIR-1+NS,NS) ELSEIF(IN1.OR.(EDGE1.AND..NOT.IN2))THEN IP=JP IDIR=-1 IL=3 IP=1+MOD(IP+IDIR-1+NS,NS) ELSEIF(IN2.OR.(EDGE2.AND..NOT.IN1))THEN IP=JP IDIR=+1 IL=3 IP=1+MOD(IP+IDIR-1+NS,NS) ELSE IP=1+MOD(IP+IDIR-1+NP,NP) ENDIF * If on plane 2, follow separation line entering plane 2. ELSEIF(IL.EQ.2)THEN JP=IREF(IP,IL,3) CALL INTERD(NPL2,XPL2,YPL2, - 0.5*(XL(1+MOD(JP-2+NS,NS),3)+ - XL(1+MOD(JP-1 ,NS),3)), - 0.5*(YL(1+MOD(JP-2+NS,NS),3)+ - YL(1+MOD(JP-1 ,NS),3)),IN1,EDGE1) CALL INTERD(NPL2,XPL2,YPL2, - 0.5*(XL(1+MOD(JP ,NS),3)+ - XL(1+MOD(JP-1 ,NS),3)), - 0.5*(YL(1+MOD(JP ,NS),3)+ - YL(1+MOD(JP-1 ,NS),3)),IN2,EDGE2) IF(JP.LE.1)THEN IP=1 IDIR=+1 IL=3 IP=1+MOD(IP+IDIR-1+NS,NS) ELSEIF(JP.GE.NS)THEN IP=NS IDIR=-1 IL=3 IP=1+MOD(IP+IDIR-1+NS,NS) ELSEIF(IN1.OR.(EDGE1.AND..NOT.IN2))THEN IP=JP IDIR=-1 IL=3 IP=1+MOD(IP+IDIR-1+NS,NS) ELSEIF(IN2.OR.(EDGE2.AND..NOT.IN1))THEN IP=JP IDIR=+1 IL=3 IP=1+MOD(IP+IDIR-1+NS,NS) ELSE IP=1+MOD(IP+IDIR-1+NP,NP) ENDIF * If on separation line, follow visible part of plane entered. ELSEIF(IL.EQ.3)THEN * Find out which plane we enter. IF(IREF(IP,3,1).NE.0)THEN JP=IREF(IP,3,1) IL=1 ZAUX1=(DPL1- - APL1*0.5*(XL(JP,IL)+XL(1+MOD(JP,N1),IL))- - BPL1*0.5*(YL(JP,IL)+YL(1+MOD(JP,N1),IL)))/ - CPL1 ZAUX2=(DPL2- - APL2*0.5*(XL(JP,IL)+XL(1+MOD(JP,N1),IL))- - BPL2*0.5*(YL(JP,IL)+YL(1+MOD(JP,N1),IL)))/ - CPL2 ZAUX3=(DPL1- - APL1*0.5*(XL(JP,IL)+ - XL(1+MOD(JP-2+N1,N1),IL))- - BPL1*0.5*(YL(JP,IL)+ - YL(1+MOD(JP-2+N1,N1),IL)))/CPL1 ZAUX4=(DPL2- - APL2*0.5*(XL(JP,IL)+ - XL(1+MOD(JP-2+N1,N1),IL))- - BPL2*0.5*(YL(JP,IL)+ - YL(1+MOD(JP-2+N1,N1),IL)))/CPL2 IF(ZAUX1.GT.ZAUX2)THEN IDIR=+1 ELSEIF(ZAUX3.GT.ZAUX4)THEN IDIR=-1 ENDIF IP=1+MOD(JP+IDIR-1+N1,N1) ELSEIF(IREF(IP,3,2).NE.0)THEN JP=IREF(IP,3,2) IL=2 ZAUX1=(DPL1- - APL1*0.5*(XL(JP,IL)+XL(1+MOD(JP,N2),IL))- - BPL1*0.5*(YL(JP,IL)+YL(1+MOD(JP,N2),IL)))/ - CPL1 ZAUX2=(DPL2- - APL2*0.5*(XL(JP,IL)+XL(1+MOD(JP,N2),IL))- - BPL2*0.5*(YL(JP,IL)+YL(1+MOD(JP,N2),IL)))/ - CPL2 ZAUX3=(DPL1- - APL1*0.5*(XL(JP,IL)+ - XL(1+MOD(JP-2+N2,N2),IL))- - BPL1*0.5*(YL(JP,IL)+ - YL(1+MOD(JP-2+N2,N2),IL)))/CPL1 ZAUX4=(DPL2- - APL2*0.5*(XL(JP,IL)+ - XL(1+MOD(JP-2+N2,N2),IL))- - BPL2*0.5*(YL(JP,IL)+ - YL(1+MOD(JP-2+N2,N2),IL)))/CPL2 IF(ZAUX2.GT.ZAUX1)THEN IDIR=+1 ELSEIF(ZAUX4.GT.ZAUX3)THEN IDIR=-1 ENDIF IP=1+MOD(JP+IDIR-1+N2,N2) ELSE PRINT *,' !!!!!! PLASPL WARNING : Hole has no'// - ' matching plane.' IP=1+MOD(IP+IDIR-1+NP,NP) ENDIF ENDIF ** If this is a crossing with the separation line. ELSEIF(IT(IP,IL).EQ.5)THEN IF(LDEBUG)WRITE(LUNOUT,'('' Plane crosses separation.'')') * If we are on plane 1, ensure we don't dive under other plane. IF(IL.EQ.1)THEN CALL INTERD(NPL2,XPL2,YPL2, - (XL(IP,IL)+XL(1+MOD(IP+IDIR-1,NP),IL))/2, - (YL(IP,IL)+YL(1+MOD(IP+IDIR-1,NP),IL))/2, - IN1,EDGE1) ZAUX1=(DPL1- - APL1*(XL(IP,IL)+XL(1+MOD(IP+IDIR-1,NP),IL))/2- - BPL1*(YL(IP,IL)+YL(1+MOD(IP+IDIR-1,NP),IL))/2)/ - CPL1 ZAUX2=(DPL2- - APL2*(XL(IP,IL)+XL(1+MOD(IP+IDIR-1,NP),IL))/2- - BPL2*(YL(IP,IL)+YL(1+MOD(IP+IDIR-1,NP),IL))/2)/ - CPL2 IF((IN1.OR.EDGE1).AND.ZAUX1.LT.ZAUX2)THEN IF(LDEBUG)WRITE(LUNOUT,'(5X, - ''On 1, going over 2'')') JP=IREF(IP,IL,3) CALL INTERD(NPL1,XPL1,YPL1, - (XL(JP,3)+XL(1+MOD(JP-2+NS,NS),3))/2, - (YL(JP,3)+YL(1+MOD(JP-2+NS,NS),3))/2, - IN1,EDGE1) CALL INTERD(NPL1,XPL1,YPL1, - (XL(JP,3)+XL(1+MOD(JP ,NS),3))/2, - (YL(JP,3)+YL(1+MOD(JP ,NS),3))/2, - IN2,EDGE2) CALL INTERD(NPL2,XPL2,YPL2, - (XL(JP,3)+XL(1+MOD(JP-2+NS,NS),3))/2, - (YL(JP,3)+YL(1+MOD(JP-2+NS,NS),3))/2, - IN3,EDGE3) CALL INTERD(NPL2,XPL2,YPL2, - (XL(JP,3)+XL(1+MOD(JP ,NS),3))/2, - (YL(JP,3)+YL(1+MOD(JP ,NS),3))/2, - IN4,EDGE4) IF((IN1.OR.EDGE1).AND.(IN3.OR.EDGE3))THEN IF(JP.LE.1)THEN PRINT *,' !!!!!! PLASPL WARNING :'// - ' Reached start of separation.' LGSIG=.TRUE. IDIR=+1 ELSE IDIR=-1 ENDIF IL=3 IP=JP+IDIR ELSEIF((IN2.OR.EDGE2).AND.(IN4.OR.EDGE4))THEN IF(JP.GE.NS)THEN PRINT *,' !!!!!! PLASPL WARNING :'// - ' Reached end of separation.' LGSIG=.TRUE. IDIR=-1 ELSE IDIR=+1 ENDIF IL=3 IP=JP+IDIR ELSE C print *,' No interest in changing line.' IP=1+MOD(IP+IDIR-1+NP,NP) ENDIF ELSE C print *,' Staying on curve' IP=1+MOD(IP+IDIR-1+NP,NP) ENDIF * If we are on plane 2, ensure we don't dive under other plane. ELSEIF(IL.EQ.2)THEN CALL INTERD(NPL1,XPL1,YPL1, - (XL(IP,IL)+XL(1+MOD(IP+IDIR-1,NP),IL))/2, - (YL(IP,IL)+YL(1+MOD(IP+IDIR-1,NP),IL))/2, - IN1,EDGE1) ZAUX1=(DPL1- - APL1*(XL(IP,IL)+XL(1+MOD(IP+IDIR-1,NP),IL))/2- - BPL1*(YL(IP,IL)+YL(1+MOD(IP+IDIR-1,NP),IL))/2)/ - CPL1 ZAUX2=(DPL2- - APL2*(XL(IP,IL)+XL(1+MOD(IP+IDIR-1,NP),IL))/2- - BPL2*(YL(IP,IL)+YL(1+MOD(IP+IDIR-1,NP),IL))/2)/ - CPL2 IF((IN1.OR.EDGE1).AND.ZAUX1.GT.ZAUX2)THEN IF(LDEBUG)WRITE(LUNOUT,'(5X, - ''On 1, going over 2'')') JP=IREF(IP,IL,3) CALL INTERD(NPL2,XPL2,YPL2, - (XL(JP,3)+XL(1+MOD(JP-2+NS,NS),3))/2, - (YL(JP,3)+YL(1+MOD(JP-2+NS,NS),3))/2, - IN1,EDGE1) CALL INTERD(NPL2,XPL2,YPL2, - (XL(JP,3)+XL(1+MOD(JP ,NS),3))/2, - (YL(JP,3)+YL(1+MOD(JP ,NS),3))/2, - IN2,EDGE2) CALL INTERD(NPL1,XPL1,YPL1, - (XL(JP,3)+XL(1+MOD(JP-2+NS,NS),3))/2, - (YL(JP,3)+YL(1+MOD(JP-2+NS,NS),3))/2, - IN3,EDGE3) CALL INTERD(NPL1,XPL1,YPL1, - (XL(JP,3)+XL(1+MOD(JP ,NS),3))/2, - (YL(JP,3)+YL(1+MOD(JP ,NS),3))/2, - IN4,EDGE4) IF((IN1.OR.EDGE1).AND.(IN3.OR.EDGE3))THEN IF(JP.LE.1)THEN PRINT *,' !!!!!! PLASPL WARNING :'// - ' Reached start of separation.' LGSIG=.TRUE. IDIR=+1 ELSE IDIR=-1 ENDIF IL=3 IP=JP+IDIR ELSEIF((IN2.OR.EDGE2).AND.(IN4.OR.EDGE4))THEN IF(JP.GE.NS)THEN PRINT *,' !!!!!! PLASPL WARNING :'// - ' Reached end of separation.' LGSIG=.TRUE. IDIR=-1 ELSE IDIR=+1 ENDIF IL=3 IP=JP+IDIR ELSE C print *,' No interest in changing line.' IP=1+MOD(IP+IDIR-1+NP,NP) ENDIF ELSE C print *,' Staying on curve' IP=1+MOD(IP+IDIR-1+NP,NP) ENDIF * If on intersect, continue on the new plane. ELSEIF(IL.EQ.3)THEN * If crossing plane 1, continue in original direction. IF(IREF(IP,3,1).NE.0)THEN C print *,' Entering plane 1' JP=IREF(IP,3,1) CALL INTERD(NPL2,XPL2,YPL2, - (XL(JP,1)+XL(1+MOD(JP-2+N1,N1),1))/2, - (YL(JP,1)+YL(1+MOD(JP-2+N1,N1),1))/2, - IN1,EDGE1) CALL INTERD(NPL2,XPL2,YPL2, - (XL(JP,1)+XL(1+MOD(JP ,N1),1))/2, - (YL(JP,1)+YL(1+MOD(JP ,N1),1))/2, - IN2,EDGE2) ZAUX1=(DPL1- - APL1*(XL(JP,1)+XL(1+MOD(JP-2+N1,N1),1))/2- - BPL1*(YL(JP,1)+YL(1+MOD(JP-2+N1,N1),1))/2)/ - CPL1 ZAUX2=(DPL2- - APL2*(XL(JP,1)+XL(1+MOD(JP-2+N1,N1),1))/2- - BPL2*(YL(JP,1)+YL(1+MOD(JP-2+N1,N1),1))/2)/ - CPL2 ZAUX3=(DPL1- - APL1*(XL(JP,1)+XL(1+MOD(JP ,N1),1))/2- - BPL1*(YL(JP,1)+YL(1+MOD(JP ,N1),1))/2)/ - CPL1 ZAUX4=(DPL2- - APL2*(XL(JP,1)+XL(1+MOD(JP ,N1),1))/2- - BPL2*(YL(JP,1)+YL(1+MOD(JP ,N1),1))/2)/ - CPL2 IF(.NOT.(IN1.OR.EDGE1))THEN IDIR=-1 ELSEIF(.NOT.(IN2.OR.EDGE2))THEN IDIR=+1 ELSEIF(ZAUX1.GT.ZAUX2)THEN IDIR=-1 ELSEIF(ZAUX3.GT.ZAUX4)THEN IDIR=+1 ELSE C print *,' Resuming plane 1 in old direction.' IDIR=INITD ENDIF IL=1 IP=1+MOD(JP+IDIR-1+N1,N1) ELSEIF(IREF(IP,3,2).NE.0)THEN JP=IREF(IP,3,2) IL=2 PRINT *,' !!!!!! PLASPL WARNING : Entered plane'// - ' 2.' LGSIG=.TRUE. ZAUX1=(DPL1- - APL1*0.5*(XL(JP,IL)+XL(1+MOD(JP,N2),IL))- - BPL1*0.5*(YL(JP,IL)+YL(1+MOD(JP,N2),IL)))/ - CPL1 ZAUX2=(DPL2- - APL2*0.5*(XL(JP,IL)+XL(1+MOD(JP,N2),IL))- - BPL2*0.5*(YL(JP,IL)+YL(1+MOD(JP,N2),IL)))/ - CPL2 ZAUX3=(DPL1- - APL1*0.5*(XL(JP,IL)+ - XL(1+MOD(JP-2+N2,N2),IL))- - BPL1*0.5*(YL(JP,IL)+ - YL(1+MOD(JP-2+N2,N2),IL)))/CPL1 ZAUX4=(DPL2- - APL2*0.5*(XL(JP,IL)+ - XL(1+MOD(JP-2+N2,N2),IL))- - BPL2*0.5*(YL(JP,IL)+ - YL(1+MOD(JP-2+N2,N2),IL)))/CPL2 IF(ZAUX2.GT.ZAUX1)THEN IDIR=+1 ELSEIF(ZAUX4.GT.ZAUX3)THEN IDIR=-1 ENDIF IP=1+MOD(JP+IDIR-1+N2,N2) ELSE PRINT *,' !!!!!! PLASPL WARNING : No connection'// - ' found.' LGSIG=.TRUE. IP=1+MOD(JP+IDIR-1+NP,NP) ENDIF * Move in the direction in which the line visible. ENDIF ** Anything else. ELSE PRINT *,' !!!!!! PLASPL WARNING : Unknown type for a'// - ' point; skipped.' IP=1+MOD(IP+IDIR-1+NP,NP) ENDIF *** Resume the loop. GOTO 430 *** And process cut-outs, pieces of 2 sticking out above the plane. 1000 CONTINUE ** Loop over the planes that were produced. DO 1010 IR=1,NREF IF(IREFO(IR).LE.0)GOTO 1010 CALL PLABU2('READ',IREFO(IR),NPL,XPL,YPL,ZPL, - APL1,BPL1,CPL1,DPL1,ICOL1,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! PLASPL WARNING : Unable to retrieve a'// - ' plane ; not checked for cut-outs.' GOTO 1010 ENDIF * Find a first vertex sticking out. DO 710 I=1,N2 IF(IT(I,2).NE.1)GOTO 710 CALL INTERD(NPL,XPL,YPL,XL(I,2),YL(I,2),INSIDE,EDGE) IF(INSIDE.AND.(.NOT.EDGE).AND. - ZL(I,2).GT.(DPL1-APL1*XL(I,2)-BPL1*YL(I,2))/CPL1)THEN IP=I IL=2 NCUT=0 C print *,' Found a vertex sticking out IP/IL=',ip,il C print *,' xyz: ',xl(i,2),yl(i,2),zl(i,2) C print *,' offset: ',(dpl1-apl1*xl(i,2)-bpl1*yl(i,2))/cpl1 ** Trace the curve from here. START=.TRUE. 720 CONTINUE * See whether the loop is closed. IF(.NOT.START.AND. - ABS(XL(IP,IL)-XCUT(1)).LT.EPSX.AND. - ABS(YL(IP,IL)-YCUT(1)).LT.EPSY)THEN IF(NCUT.LT.3)THEN C print *,' Loop closed, not long enough' GOTO 710 ELSE C print *,' Loop closed, length=',ncut GOTO 730 ENDIF ENDIF START=.FALSE. * Add the current point. IF(NCUT+1.LE.MXCORN)THEN NCUT=NCUT+1 XCUT(NCUT)=XL(IP,IL) YCUT(NCUT)=YL(IP,IL) ZCUT(NCUT)=(DPL1-APL1*XL(IP,IL)-BPL1*YL(IP,IL))/CPL1 ELSE PRINT *,' !!!!!! PLASPL WARNING : Cut-out too long'// - ' ; truncated.' C print *,' Length=',ncut GOTO 730 ENDIF * Ensure there is no link with plane 1. IF(IREF(IP,IL,1).NE.0)THEN C print *,' Linked with 1, abandoned' GOTO 710 * See whether this is a vertex of 2. ELSEIF(IL.EQ.2.AND.IT(IP,IL).EQ.1)THEN C print *,' Vertex IP/IL=',IP,IL CALL INTERD(NPL,XPL,YPL,XL(IP,IL),YL(IP,IL), - INSIDE,EDGE) IF((.NOT.INSIDE).OR.EDGE.OR.ZL(IP,IL).LT. - (DPL1-APL1*XL(IP,IL)-BPL1*YL(IP,IL))/CPL1)THEN C print *,' - Not useable, abandoned.' GOTO 710 ENDIF IP=1+MOD(IP,N2) * See whether this is an intersect with the separation. ELSEIF(IL.EQ.2.AND.IT(IP,IL).EQ.4)THEN C print *,' Intersect with separation IP/IL=',IP,IL JP=IREF(IP,2,3) CALL INTERD(N2,XL(1,2),YL(1,2), - (XL(JP,3)+XL(1+MOD(JP ,NS),3))/2, - (YL(JP,3)+YL(1+MOD(JP ,NS),3))/2,IN1,EDGE1) CALL INTERD(N2,XL(1,2),YL(1,2), - (XL(JP,3)+XL(1+MOD(JP-2+NS,NS),3))/2, - (YL(JP,3)+YL(1+MOD(JP-2+NS,NS),3))/2,IN2,EDGE2) IF(JP.LE.1.AND..NOT.(IN1.OR.EDGE1))THEN C print *,' - Lost trace on separation' GOTO 710 ELSEIF(JP.LE.1)THEN IP=2 IL=3 ELSEIF(JP.GE.NS.AND..NOT.(IN2.OR.EDGE2))THEN C print *,' - Lost trace on separation' GOTO 710 ELSEIF(JP.GE.NS)THEN IP=NS-1 IL=3 ELSEIF(IN1.OR.EDGE1)THEN IP=JP+1 IL=3 ELSEIF(IN2.OR.EDGE2)THEN IP=JP-1 IL=3 ELSE C print *,' - No way out.' GOTO 710 ENDIF * See whether the intersect crosses plane 2 here. ELSEIF(IL.EQ.3.AND.(IT(IP,IL).EQ.4.OR.IT(IP,IL).EQ.2))THEN C print *,' Crossing 2' JP=1+MOD(IREF(IP,3,2),N2) CALL INTERD(NPL,XPL,YPL,XL(JP,2),YL(JP,2),INSIDE,EDGE) IF(IREF(IP,3,2).EQ.0.OR. - (.NOT.INSIDE).OR.EDGE.OR.ZL(JP,2).LT. - (DPL1-APL1*XL(JP,2)-BPL1*YL(JP,2))/CPL1)THEN C print *,' - Not useable, abandoned.' GOTO 710 ELSE IP=JP IL=2 ENDIF * Other cases should not occur. ELSE PRINT *,' !!!!!! PLASPL WARNING : Unknown cut-out'// - ' case seen.' LGSIG=.TRUE. ENDIF * Make another step. GOTO 720 ENDIF 710 CONTINUE * End of vertex loop. GOTO 1010 * Check number of points. 730 CONTINUE C print *,' Genuine cut-out:' C call gsplci(9) C call gsln(1) C call gpl2(ncut,xcut,ycut) C call gspmci(9) C call gsmk(5) ** Find a place where we can connect cutout and curve. DO 770 K=1,NPL-1 DO 740 J=1,NCUT * Check for intersects with the visible parts of curve 2. DO 760 I=1,N2 IF( (ABS(XCUT(1+MOD(J-1,NCUT))-XL(1+MOD(I-1,N2),2)).GT.EPSX.OR. - ABS(YCUT(1+MOD(J-1,NCUT))-YL(1+MOD(I-1,N2),2)).GT.EPSY).AND. - (ABS(XCUT(1+MOD(J-1,NCUT))-XL(1+MOD(I ,N2),2)).GT.EPSX.OR. - ABS(YCUT(1+MOD(J-1,NCUT))-YL(1+MOD(I ,N2),2)).GT.EPSY).AND. - CROSSD( - XPL (K ),YPL (K ), - XCUT(1+MOD(J-1,NCUT)),YCUT(1+MOD(J-1,NCUT)), - XL (1+MOD(I-1,N2),2),YL (1+MOD(I-1,N2),2), - XL (1+MOD(I ,N2),2),YL (1+MOD(I ,N2),2)))GOTO 740 IF( (ABS(XCUT(1+MOD(J-1,NCUT))-XL(1+MOD(I-1,N2),2)).GT.EPSX.OR. - ABS(YCUT(1+MOD(J-1,NCUT))-YL(1+MOD(I-1,N2),2)).GT.EPSY).AND. - ONLIND( - XPL (K ),YPL (K ), - XCUT(1+MOD(J-1,NCUT)),YCUT(1+MOD(J-1,NCUT)), - XL (1+MOD(I-1,N2),2),YL (1+MOD(I-1,N2),2)))GOTO 740 IF( (ABS(XCUT(1+MOD(J ,NCUT))-XL(1+MOD(I-1,N2),2)).GT.EPSX.OR. - ABS(YCUT(1+MOD(J ,NCUT))-YL(1+MOD(I-1,N2),2)).GT.EPSY).AND. - (ABS(XCUT(1+MOD(J ,NCUT))-XL(1+MOD(I ,N2),2)).GT.EPSX.OR. - ABS(YCUT(1+MOD(J ,NCUT))-YL(1+MOD(I ,N2),2)).GT.EPSY).AND. - CROSSD( - XPL (K+1 ),YPL (K+1 ), - XCUT(1+MOD(J ,NCUT)),YCUT(1+MOD(J ,NCUT)), - XL (1+MOD(I-1,N2),2),YL (1+MOD(I-1,N2),2), - XL (1+MOD(I ,N2),2),YL (1+MOD(I ,N2),2)))GOTO 740 IF( (ABS(XCUT(1+MOD(J ,NCUT))-XL(1+MOD(I-1,N2),2)).GT.EPSX.OR. - ABS(YCUT(1+MOD(J ,NCUT))-YL(1+MOD(I-1,N2),2)).GT.EPSY).AND. - ONLIND( - XPL (K+1 ),YPL (K+1 ), - XCUT(1+MOD(J ,NCUT)),YCUT(1+MOD(J ,NCUT)), - XL (1+MOD(I-1,N2),2),YL (1+MOD(I-1,N2),2)))GOTO 740 760 CONTINUE * Check for intersects with the cut-out. DO 755 I=1,NCUT IF( 1+MOD(J-1,NCUT).NE.1+MOD(I-1,NCUT).AND. - 1+MOD(J-1,NCUT).NE.1+MOD(I ,NCUT).AND. - CROSSD( - XPL (K ),YPL (K ), - XCUT(1+MOD(J-1,NCUT)),YCUT(1+MOD(J-1,NCUT)), - XCUT(1+MOD(I-1,NCUT)),YCUT(1+MOD(I-1,NCUT)), - XCUT(1+MOD(I ,NCUT)),YCUT(1+MOD(I ,NCUT))))GOTO 740 IF( 1+MOD(J-1,NCUT).NE.1+MOD(I-1,NCUT).AND. - ONLIND( - XPL (K ),YPL (K ), - XCUT(1+MOD(J-1,NCUT)),YCUT(1+MOD(J-1,NCUT)), - XCUT(1+MOD(I-1,NCUT)),YCUT(1+MOD(I-1,NCUT))))GOTO 740 IF( 1+MOD(J ,NCUT).NE.1+MOD(I-1,NCUT).AND. - 1+MOD(J ,NCUT).NE.1+MOD(I ,NCUT).AND. - CROSSD( - XPL (K+1 ),YPL (K+1 ), - XCUT(1+MOD(J ,NCUT)),YCUT(1+MOD(J ,NCUT)), - XCUT(1+MOD(I-1,NCUT)),YCUT(1+MOD(I-1,NCUT)), - XCUT(1+MOD(I ,NCUT)),YCUT(1+MOD(I ,NCUT))))GOTO 740 IF( 1+MOD(J ,NCUT).NE.1+MOD(I-1,NCUT).AND. - ONLIND( - XPL (K+1 ),YPL (K+1 ), - XCUT(1+MOD(J ,NCUT)),YCUT(1+MOD(J ,NCUT)), - XCUT(1+MOD(I-1,NCUT)),YCUT(1+MOD(I-1,NCUT))))GOTO 740 755 CONTINUE * Check for intersects with the curve. DO 750 I=1,NPL IF( K .NE.1+MOD(I-1,NPL).AND. - K .NE.1+MOD(I ,NPL).AND. - CROSSD( - XPL (K ),YPL (K ), - XCUT(1+MOD(J-1,NCUT)),YCUT(1+MOD(J-1,NCUT)), - XPL (1+MOD(I-1,NPL )),YPL (1+MOD(I-1,NPL )), - XPL (1+MOD(I ,NPL )),YPL (1+MOD(I ,NPL ))))GOTO 740 IF( K .NE.1+MOD(I-1,NPL).AND. - ONLIND( - XPL (K ),YPL (K ), - XCUT(1+MOD(J-1,NCUT)),YCUT(1+MOD(J-1,NCUT)), - XPL (1+MOD(I-1,NPL )),YPL (1+MOD(I-1,NPL ))))GOTO 740 IF( K+1.NE.1+MOD(I-1,NPL).AND. - K+1.NE.1+MOD(I ,NPL).AND. - CROSSD( - XPL (K+1 ),YPL (K+1 ), - XCUT(1+MOD(J ,NCUT)),YCUT(1+MOD(J ,NCUT)), - XPL (1+MOD(I-1,NPL )),YPL (1+MOD(I-1,NPL )), - XPL (1+MOD(I ,NPL )),YPL (1+MOD(I ,NPL ))))GOTO 740 IF( K+1.NE.1+MOD(I-1,NPL).AND. - ONLIND( - XPL (K+1 ),YPL (K+1 ), - XCUT(1+MOD(J ,NCUT)),YCUT(1+MOD(J ,NCUT)), - XPL (1+MOD(I-1,NPL )),YPL (1+MOD(I-1,NPL ))))GOTO 740 750 CONTINUE * Found a pair. K0=K K1=K+1 C call gspmci(1) C call gsmk(4) C call gpm2(1,xpl(k0),ypl(k0)) C call gpm2(1,xpl(k1),ypl(k1)) C print *,' Point 0 on curve: ',k0,xpl(k0),ypl(k0) C print *,' Point 1 on curve: ',k1,xpl(k1),ypl(k1) C print *,' (Range: ',1,npl,')' J0=1+MOD(J-1,NCUT) J1=1+MOD(J ,NCUT) C call gsmk(2) C call gpm2(1,xcut(j0),ycut(j0)) C call gpm2(1,xcut(j1),ycut(j1)) C print *,' Point 0 on cutout: ',j0,xcut(j0),ycut(j0) C print *,' Point 1 on cutout: ',j1,xcut(j1),ycut(j1) C print *,' (Range: ',1,ncut,')' GOTO 780 * Continue loops. 740 CONTINUE 770 CONTINUE * No connection found. PRINT *,' !!!!!! PLASPL WARNING : Can''t connect cut-out'// - ' to outer plane ; cut-out ignored.' GOTO 1010 ** Constract the 2 halves and store separately. 780 CONTINUE * See whether we have memory for this at all. IF(NCUT+NPL.GT.MXEDGE.OR.NREF+2.GT.MXPLAN)THEN PRINT *,' !!!!!! PLASPL WARNING : Lack of reference space'// - ' or list length for cut-out.' GOTO 1010 ENDIF * See whether the junction lines cross. IF(CROSSD(XPL(K0),YPL(K0),XCUT(J0),YCUT(J0), - XPL(K1),YPL(K1),XCUT(J1),YCUT(J1)))THEN IAUX=J1 J1=J0 J0=IAUX C print *,' Interchanging J0/J1' ENDIF * First make the small 4-point loop. XPL1(1)=XPL(K0) YPL1(1)=YPL(K0) ZPL1(1)=ZPL(K0) XPL1(2)=XCUT(J0) YPL1(2)=YCUT(J0) ZPL1(2)=(DPL1-APL1*XCUT(J0)-BPL1*YCUT(J0))/CPL1 XPL1(3)=XCUT(J1) YPL1(3)=YCUT(J1) ZPL1(3)=(DPL1-APL1*XCUT(J1)-BPL1*YCUT(J1))/CPL1 XPL1(4)=XPL(K1) YPL1(4)=YPL(K1) ZPL1(4)=ZPL(K1) NPL1=4 * Test to see whether this includes a point of the cut-out. SWAP=.FALSE. DO 820 I=1,NCUT IF(I.EQ.J0.OR.I.EQ.J1)GOTO 820 CALL INTERD(NPL1,XPL1,YPL1,XCUT(I),YCUT(I),INSIDE,EDGE) IF(INSIDE.OR.EDGE)SWAP=.TRUE. 820 CONTINUE C if(swap)print *,' Found an internal point of cut-out.' * If there was, select the other branch. IF(SWAP)THEN XPL1(1)=XPL(K0) YPL1(1)=YPL(K0) ZPL1(1)=ZPL(K0) IF(MOD(J0-J1+NCUT,NCUT).EQ.+1)THEN DO 830 J=J0,J1+NCUT XPL1(1+J-J0+1)=XCUT(1+MOD(J-1,NCUT)) YPL1(1+J-J0+1)=YCUT(1+MOD(J-1,NCUT)) ZPL1(1+J-J0+1)=(DPL1-APL1*XPL1(1+J-J0+1)- - BPL1*YPL1(1+J-J0+1))/CPL1 830 CONTINUE ELSE DO 840 J=J0,J1-NCUT,-1 XPL1(1+J0-J+1)=XCUT(1+MOD(J-1+NCUT,NCUT)) YPL1(1+J0-J+1)=YCUT(1+MOD(J-1+NCUT,NCUT)) ZPL1(1+J0-J+1)=(DPL1-APL1*XPL1(1+J0-J+1)- - BPL1*YPL1(1+J0-J+1))/CPL1 840 CONTINUE ENDIF XPL1(NCUT+2)=XPL(K1) YPL1(NCUT+2)=YPL(K1) ZPL1(NCUT+2)=ZPL(K1) NPL1=NCUT+2 ENDIF C call gsln(1) C call gsplci(8) C call gpl2(npl1,xpl1,ypl1) * Store this part of the curve. CALL PLARED(NPL1,XPL1,YPL1,ZPL1,APL1,BPL1,CPL1,DPL1) IF(NPL1.GE.3)THEN NREF=NREF+1 CALL PLABU2('STORE',IREFO(NREF),NPL1,XPL1,YPL1,ZPL1, - APL1,BPL1,CPL1,DPL1,ICOL1,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! PLASPL WARNING : Unable to store'// - ' small half of a split plane.' NREF=NREF-1 ENDIF ENDIF * Now make the large loop. IF(SWAP)THEN XPL2(1)=XCUT(J1) YPL2(1)=YCUT(J1) ZPL2(1)=(DPL1-APL1*XPL2(1)-BPL1*YPL2(1))/CPL1 XPL2(2)=XCUT(J0) YPL2(2)=YCUT(J0) ZPL2(2)=(DPL1-APL1*XPL2(2)-BPL1*YPL2(2))/CPL1 NPL2=2 ELSEIF(MOD(J1-J0+NCUT,NCUT).EQ.+1)THEN DO 790 J=J1,J0+NCUT XPL2(J-J1+1)=XCUT(1+MOD(J-1,NCUT)) YPL2(J-J1+1)=YCUT(1+MOD(J-1,NCUT)) ZPL2(J-J1+1)=(DPL1-APL1*XPL2(J-J1+1)- - BPL1*YPL2(J-J1+1))/CPL1 790 CONTINUE NPL2=NCUT ELSE DO 810 J=J1,J0-NCUT,-1 XPL2(J1-J+1)=XCUT(1+MOD(J-1+NCUT,NCUT)) YPL2(J1-J+1)=YCUT(1+MOD(J-1+NCUT,NCUT)) ZPL2(J1-J+1)=(DPL1-APL1*XPL2(J1-J+1)- - BPL1*YPL2(J1-J+1))/CPL1 810 CONTINUE NPL2=NCUT ENDIF DO 800 K=K0+NPL,K1,-1 XPL2(NPL2+K0+NPL-K+1)=XPL(1+MOD(K-1,NPL)) YPL2(NPL2+K0+NPL-K+1)=YPL(1+MOD(K-1,NPL)) ZPL2(NPL2+K0+NPL-K+1)=ZPL(1+MOD(K-1,NPL)) 800 CONTINUE NPL2=NPL2+NPL C call gsln(1) C call gsplci(12) C call gpl2(npl2,xpl2,ypl2) * Store this part of the curve. CALL PLARED(NPL2,XPL2,YPL2,ZPL2,APL1,BPL1,CPL1,DPL1) IF(NPL2.GE.3)THEN NREF=NREF+1 CALL PLABU2('STORE',IREFO(NREF),NPL2,XPL2,YPL2,ZPL2, - APL1,BPL1,CPL1,DPL1,ICOL1,IFAIL2) IF(IFAIL2.NE.0)THEN PRINT *,' !!!!!! PLASPL WARNING : Unable to store'// - ' large half of a split plane.' NREF=NREF-1 ENDIF ENDIF C call guwk(1,0) C read *,iaux ** Delete original plane and start from scratch. CALL PLABU2('DELETE',IREFO(IR),NPL1,XPL1,YPL1,ZPL1, - APL1,BPL1,CPL1,DPL1,ICOL1,IFAIL1) IREFO(IR)=0 GOTO 1000 ** Continue with next plane. 1010 CONTINUE *** Seems to have worked. IFAIL=0 END +DECK,PLASRP. SUBROUTINE PLASRP *----------------------------------------------------------------------- * PLASRP - Cuts the current set of planes to avoid overlaps and sorts * them for plotting, version for 3D impressions. * (Last changed on 26/10/07.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PARAMETERS. +SEQ,PRINTPLOT. +SEQ,SOLIDS. INTEGER NPL1,NPL2,IVOL1,ICOL1,ICOL2,IFAIL1,IFAIL2, - I,J,K,L,NREF,NFIRST,NLAST,NNLAST, - IREF,IREFL(2*MXPLAN),IREFO(MXPLAN),NPLAN1,NPLAN2 DOUBLE PRECISION XPL1(MXEDGE),YPL1(MXEDGE),ZPL1(MXEDGE), - XPL2(MXEDGE),YPL2(MXEDGE),ZPL2(MXEDGE), - APL1,BPL1,CPL1,DPL1,APL2,BPL2,CPL2,DPL2, - XCUT,YCUT,ZCUT,XEMIN,XEMAX,YEMIN,YEMAX,ZEMIN,ZEMAX C DOUBLE PRECISION VEC(3),FNORM LOGICAL PLAGT,KEEP,MARK(2*MXPLAN) EXTERNAL PLAGT *** Identification output. IF(LIDENT)PRINT *,' /// ROUTINE PLASRP ///' *** Set the tolerances. CALL PLACO3(GXMIN,GYMIN,GZMIN,XCUT,YCUT,ZCUT) XEMIN=XCUT YEMIN=YCUT ZEMIN=ZCUT XEMAX=XCUT YEMAX=YCUT ZEMAX=ZCUT CALL PLACO3(GXMIN,GYMIN,GZMAX,XCUT,YCUT,ZCUT) IF(XCUT.LT.XEMIN)XEMIN=XCUT IF(XCUT.GT.XEMAX)XEMAX=XCUT IF(YCUT.LT.YEMIN)YEMIN=YCUT IF(YCUT.GT.YEMAX)YEMAX=YCUT IF(ZCUT.LT.ZEMIN)ZEMIN=ZCUT IF(ZCUT.GT.ZEMAX)ZEMAX=ZCUT CALL PLACO3(GXMIN,GYMAX,GZMIN,XCUT,YCUT,ZCUT) IF(XCUT.LT.XEMIN)XEMIN=XCUT IF(XCUT.GT.XEMAX)XEMAX=XCUT IF(YCUT.LT.YEMIN)YEMIN=YCUT IF(YCUT.GT.YEMAX)YEMAX=YCUT IF(ZCUT.LT.ZEMIN)ZEMIN=ZCUT IF(ZCUT.GT.ZEMAX)ZEMAX=ZCUT CALL PLACO3(GXMIN,GYMAX,GZMAX,XCUT,YCUT,ZCUT) IF(XCUT.LT.XEMIN)XEMIN=XCUT IF(XCUT.GT.XEMAX)XEMAX=XCUT IF(YCUT.LT.YEMIN)YEMIN=YCUT IF(YCUT.GT.YEMAX)YEMAX=YCUT IF(ZCUT.LT.ZEMIN)ZEMIN=ZCUT IF(ZCUT.GT.ZEMAX)ZEMAX=ZCUT CALL PLACO3(GXMAX,GYMIN,GZMIN,XCUT,YCUT,ZCUT) IF(XCUT.LT.XEMIN)XEMIN=XCUT IF(XCUT.GT.XEMAX)XEMAX=XCUT IF(YCUT.LT.YEMIN)YEMIN=YCUT IF(YCUT.GT.YEMAX)YEMAX=YCUT IF(ZCUT.LT.ZEMIN)ZEMIN=ZCUT IF(ZCUT.GT.ZEMAX)ZEMAX=ZCUT CALL PLACO3(GXMAX,GYMIN,GZMAX,XCUT,YCUT,ZCUT) IF(XCUT.LT.XEMIN)XEMIN=XCUT IF(XCUT.GT.XEMAX)XEMAX=XCUT IF(YCUT.LT.YEMIN)YEMIN=YCUT IF(YCUT.GT.YEMAX)YEMAX=YCUT IF(ZCUT.LT.ZEMIN)ZEMIN=ZCUT IF(ZCUT.GT.ZEMAX)ZEMAX=ZCUT CALL PLACO3(GXMAX,GYMAX,GZMIN,XCUT,YCUT,ZCUT) IF(XCUT.LT.XEMIN)XEMIN=XCUT IF(XCUT.GT.XEMAX)XEMAX=XCUT IF(YCUT.LT.YEMIN)YEMIN=YCUT IF(YCUT.GT.YEMAX)YEMAX=YCUT IF(ZCUT.LT.ZEMIN)ZEMIN=ZCUT IF(ZCUT.GT.ZEMAX)ZEMAX=ZCUT CALL PLACO3(GXMAX,GYMAX,GZMAX,XCUT,YCUT,ZCUT) IF(XCUT.LT.XEMIN)XEMIN=XCUT IF(XCUT.GT.XEMAX)XEMAX=XCUT IF(YCUT.LT.YEMIN)YEMIN=YCUT IF(YCUT.GT.YEMAX)YEMAX=YCUT IF(ZCUT.LT.ZEMIN)ZEMIN=ZCUT IF(ZCUT.GT.ZEMAX)ZEMAX=ZCUT CALL EPSSET('SET',1D-7*(XEMAX-XEMIN),1D-7*(YEMAX-YEMIN), - 1D-7*(ZEMAX-ZEMIN)) *** Progress printing. CALL PROFLD(1,'Counting planes',-1.0) CALL PROSTA(1,0.0) *** Find out how many planes are in store. CALL PLABU1('QUERY',NPLAN1,NPL1,XPL1,YPL1,ZPL1,APL1,BPL1,CPL1, - ICOL1,IVOL1,IFAIL1) IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLASRP DEBUG : Found '', - I5,'' geometric panels.'')') NPLAN1 *** Reset the plot-plane buffer. CALL PROFLD(1,'Projecting planes',REAL(NPLAN1)) CALL PLABU2('RESET',IREF,NPL1,XPL2,YPL2,ZPL2, - APL1,BPL1,CPL1,DPL1,ICOL1,IFAIL2) *** Project the planes. NPLAN2=0 DO 10 I=1,NPLAN1 CALL PROSTA(1,REAL(I)) * Read plane. CALL PLABU1('READ',I,NPL1,XPL1,YPL1,ZPL1,APL1,BPL1,CPL1,ICOL1, - IVOL1,IFAIL1) * Skip empty and deleted planes. IF(IFAIL1.NE.0.OR.NPL1.LT.3)GOTO 10 * Ensure that the plane is visible. IF(APL1*FPROJA+BPL1*FPROJB+CPL1*FPROJC.LT. - 1D-6*SQRT((APL1**2+BPL1**2+CPL1**2)* - (FPROJA**2+FPROJB**2+FPROJC**2)))THEN GOTO 10 ENDIF * Project points, adjusting to box dimensions, also compute offset. C IF(IVOL1.GT.0)THEN CALL PLAPOL(GXMIN,GYMIN,GZMIN,GXMAX,GYMAX,GZMAX, - XPL1,YPL1,ZPL1,NPL1,APL1,BPL1,CPL1,XPL2,YPL2,ZPL2,NPL2) C ELSE C DO 30 J=1,NPL1 C CALL PLACO3(XPL1(J),YPL1(J),ZPL1(J),XPL2(J),YPL2(J),ZPL2(J)) C30 CONTINUE C NPL2=NPL1 C ENDIF * Verify the resulting plane. CALL PLACHK(NPL2,XPL2,YPL2,ZPL2,IFAIL2) IF(IFAIL2.NE.0)GOTO 10 * Compute the norm vector of the projected plane and re-check. C VEC(1)=APL1 C VEC(2)=BPL1 C VEC(3)=CPL1 C CALL DFEQN(3,FPRMAT,3,IPRMAT,1,VEC) C FNORM=SQRT(VEC(1)**2+VEC(2)**2+VEC(3)**2) C IF(FNORM.LE.0.OR.NPL2.LE.2)THEN C PRINT *,' !!!!!! PLASRP WARNING : Unable to project a'// C - ' panel; panel skipped.' C GOTO 10 C ENDIF C APL2=VEC(1)/FNORM C BPL2=VEC(2)/FNORM C CPL2=VEC(3)/FNORM C DPL2=0 C DO 20 J=1,NPL2 C DPL2=DPL2+APL2*XPL2(J)+BPL2*YPL2(J)+CPL2*ZPL2(J) C20 CONTINUE C DPL2=DPL2/NPL2 CALL PLANOR(NPL2,XPL2,YPL2,ZPL2,APL2,BPL2,CPL2,DPL2,IFAIL2) IF(IFAIL2.NE.0)THEN PRINT *,' !!!!!! PLASRP WARNING : Unable to project a'// - ' panel; panel skipped.' GOTO 10 ENDIF * Skip planes perpendicular to the view. IF(ABS(CPL2).LT.1.0E-2*SQRT(APL2**2+BPL2**2))GOTO 10 * Store the projected plane. CALL PLABU2('STORE',IREF,NPL2,XPL2,YPL2,ZPL2, - APL2,BPL2,CPL2,DPL2,ICOL1,IFAIL2) IF(IFAIL2.NE.0)THEN PRINT *,' !!!!!! PLASRP WARNING : Storage error for a'// - ' projected plane ; plot likely to be incomplete.' ELSE IF(NPLAN2.GE.2*MXPLAN)GOTO 3010 NPLAN2=NPLAN2+1 IREFL(NPLAN2)=IREF ENDIF 10 CONTINUE * Debugging output. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLASRP DEBUG : Created '', - I5,'' projected planes.'')') NPLAN2 *** Split planes that have hide each other in part. IF(LSPLIT)THEN CALL PROFLD(1,'Cutting overlaps',REAL(NPLAN2)) ** Loop over plane I, which is the one being cut. NFIRST=NPLAN2+1 DO 100 I=1,NPLAN2 * Progress printing. CALL PROSTA(1,REAL(I)) * Set the initial mark value. MARK(I)=.FALSE. * Copy its reference to the end. IREFL(NFIRST)=IREFL(I) * Initialise the counter of planes generated sofar. NLAST=NFIRST ** Loop over plane J, which is the one that cuts. DO 110 J=1,NPLAN2 IF(I.EQ.J)GOTO 110 ** Cut plane I with all other planes. NNLAST=NLAST DO 120 K=NFIRST,NNLAST IF(IREFL(K).EQ.0)GOTO 120 * Perform the actual split. LGSIG=.FALSE. CALL PLASPL(IREFL(K),IREFL(J),NREF,IREFO,KEEP,IFAIL1) * Debugging output and quit when stop flag is set. IF(LGSTOP.AND.LGSIG)THEN PRINT *,' !!!!!! PLASRP WARNING : Separation error'// - ' detected ; generating dump and quitting.' CALL PLABU2('READ',IREFL(K),NPL1,XPL1,YPL1,ZPL1, - APL1,BPL1,CPL1,DPL1,ICOL1,IFAIL1) CALL PLABU2('READ',IREFL(J),NPL2,XPL2,YPL2,ZPL2, - APL2,BPL2,CPL2,DPL2,ICOL2,IFAIL2) OPEN(UNIT=12,FILE='plaspl.dat',STATUS='UNKNOWN') WRITE(12,*) EPSGX,EPSGY,EPSGZ,LEPSG WRITE(12,*) APL1,BPL1,CPL1,DPL1,ICOL1 WRITE(12,*) NPL1 DO 200 L=1,NPL1 WRITE(12,*) XPL1(L),YPL1(L),ZPL1(L) 200 CONTINUE WRITE(12,*) APL2,BPL2,CPL2,DPL2,ICOL2 WRITE(12,*) NPL2 DO 210 L=1,NPL2 WRITE(12,*) XPL2(L),YPL2(L),ZPL2(L) 210 CONTINUE CLOSE(12) CALL QUIT ENDIF * Store the result, delete the original. IF(IFAIL1.EQ.0.AND..NOT.KEEP)THEN IF(IREFL(K).NE.IREFL(I))THEN CALL PLABU2('DELETE',IREFL(K), - NPL1,XPL1,YPL1,ZPL1,APL1,BPL1,CPL1,DPL1, - ICOL1,IFAIL1) ELSE MARK(I)=.TRUE. ENDIF IREFL(K)=0 IF(NREF.EQ.1.AND.IREFO(1).NE.0)THEN IREFL(K)=IREFO(1) ELSE DO 130 L=1,NREF IF(IREFO(L).NE.0)THEN IF(NLAST.GE.2*MXPLAN)GOTO 3010 NLAST=NLAST+1 IREFL(NLAST)=IREFO(L) ENDIF 130 CONTINUE ENDIF ELSEIF(.NOT.KEEP)THEN PRINT *,' !!!!!! PLASRP WARNING : Unable to remove;'// - ' invisible parts ; keeping original.' ENDIF 120 CONTINUE ** Compress the list. NNLAST=NLAST NLAST=NFIRST-1 DO 140 K=NFIRST,NNLAST IF(IREFL(K).EQ.0)GOTO 140 NLAST=NLAST+1 IREFL(NLAST)=IREFL(K) 140 CONTINUE * If there is not a single plane left, stop cutting. IF(NLAST.LT.NFIRST)GOTO 100 ** Next plane that cuts. 110 CONTINUE ** Next plane being cut, update the start of list marker. IF(NLAST.GE.2*MXPLAN)GOTO 3010 NFIRST=NLAST+1 100 CONTINUE ** Remove the original planes. DO 150 I=1,NPLAN2 IF(MARK(I))CALL PLABU2('DELETE',IREFL(I), - NPL1,XPL1,YPL1,ZPL1,APL1,BPL1,CPL1,DPL1,ICOL1,IFAIL1) 150 CONTINUE ENDIF *** Sort the planes so that the backmost plane is plotted first. NQ=0 CALL PROFLD(1,'Counting planes',-1.0) CALL PROSTA(1,0.0) DO 300 I=1,MXPLAN * Read the plane. CALL PLABU2('READ',I,NPL1,XPL1,YPL1,ZPL1,APL1,BPL1,CPL1,DPL1, - ICOL1,IFAIL1) * Skip if deleted or empty. IF(IFAIL1.NE.0.OR.NPL1.LE.2)GOTO 300 * Compute largest offset. NQ=NQ+1 * Store reference. IQ(NQ)=I 300 CONTINUE * Debugging output. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLASRP DEBUG : Created '', - I5,'' visible planes.'')') NQ * Sort the planes. IF(LSORT)THEN CALL PROFLD(1,'Sorting planes',-1.0) CALL PROSTA(1,0.0) CALL BSORT(IQ,NQ,PLAGT) ENDIF RETURN *** Error processing. 3010 CONTINUE PRINT *,' !!!!!! PLASRP WARNING : Removing invisible parts'// - ' generated too many sub-panels ; aborted.' END +DECK,PLASRC. SUBROUTINE PLASRC *----------------------------------------------------------------------- * PLASRC - Prepares the current set of volume cuts for plotting. * version for cut-throughs impressions. * (Last changed on 8/10/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PARAMETERS. +SEQ,SOLIDS. INTEGER NPL,IVOL,ICOL,IFAIL,I,J,IREF,NPLANE,NCUT DOUBLE PRECISION XPL(MXEDGE),YPL(MXEDGE),ZPL(MXEDGE), - APL,BPL,CPL,DPL,VEC(3),FNORM, - XCUT(MXEDGE),YCUT(MXEDGE),ZCUT(MXEDGE) *** Progress printing. CALL PROFLD(1,'Counting planes',-1.0) CALL PROSTA(1,0.0) *** Find out how many planes are in store. CALL PLABU1('QUERY',NPLANE,NPL,XPL,YPL,ZPL,APL,BPL,CPL, - ICOL,IVOL,IFAIL) *** Reset the plot-plane buffer. CALL PROFLD(1,'Copying planes',REAL(NPLANE)) CALL PLABU2('RESET',IREF,NPL,XPL,YPL,ZPL,APL,BPL,CPL,DPL, - ICOL,IFAIL) *** Copy the planes. NQ=0 DO 10 I=1,NPLANE CALL PROSTA(1,REAL(I)) * Read plane. CALL PLABU1('READ',I,NPL,XPL,YPL,ZPL,APL,BPL,CPL,ICOL,IVOL,IFAIL) * Skip empty and deleted planes. IF(IFAIL.NE.0.OR.NPL.LT.3)GOTO 10 * Project points, adjusting to box dimensions. CALL PLAPOL(GXMIN,GYMIN,GZMIN,GXMAX,GYMAX,GZMAX, - XPL,YPL,ZPL,NPL,APL,BPL,CPL,XCUT,YCUT,ZCUT,NCUT) * Verify the resulting plane. CALL PLACHK(NCUT,XCUT,YCUT,ZCUT,IFAIL) IF(IFAIL.NE.0)GOTO 10 * Compute normal vector. VEC(1)=APL VEC(2)=BPL VEC(3)=CPL CALL DFEQN(3,FPRMAT,3,IPRMAT,1,VEC) FNORM=SQRT(VEC(1)**2+VEC(2)**2+VEC(3)**2) IF(FNORM.LE.0.OR.NCUT.LE.2)THEN PRINT *,' !!!!!! PLASRC WARNING : Unable to project a'// - ' panel; panel skipped.' GOTO 10 ENDIF APL=VEC(1)/FNORM BPL=VEC(2)/FNORM CPL=VEC(3)/FNORM DPL=0 DO 20 J=1,NCUT DPL=DPL+APL*XCUT(J)+BPL*YCUT(J)+CPL*ZCUT(J) 20 CONTINUE DPL=DPL/NCUT * Store the projected plane. CALL PLABU2('STORE',IREF,NCUT,XCUT,YCUT,ZCUT,APL,BPL,CPL,DPL, - ICOL,IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! PLASRC WARNING : Storage error for a'// - ' projected plane ; plot likely to be incomplete.' ELSE NQ=NQ+1 IQ(NQ)=IREF ENDIF 10 CONTINUE END +DECK,PLAGT. LOGICAL FUNCTION PLAGT(I1,I2) *----------------------------------------------------------------------- * PLAGT - Determines whick plane partially overlaps the other. * (Last changed on 29/ 9/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PARAMETERS. INTEGER I1,I2,NPL1,NPL2,ICOL1,ICOL2,IFAIL1,IFAIL2,I,J DOUBLE PRECISION XPL1(MXEDGE),YPL1(MXEDGE),ZPL1(MXEDGE), - XPL2(MXEDGE),YPL2(MXEDGE),ZPL2(MXEDGE), - APL1,BPL1,CPL1,DPL1,APL2,BPL2,CPL2,DPL2, - OFFSET,OFF1,OFF2,XC,YC,EPS,ZMAX,ZMIN LOGICAL INSIDE,EDGE,LT12,EQ12,GT12,CROSS *** If the planes are identical, return True. IF(I1.EQ.I2)THEN PLAGT=.TRUE. RETURN ENDIF *** Fetch both planes. CALL PLABU2('READ',I1,NPL1,XPL1,YPL1,ZPL1,APL1,BPL1,CPL1,DPL1, - ICOL1,IFAIL1) CALL PLABU2('READ',I2,NPL2,XPL2,YPL2,ZPL2,APL2,BPL2,CPL2,DPL2, - ICOL2,IFAIL2) IF(IFAIL1.NE.0.OR.IFAIL2.NE.0.OR.NPL1.LE.2.OR.NPL2.LE.2)THEN PRINT *,' !!!!!! PLAGT WARNING : Error fetching a plane'// - ' ; overlap set to False.' PLAGT=.FALSE. RETURN ENDIF *** Compute and epsilon for equality comparisons. IF(LEPSG)THEN EPS=EPSGZ ELSE ZMIN=ZPL1(1) ZMAX=ZPL1(1) DO 50 I=2,NPL1 ZMIN=MIN(ZMIN,ZPL1(I)) ZMAX=MAX(ZMAX,ZPL1(I)) 50 CONTINUE DO 60 I=1,NPL2 ZMIN=MIN(ZMIN,ZPL2(I)) ZMAX=MAX(ZMAX,ZPL2(I)) 60 CONTINUE EPS=1.0D-6*ABS(ZMAX-ZMIN) ENDIF *** Check for perpendicular planes. IF(CPL1.EQ.0.OR.CPL2.EQ.0)THEN PLAGT=.FALSE. RETURN ENDIF *** Initial setting of the flags. LT12=.FALSE. EQ12=.FALSE. GT12=.FALSE. *** Find the corners of 1 internal to 2. DO 10 I=1,NPL1 CALL INTERD(NPL2,XPL2,YPL2,XPL1(I),YPL1(I),INSIDE,EDGE) * For these points, compute the offset projected on plane 2. IF(INSIDE.OR.EDGE)THEN OFFSET=(DPL2-APL2*XPL1(I)-BPL2*YPL1(I))/CPL2 IF(ABS(OFFSET-ZPL1(I)).LT.EPS)THEN EQ12=.TRUE. ELSEIF(ZPL1(I).GT.OFFSET)THEN GT12=.TRUE. ELSEIF(ZPL1(I).LT.OFFSET)THEN LT12=.TRUE. ENDIF ENDIF 10 CONTINUE *** Find the corners of 2 internal to 1. DO 20 I=1,NPL2 CALL INTERD(NPL1,XPL1,YPL1,XPL2(I),YPL2(I),INSIDE,EDGE) * For these points, compute the offset projected on plane 1. IF(INSIDE.OR.EDGE)THEN OFFSET=(DPL1-APL1*XPL2(I)-BPL1*YPL2(I))/CPL1 IF(ABS(OFFSET-ZPL2(I)).LT.EPS)THEN EQ12=.TRUE. ELSEIF(OFFSET.GT.ZPL2(I))THEN GT12=.TRUE. ELSEIF(OFFSET.LT.ZPL2(I))THEN LT12=.TRUE. ENDIF ENDIF 20 CONTINUE *** Check for mid-line intersects. DO 30 I=1,NPL1 DO 40 J=1,NPL2 CALL CRSPND( - XPL1(1+MOD(I-1,NPL1)),YPL1(1+MOD(I-1,NPL1)), - XPL1(1+MOD(I ,NPL1)),YPL1(1+MOD(I ,NPL1)), - XPL2(1+MOD(J-1,NPL2)),YPL2(1+MOD(J-1,NPL2)), - XPL2(1+MOD(J ,NPL2)),YPL2(1+MOD(J ,NPL2)), - XC,YC,CROSS) IF(CROSS)THEN OFF1=(DPL1-APL1*XC-BPL1*YC)/CPL1 OFF2=(DPL2-APL2*XC-BPL2*YC)/CPL2 IF(ABS(OFF1-OFF2).LT.EPS)THEN EQ12=.TRUE. ELSEIF(OFF1.GT.OFF2)THEN GT12=.TRUE. ELSEIF(OFF1.LT.OFF2)THEN LT12=.TRUE. ENDIF ENDIF 40 CONTINUE 30 CONTINUE *** Check the final flags. IF(LT12.AND.GT12)THEN PRINT *,' !!!!!! PLAGT WARNING : Planes probably'// - ' intersect ; plot probably incorrect.' PLAGT=.TRUE. ELSEIF(GT12)THEN PLAGT=.TRUE. ELSE PLAGT=.FALSE. ENDIF END +DECK,PLANOR. SUBROUTINE PLANOR(N,X,Y,Z,A,B,C,D,IFAIL) *----------------------------------------------------------------------- * PLANOR - Computes a normal vector to a polygon. * (Last changed on 16/11/02.) *----------------------------------------------------------------------- implicit none INTEGER N,I,J,K,IFAIL DOUBLE PRECISION X(N),Y(N),Z(N),A,B,C,D,AA,BB,CC,FNORM *** Initial settings. A=0 B=0 C=0 *** Check number of points. IF(N.LT.3)THEN PRINT *,' !!!!!! PLANOR WARNING : Insufficient number of'// - ' points to compute a normal vector.' IFAIL=1 RETURN ENDIF *** Loop over all cross products. DO 10 I=1,N DO 20 J=1,N-1 IF(I.EQ.J)GOTO 20 DO 30 K=J+1,N IF(I.EQ.K.OR.J.EQ.K)GOTO 30 AA=(Y(J)-Y(I))*(Z(K)-Z(I))-(Y(K)-Y(I))*(Z(J)-Z(I)) BB=(Z(J)-Z(I))*(X(K)-X(I))-(Z(K)-Z(I))*(X(J)-X(I)) CC=(X(J)-X(I))*(Y(K)-Y(I))-(X(K)-X(I))*(Y(J)-Y(I)) IF( (AA.LT.0.AND.BB.LT.0).OR. - (AA.LT.0.AND.CC.LT.0).OR. - (BB.LT.0.AND.CC.LT.0))THEN A=A-AA B=B-BB C=C-CC ELSE A=A+AA B=B+BB C=C+CC ENDIF 30 CONTINUE 20 CONTINUE 10 CONTINUE *** Normalise the sum. FNORM=A**2+B**2+C**2 IF(FNORM.LE.0)THEN PRINT *,' !!!!!! PLANOR WARNING : Computed normal vector'// - ' has zero norm; probably degenerate curve.' A=0 B=0 C=0 IFAIL=1 ELSE A=A/SQRT(FNORM) B=B/SQRT(FNORM) C=C/SQRT(FNORM) IFAIL=0 ENDIF *** Find the offset. D=0 DO 40 I=1,N D=D+A*X(I)+B*Y(I)+C*Z(I) 40 CONTINUE D=D/N END +DECK,PLAPLT. SUBROUTINE PLAPLT *----------------------------------------------------------------------- * PLAPLT - Plots the current set of planes. * (Last changed on 11/10/11.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,SOLIDS. +SEQ,PARAMETERS. +SEQ,PRINTPLOT. DOUBLE PRECISION XPL(MXEDGE+1),YPL(MXEDGE+1),ZPL(MXEDGE+1), - APL,BPL,CPL,DPL INTEGER I,J,IVOL,ICOL,IFAIL,NPL,NWORD,INPCMP,NCSTR CHARACTER*20 STR EXTERNAL INPCMP *** Identification. IF(LIDENT)PRINT *,' /// ROUTINE PLAPLT ///' *** Open a segment so that we can later on pick out the wires. C CALL GCRSG(1) *** Make the solids detectable. C CALL GSDTEC(1,1) *** Plot the panels, prepare for requesting input if needed. IF(LGSTEP)THEN WRITE(LUNOUT,'('' Showing the '',I4,'' panels one at'', - '' the time, hit return or SHOW to proceed.'')') NQ CALL INPSWI('TERMINAL') ENDIF * Loop over the panels. DO 10 I=1,NQ * Read the panel. CALL PLABU2('READ',IQ(I),NPL,XPL,YPL,ZPL,APL,BPL,CPL,DPL, - ICOL,IFAIL) IF(IFAIL.NE.0.OR.NPL.LE.2)GOTO 10 * Set a pick identifier for each solid separately. C CALL GSPKID(IVOL) * Set the representations. IF(ICOL.GE.50.AND.ICOL.LT.50+NPRCOL)THEN CALL GRATTS('CONDUCTORS-1','AREA') ELSE CALL GRATTS('DIELECTRIC-1','AREA') ENDIF * Set the colour. CALL GSFACI(ICOL) CALL GSPLCI(ICOL) * Add the last point to make a complete loop. NPL=NPL+1 XPL(NPL)=XPL(1) YPL(NPL)=YPL(1) ZPL(NPL)=ZPL(1) * Plot the area. CALL GFA2(NPL,XPL,YPL) CALL GPL2(NPL,XPL,YPL) * Debugging. IF(LGSTEP)THEN CALL GUWK(1,0) CALL OUTFMT(REAL(I),2,STR,NCSTR,'LEFT') CALL INPPRM('Panel '//STR(1:NCSTR),'ADD-NOPRINT') CALL INPWRD(NWORD) CALL INPPRM(' ','BACK-PRINT') IF(NWORD.EQ.1.AND.INPCMP(1,'S#HOW')+ - INPCMP(1,'Y#ES').NE.0)THEN WRITE(LUNOUT,'('' Panel '',I3,'': reference='',I4, - '', colour='',I3,'', edges='',I3// - 11X,''x'',13X,''y'',13X,''z'')') I,IQ(I),ICOL,NPL DO 20 J=1,NPL WRITE(LUNOUT,'(3(2X,F12.5))') XPL(J),YPL(J),ZPL(J) 20 CONTINUE ELSEIF(NWORD.NE.0)THEN PRINT *,' !!!!!! PLAPLT WARNING : Unknown response ;'// - ' not showing details.' ENDIF ENDIF 10 CONTINUE * Restore input. IF(LGSTEP)CALL INPSWI('RESTORE') *** Close the segment for the solids. C CALL GCLSG *** Optionally also plot the outline. IF(LOUTL)THEN * Set the representation. CALL GRATTS('OUTLINE','POLYLINE') DO 1010 IVOL=1,NSOLID * cylinders ... IF(ISOLTP(IVOL).EQ.1)THEN C CALL PLACYO(IVOL) * cylindrical holes ... ELSEIF(ISOLTP(IVOL).EQ.2)THEN CALL PLACHO(IVOL) * boxes ... ELSEIF(ISOLTP(IVOL).EQ.3)THEN CALL PLABXO(IVOL) * spheres ... ELSEIF(ISOLTP(IVOL).EQ.4)THEN C CALL PLASPO(IVOL) * Toblerone ... ELSEIF(ISOLTP(IVOL).EQ.5)THEN CALL PLATBO(IVOL) * Extrusion ... ELSEIF(ISOLTP(IVOL).EQ.6)THEN C CALL PLAEXO(IVOL) * other things not known. ELSE PRINT *,' !!!!!! PLAPLT WARNING : Asked to plot an'// - ' outline of unknown type ',ISOLTP(IVOL), - '; not plotted.' ENDIF 1010 CONTINUE ENDIF END +DECK,PLALAM. SUBROUTINE PLALAM(X1,X0,X2,Y1,Y0,Y2,XLAM) *----------------------------------------------------------------------- * PLALAM - Computes lambda for a point on a line (0 = start, 1 = end). * (Last changed on 20/ 1/98.) *----------------------------------------------------------------------- implicit none +SEQ,PRINTPLOT. DOUBLE PRECISION X1,X0,X2,Y0,Y1,Y2,XLAM *** Segment of zero length. IF((X1-X2).EQ.0.AND.(Y1-Y2).EQ.0)THEN PRINT *,' !!!!!! PLALAM WARNING : Zero length segment.' if(lgstop)then print *,' x1-y2=',x1,x2 print *,' y1-y2=',y1,y2 endif XLAM=2 *** Point nearer to (X1,Y1). ELSEIF((X0-X1)**2+(Y0-Y1)**2.LT.(X0-X2)**2+(Y0-Y2)**2)THEN IF(ABS(Y1-Y2).GT.ABS(X1-X2))THEN XLAM=(Y0-Y1)/(Y2-Y1) ELSE XLAM=(X0-X1)/(X2-X1) ENDIF *** Point nearer to (X2,Y2). ELSE IF(ABS(Y1-Y2).GT.ABS(X1-X2))THEN XLAM=1-(Y0-Y2)/(Y1-Y2) ELSE XLAM=1-(X0-X2)/(X1-X2) ENDIF ENDIF END +DECK,PLABU1. SUBROUTINE PLABU1(ACTION,IREF,NPL,XPL,YPL,ZPL,APL,BPL,CPL, - ICOL,IVOL,IFAIL) *----------------------------------------------------------------------- * PLABU1 - Stores planes of surfaces. * (Last changed on 28/10/09.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. DOUBLE PRECISION XBUF(MXPOIN),YBUF(MXPOIN),ZBUF(MXPOIN), - ABUF(MXPLAN),BBUF(MXPLAN),CBUF(MXPLAN), - XPL(MXEDGE),YPL(MXEDGE),ZPL(MXEDGE),APL,BPL,CPL double precision dpl INTEGER ICBUF(MXPLAN),IVBUF(MXPLAN),NBUF(MXPLAN),ISTART(MXPLAN), - ICURR,IND(MXPLAN),II,IREF,NPL,ICOL,IVOL,IFAIL,I,J LOGICAL USE(MXPLAN) CHARACTER*(*) ACTION +SELF,IF=SAVE. SAVE NBUF,XBUF,YBUF,ZBUF,ABUF,BBUF,CBUF,IVBUF,ICBUF, - ISTART,ICURR,USE +SELF. DATA ICURR/0/,USE/MXPLAN*.FALSE./,ISTART/MXPLAN*-1/ *** Assume failure. IFAIL=1 *** Store a new plane. IF(ACTION.EQ.'STORE')THEN * Basic check on the data. IF(NPL.LT.0.OR.NPL.GT.MXEDGE)THEN PRINT *,' !!!!!! PLABU1 WARNING : Number of points'// - ' on polygon < 0 or > MXEDGE ; not stored.' RETURN ENDIF * See whether there is a free slot. IREF=0 DO 10 I=1,MXPLAN IF(.NOT.USE(I))THEN IREF=I GOTO 20 ENDIF 10 CONTINUE PRINT *,' !!!!!! PLABU1 WARNING : No room to store'// - ' further polygons ; increase MXPLAN.' RETURN 20 CONTINUE * See whether there is free space, garbage collect if not. IF(ICURR+NPL.GT.MXPOIN)THEN C CALL SORTZV(ISTART,IND,MXPLAN,-1,0,0) DO 15 I=1,MXPLAN IND(I)=I 15 CONTINUE CALL SORTTI(ISTART,IND,MXPLAN) ICURR=0 DO 30 II=1,MXPLAN I=IND(II) IF(ISTART(I).LT.0.OR..NOT.USE(I))GOTO 30 DO 40 J=1,NBUF(I) XBUF(ICURR+J)=XBUF(ISTART(I)+J) YBUF(ICURR+J)=YBUF(ISTART(I)+J) ZBUF(ICURR+J)=ZBUF(ISTART(I)+J) 40 CONTINUE ISTART(I)=ICURR ICURR=ICURR+NBUF(I) 30 CONTINUE ENDIF * See whether there now is enough space. IF(ICURR+NPL.GT.MXPOIN)THEN PRINT *,' !!!!!! PLABU1 WARNING : No room to store'// - ' further points; increase MXPOIN.' RETURN ENDIF * Store the polygon. ISTART(IREF)=ICURR USE(IREF)=.TRUE. NBUF(IREF)=NPL ABUF(IREF)=APL BBUF(IREF)=BPL CBUF(IREF)=CPL ICBUF(IREF)=ICOL IVBUF(IREF)=IVOL dpl=0 DO 50 I=1,NPL XBUF(ISTART(IREF)+I)=XPL(I) YBUF(ISTART(IREF)+I)=YPL(I) ZBUF(ISTART(IREF)+I)=ZPL(I) dpl=dpl+apl*xpl(i)+bpl*ypl(i)+cpl*zpl(i) 50 CONTINUE dpl=dpl/npl do i=1,npl if(abs(dpl-xpl(i)*apl-ypl(i)*bpl-zpl(i)*cpl).gt.1e-6)then print *,' PLABU1 Offset Error: ' print *,' Point: ',xpl(i),ypl(i),zpl(i) print *,' Error: ',dpl-xpl(i)*apl-ypl(i)*bpl- - cpl*zpl(i) endif enddo ICURR=ICURR+NPL *** Read back a plane. ELSEIF(ACTION.EQ.'READ')THEN * Basic checks of the index. IF(IREF.LT.1.OR.IREF.GT.MXPLAN)THEN PRINT *,' !!!!!! PLABU1 WARNING : Polygon reference'// - ' number out of range; not read.' RETURN ELSEIF(.NOT.USE(IREF))THEN IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLABU1 DEBUG :'', - '' Requested polygon not defined; not read.'')') RETURN ENDIF * Return the polygon. DO 100 I=1,NBUF(IREF) XPL(I)=XBUF(ISTART(IREF)+I) YPL(I)=YBUF(ISTART(IREF)+I) ZPL(I)=ZBUF(ISTART(IREF)+I) 100 CONTINUE APL=ABUF(IREF) BPL=BBUF(IREF) CPL=CBUF(IREF) ICOL=ICBUF(IREF) IVOL=IVBUF(IREF) NPL=NBUF(IREF) *** Delete a plane. ELSEIF(ACTION.EQ.'DELETE')THEN * Basic checks of the index. IF(IREF.LT.1.OR.IREF.GT.MXPLAN)THEN PRINT *,' !!!!!! PLABU1 WARNING : Polygon reference'// - ' number out of range; not deleted.' RETURN ELSEIF(.NOT.USE(IREF))THEN PRINT *,' ------ PLABU1 MESSAGE : Requested polygon'// - ' is currently not defined.' RETURN ENDIF * Delete the polygon. USE(IREF)=.FALSE. ISTART(IREF)=-1 *** Reset the buffer. ELSEIF(ACTION.EQ.'RESET'.OR.ACTION.EQ.'INITIALISE')THEN ICURR=0 DO 200 I=1,MXPLAN NBUF(I)=0 USE(I)=.FALSE. ISTART(I)=-1 200 CONTINUE *** List the buffer. ELSEIF(ACTION.EQ.'LIST'.OR.ACTION.EQ.'PRINT')THEN DO 300 I=1,MXPLAN IF(USE(I))THEN WRITE(LUNOUT,'(2X,''Polygon '',I4,'' is stored '', - '' from '',I4)') I,ISTART(I) WRITE(LUNOUT,'(2X,''Colour index: '',I5)') ICBUF(I) WRITE(LUNOUT,'(2X,''Volume index: '',I5)') IVBUF(I) WRITE(LUNOUT,'(2X,''Plane parameters: '',3E15.8)') - ABUF(I),BBUF(I),CBUF(I) WRITE(LUNOUT,'(2X,''Number of points: '',I5)') - NBUF(I) DO 310 J=1,NBUF(I) WRITE(LUNOUT,'(10X,3E15.8)') XBUF(ISTART(I)+J), - YBUF(ISTART(I)+J),ZBUF(ISTART(I)+J) 310 CONTINUE ENDIF 300 CONTINUE *** Query of maximum numbers. ELSEIF(ACTION.EQ.'QUERY')THEN DO 400 I=MXPLAN,1,-1 IF(USE(I))THEN IREF=I GOTO 410 ENDIF 400 CONTINUE IREF=0 410 CONTINUE *** Query of maximum numbers. ELSEIF(ACTION.EQ.'NEWCOLOUR')THEN IF(IREF.LT.1.OR.IREF.GT.MXPLAN)THEN PRINT *,' !!!!!! PLABU1 WARNING : Polygon reference'// - ' number out of range; not deleted.' RETURN ELSEIF(.NOT.USE(IREF))THEN PRINT *,' ------ PLABU1 MESSAGE : Requested polygon'// - ' is currently not defined.' RETURN ENDIF ICBUF(IREF)=ICOL *** Other actions not known. ELSE PRINT *,' !!!!!! PLABU1 WARNING : Unknown action ', - ACTION,' received ; nothing done.' IFAIL=1 RETURN ENDIF *** Seems to have worked. IFAIL=0 END +DECK,PLABU2. SUBROUTINE PLABU2(ACTION,IREF,NPL,XPL,YPL,ZPL,APL,BPL,CPL,DPL, - ICOL,IFAIL) *----------------------------------------------------------------------- * PLABU2 - Stores projected planes of surfaces. * (Last changed on 31/ 7/08.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. DOUBLE PRECISION XBUF(MXPOIN),YBUF(MXPOIN),ZBUF(MXPOIN), - ABUF(MXPLAN),BBUF(MXPLAN),CBUF(MXPLAN),DBUF(MXPLAN), - XPL(MXEDGE),YPL(MXEDGE),ZPL(MXEDGE),APL,BPL,CPL,DPL INTEGER ICBUF(MXPLAN),NBUF(MXPLAN),ISTART(MXPLAN),ICURR, - IREF,NPL,ICOL,IFAIL,I,J,IND(MXPLAN),II LOGICAL USE(MXPLAN) CHARACTER*(*) ACTION +SELF,IF=SAVE. SAVE NBUF,XBUF,YBUF,ZBUF,ABUF,BBUF,CBUF,DBUF,ICBUF, - ISTART,ICURR,USE +SELF. DATA ICURR/0/,USE/MXPLAN*.FALSE./,ISTART/MXPLAN*-1/ *** Assume failure. IFAIL=1 *** Store a new plane. IF(ACTION.EQ.'STORE')THEN * Basic check on the data. IF(NPL.LT.0.OR.NPL.GT.MXEDGE)THEN PRINT *,' !!!!!! PLABU2 WARNING : Number of points'// - ' on polygon < 0 or > MXEDGE ; not stored.' RETURN ENDIF * See whether there is a free slot. IREF=0 DO 10 I=1,MXPLAN IF(.NOT.USE(I))THEN IREF=I GOTO 20 ENDIF 10 CONTINUE PRINT *,' !!!!!! PLABU2 WARNING : No room to store'// - ' further polygons ; increase MXPLAN.' RETURN 20 CONTINUE * See whether there is free space, garbage collect if not. IF(ICURR+NPL.GT.MXPOIN)THEN C CALL SORTZV(ISTART,IND,MXPLAN,-1,0,0) DO 15 I=1,MXPLAN IND(I)=I 15 CONTINUE CALL SORTTI(ISTART,IND,MXPLAN) ICURR=0 DO 30 II=1,MXPLAN I=IND(II) IF(ISTART(I).LT.0.OR..NOT.USE(I))GOTO 30 DO 40 J=1,NBUF(I) XBUF(ICURR+J)=XBUF(ISTART(I)+J) YBUF(ICURR+J)=YBUF(ISTART(I)+J) ZBUF(ICURR+J)=ZBUF(ISTART(I)+J) 40 CONTINUE ISTART(I)=ICURR ICURR=ICURR+NBUF(I) 30 CONTINUE ENDIF * See whether there now is enough space. IF(ICURR+NPL.GT.MXPOIN)THEN PRINT *,' !!!!!! PLABU2 WARNING : No room to store'// - ' further points; increase MXPOIN.' RETURN ENDIF * Store the polygon. ISTART(IREF)=ICURR USE(IREF)=.TRUE. NBUF(IREF)=NPL ABUF(IREF)=APL BBUF(IREF)=BPL CBUF(IREF)=CPL DBUF(IREF)=DPL ICBUF(IREF)=ICOL DO 50 I=1,NPL XBUF(ISTART(IREF)+I)=XPL(I) YBUF(ISTART(IREF)+I)=YPL(I) ZBUF(ISTART(IREF)+I)=ZPL(I) C if(abs(dpl-xpl(i)*apl-ypl(i)*bpl-zpl(i)*cpl).gt.1e-4)then C print *,' PLABU2 Offset Error: ' C print *,' Point: ',xpl(i),ypl(i),zpl(i) C print *,' Error: ',dpl-xpl(i)*apl-ypl(i)*bpl- C - cpl*zpl(i) C endif 50 CONTINUE ICURR=ICURR+NPL *** Read back a plane. ELSEIF(ACTION.EQ.'READ')THEN * Basic checks of the index. IF(IREF.LT.1.OR.IREF.GT.MXPLAN)THEN PRINT *,' !!!!!! PLABU2 WARNING : Polygon reference'// - ' number out of range; not read.' RETURN ELSEIF(.NOT.USE(IREF))THEN C IF(LDEBUG)PRINT *,' ++++++ PLABU2 DEBUG :'// C - ' Requested polygon is not defined; not read.' RETURN ENDIF * Return the polygon. APL=ABUF(IREF) BPL=BBUF(IREF) CPL=CBUF(IREF) DPL=DBUF(IREF) DO 100 I=1,NBUF(IREF) XPL(I)=XBUF(ISTART(IREF)+I) YPL(I)=YBUF(ISTART(IREF)+I) ZPL(I)=ZBUF(ISTART(IREF)+I) 100 CONTINUE ICOL=ICBUF(IREF) NPL=NBUF(IREF) *** Delete a plane. ELSEIF(ACTION.EQ.'DELETE')THEN * Basic checks of the index. IF(IREF.LT.1.OR.IREF.GT.MXPLAN)THEN PRINT *,' !!!!!! PLABU2 WARNING : Polygon reference'// - ' number out of range; not deleted.' RETURN ELSEIF(.NOT.USE(IREF))THEN PRINT *,' ------ PLABU2 MESSAGE : Requested polygon'// - ' is currently not defined.' RETURN ENDIF * Delete the polygon. USE(IREF)=.FALSE. ISTART(IREF)=-1 *** Reset the buffer. ELSEIF(ACTION.EQ.'RESET'.OR.ACTION.EQ.'INITIALISE')THEN ICURR=0 DO 200 I=1,MXPLAN NBUF(I)=0 USE(I)=.FALSE. ISTART(I)=-1 200 CONTINUE *** List the buffer. ELSEIF(ACTION.EQ.'LIST'.OR.ACTION.EQ.'PRINT')THEN DO 300 I=1,MXPLAN IF(USE(I))THEN WRITE(LUNOUT,'(2X,''Polygon '',I4,'' is stored '', - '' from '',I4)') I,ISTART(I) WRITE(LUNOUT,'(2X,''Colour index: '',I5)') ICBUF(I) WRITE(LUNOUT,'(2X,''Plane parameters: '',4E15.8)') - ABUF(I),BBUF(I),CBUF(I),DBUF(I) WRITE(LUNOUT,'(2X,''Number of points: '',I5)') - NBUF(I) DO 310 J=1,NBUF(I) WRITE(LUNOUT,'(10X,3E15.8)') XBUF(ISTART(I)+J), - YBUF(ISTART(I)+J),ZBUF(ISTART(I)+J) 310 CONTINUE ENDIF 300 CONTINUE *** Query of maximum numbers. ELSEIF(ACTION.EQ.'QUERY')THEN DO 400 I=MXPLAN,1,-1 IF(USE(I))THEN IREF=I GOTO 410 ENDIF 400 CONTINUE IREF=0 410 CONTINUE *** Other actions not known. ELSE PRINT *,' !!!!!! PLABU2 WARNING : Unknown action ', - ACTION,' received ; nothing done.' IFAIL=1 RETURN ENDIF *** Seems to have worked. IFAIL=0 END +DECK,PLASUR. SUBROUTINE PLASUR(SURF,IDIM,XVEC,YVEC,NX,NY,PHI,THETA, - XTXT,YTXT,ZTXT,TITLE,OPTION) *----------------------------------------------------------------------- * PLASUR - Plots a surface * (Last changed on 26/10/07.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PARAMETERS. +SEQ,SOLIDS. +SEQ,PRINTPLOT. INTEGER NX,NY,IX,IY,I,J,ICOL,IREF,IVOL,IFAIL,IFAIL1,IFAIL2,NU, - IF,IT,IDIM,IPRSAV(3) REAL SURF(IDIM,*),XVEC(NX),YVEC(NY),PHI,THETA, - QXMIN,QYMIN,QZMIN,QXMAX,QYMAX,QZMAX,DX,DY,DZ DOUBLE PRECISION A,B,C,DET,XPL(4),YPL(4),ZPL(4), - VXMIN,VYMIN,VXMAX,VYMAX,XU(12),YU(12),ZU(12),FMIN,FMAX, - XT(3),YT(3),ZT(3),FNORM,D12,D23,D13, - FPMSAV(3,3),FPRSAV(3,3),FSAVA,FSAVB,FSAVC,FSAVD,FSAVN, - PALSAV,PBLSAV,PCLSAV,SCX,SCY,SCZ CHARACTER*(*) XTXT,YTXT,ZTXT,TITLE,OPTION LOGICAL LXGR,LYGR,LZGR *** Decode options. LXGR=.FALSE. LYGR=.FALSE. LZGR=.FALSE. IF(INDEX(OPTION,'NOX-GRID').NE.0)THEN LXGR=.FALSE. ELSEIF(INDEX(OPTION,'X-GRID').NE.0)THEN LXGR=.TRUE. ENDIF IF(INDEX(OPTION,'NOY-GRID').NE.0)THEN LYGR=.FALSE. ELSEIF(INDEX(OPTION,'Y-GRID').NE.0)THEN LYGR=.TRUE. ENDIF IF(INDEX(OPTION,'NOZ-GRID').NE.0)THEN LZGR=.FALSE. ELSEIF(INDEX(OPTION,'Z-GRID').NE.0)THEN LZGR=.TRUE. ENDIF *** Start progress printing. CALL PROINT('SURFACE',1,6) *** Determine limits of the box. CALL PROFLD(1,'Determining ranges',-1.0) QXMIN=XVEC(1) QXMAX=XVEC(1) DO 100 I=2,NX IF(XVEC(I).LT.QXMIN)QXMIN=XVEC(I) IF(XVEC(I).GT.QXMAX)QXMAX=XVEC(I) 100 CONTINUE QYMIN=YVEC(1) QYMAX=YVEC(1) DO 110 I=2,NY IF(YVEC(I).LT.QYMIN)QYMIN=YVEC(I) IF(YVEC(I).GT.QYMAX)QYMAX=YVEC(I) 110 CONTINUE QZMIN=SURF(1,1) QZMAX=SURF(1,1) DO 120 I=1,NX DO 130 J=1,NY IF(SURF(I,J).LT.QZMIN)QZMIN=SURF(I,J) IF(SURF(I,J).GT.QZMAX)QZMAX=SURF(I,J) 130 CONTINUE 120 CONTINUE * Ensure every range is non-zero. IF(QXMIN.GE.QXMAX.OR.QYMIN.GE.QYMAX.OR.QZMIN.GE.QZMAX)THEN PRINT *,' !!!!!! PLASUR WARNING : Zero range in one'// - ' or more dimensions; no plot.' CALL PROEND GOTO 1000 ENDIF * Drawing margins. DX=0.005*(QXMAX-QXMIN) DY=0.005*(QYMAX-QYMIN) DZ=0.005*(QZMAX-QZMIN) * Enlarge the vertical range for better plotting. QZMIN=QZMIN-2*DZ QZMAX=QZMAX+2*DZ CALL GRASET(QXMIN,QYMIN,QZMIN,QXMAX,QYMAX,QZMAX) * Set geometrical tolerances. CALL EPSSET('SET',1D-7*(QXMAX-QXMIN),1D-7*(QYMAX-QYMIN), - 1D-7*(QZMAX-QZMIN)) * Update margins according options. IF(.NOT.LXGR)DX=0 IF(.NOT.LYGR)DY=0 IF(.NOT.LZGR)DZ=0 *** Establish the projection matrix. CALL PROFLD(1,'Computing projection matrix',-1.0) * Save old values. DO 200 I=1,3 IPRSAV(I)=IPRMAT(I) DO 210 J=1,3 FPMSAV(I,J)=FPRMAT(I,J) FPRSAV(I,J)=FPROJ(I,J) 210 CONTINUE 200 CONTINUE FSAVA=FPROJA FSAVB=FPROJB FSAVC=FPROJC FSAVD=FPROJD FSAVN=FPROJN PALSAV=PRAL PBLSAV=PRBL PCLSAV=PRCL * Compute the stretching factors. SCX=1 SCY=(QYMAX-QYMIN)/(QXMAX-QXMIN) SCZ=(QZMAX-QZMIN)/(QXMAX-QXMIN) * Rotation matrix for the given angles. FPROJ(1,1)=SCX* COS(PHI) FPROJ(1,2)=-SCY*SIN(PHI) FPROJ(1,3)=SCZ* 0 FPROJ(2,1)=SCX* SIN(PHI)*COS(THETA) FPROJ(2,2)=SCY* COS(PHI)*COS(THETA) FPROJ(2,3)=SCZ* SIN(THETA) FPROJ(3,1)=-SCX*SIN(PHI)*SIN(THETA) FPROJ(3,2)=-SCY*COS(PHI)*SIN(THETA) FPROJ(3,3)=SCZ* COS(THETA) * Store the plane parameters. FPROJA=FPROJ(3,1) FPROJB=FPROJ(3,2) FPROJC=FPROJ(3,3) FPROJN=1 FPROJD=1 * Prepare the projection matrix. FPRMAT(1,1)=FPROJ(1,1) FPRMAT(2,1)=FPROJ(1,2) FPRMAT(3,1)=FPROJ(1,3) FPRMAT(1,2)=FPROJ(2,1) FPRMAT(2,2)=FPROJ(2,2) FPRMAT(3,2)=FPROJ(2,3) FPRMAT(1,3)=FPROJA FPRMAT(2,3)=FPROJB FPRMAT(3,3)=FPROJC * Solve the matrix. CALL DFACT(3,FPRMAT,3,IPRMAT,IFAIL1,DET,IFAIL2) IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLASUR DEBUG :'', - '' Determinant of projection: '',E15.8)') DET IF(IFAIL1.NE.0.OR.IFAIL2.NE.0)THEN PRINT *,' !!!!!! PLASUR WARNING : Unable to solve'// - ' the projection matrix; reset to default.' CALL PROEND GOTO 1000 ENDIF * Establish light direction. PRAL=+COS(PRPHIL)*COS(PRTHL)*FPROJA-SIN(PRPHIL)*FPROJB+ - COS(PRPHIL)*SIN(PRTHL)*FPROJC PRBL=+SIN(PRPHIL)*COS(PRTHL)*FPROJA+COS(PRPHIL)*FPROJB+ - SIN(PRPHIL)*SIN(PRTHL)*FPROJC PRCL= -SIN(PRTHL)*FPROJA+ - COS(PRTHL)*FPROJC FNORM=SQRT(PRAL**2+PRBL**2+PRCL**2) IF(FNORM.GT.0)THEN PRAL=PRAL/FNORM PRBL=PRBL/FNORM PRCL=PRCL/FNORM ENDIF *** Initialise the panel buffer. CALL PROFLD(1,'Initialising buffer',-1.0) CALL PLABU1('RESET',IREF,0,XPL,YPL,ZPL, - 0.0D0,0.0D0,0.0D0,0,0,IFAIL) *** Set a volume indicator. IVOL=1 *** Generate a rainbow colour table. IF(ICOLRB.EQ.0)THEN CALL PROFLD(1,'Making colour table',-1.0) ICOLRB=ICOL0 CALL COLRBW(ICOLRB) ICOL0=ICOL0+NPRCOL ENDIF *** Loop over the matrix. CALL PROFLD(1,'Projecting surface',REAL(NX-1)) DO 10 IX=1,NX-1 CALL PROSTA(1,REAL(IX)) DO 20 IY=1,NY-1 * Store the outline of the entire panel. XPL(1)=XVEC(IX)+DX YPL(1)=YVEC(IY)+DY ZPL(1)=SURF(IX,IY) XPL(2)=XVEC(IX+1)-DX YPL(2)=YVEC(IY)+DY ZPL(2)=SURF(IX+1,IY) XPL(3)=XVEC(IX+1)-DX YPL(3)=YVEC(IY+1)-DY ZPL(3)=SURF(IX+1,IY+1) XPL(4)=XVEC(IX)+DX YPL(4)=YVEC(IY+1)-DY ZPL(4)=SURF(IX,IY+1) * Loop over the function values. DO 30 IF=1,NPRCOL-1 FMIN=QZMIN+DBLE(IF-1)*(QZMAX-QZMIN)/DBLE(NPRCOL-1)+DZ/2 FMAX=QZMIN+DBLE(IF )*(QZMAX-QZMIN)/DBLE(NPRCOL-1)-DZ/2 IF( FMIN.GT.MAX(SURF(IX,IY),SURF(IX+1,IY), - SURF(IX+1,IY+1),SURF(IX,IY+1)).OR. - FMAX.LT.MIN(SURF(IX,IY),SURF(IX+1,IY), - SURF(IX+1,IY+1),SURF(IX,IY+1)))GOTO 30 * Find the section of the panel for this function value range. CALL PLATRI(4,XPL,YPL,ZPL,NU,XU,YU,ZU,FMIN,FMAX) IF(NU.LT.3)GOTO 30 * Set the colour index. ICOL=ICOLRB+IF-1 * Break the resulting curve into triangles. XT(1)=XU(1) YT(1)=YU(1) ZT(1)=ZU(1) DO 40 IT=3,NU XT(2)=XU(IT-1) YT(2)=YU(IT-1) ZT(2)=ZU(IT-1) XT(3)=XU(IT) YT(3)=YU(IT) ZT(3)=ZU(IT) * Compute a normal vector of the 1st panel. DET=-XT(3)*YT(2)*ZT(1)+XT(2)*YT(3)*ZT(1)+ - XT(3)*YT(1)*ZT(2)-XT(1)*YT(3)*ZT(2)- - XT(2)*YT(1)*ZT(3)+XT(1)*YT(2)*ZT(3) IF(DET.NE.0)THEN A=( YT(2)*ZT(1)-YT(3)*ZT(1)-YT(1)*ZT(2)+ - YT(3)*ZT(2)+YT(1)*ZT(3)-YT(2)*ZT(3))/DET B=(-XT(2)*ZT(1)+XT(3)*ZT(1)+XT(1)*ZT(2)- - XT(3)*ZT(2)-XT(1)*ZT(3)+XT(2)*ZT(3))/DET C=( XT(2)*YT(1)-XT(3)*YT(1)-XT(1)*YT(2)+ - XT(3)*YT(2)+XT(1)*YT(3)-XT(2)*YT(3))/DET ELSE D12= (YT(1)*ZT(2)-ZT(1)*YT(2))**2+ - (ZT(1)*XT(2)-XT(1)*ZT(2))**2+ - (XT(1)*YT(2)-YT(1)*XT(2))**2 D13= (YT(1)*ZT(3)-ZT(1)*YT(3))**2+ - (ZT(1)*XT(3)-XT(1)*ZT(3))**2+ - (XT(1)*YT(3)-YT(1)*XT(3))**2 D23= (YT(2)*ZT(3)-ZT(2)*YT(3))**2+ - (ZT(2)*XT(3)-XT(2)*ZT(3))**2+ - (XT(2)*YT(3)-YT(2)*XT(3))**2 IF(D12.GE.D13.AND.D12.GE.D23)THEN A=YT(1)*ZT(2)-ZT(1)*YT(2) B=ZT(1)*XT(2)-XT(1)*ZT(2) C=XT(1)*YT(2)-YT(1)*XT(2) ELSEIF(D13.GE.D12.AND.D13.GE.D23)THEN A=YT(1)*ZT(3)-ZT(1)*YT(3) B=ZT(1)*XT(3)-XT(1)*ZT(3) C=XT(1)*YT(3)-YT(1)*XT(3) ELSE A=YT(2)*ZT(3)-ZT(2)*YT(3) B=ZT(2)*XT(3)-XT(2)*ZT(3) C=XT(2)*YT(3)-YT(2)*XT(3) ENDIF ENDIF * Normalise. FNORM=SQRT(A**2+B**2+C**2) IF(FNORM.LE.0)THEN PRINT *,' !!!!!! PLASUR WARNING : Panel with zero-norm'// - ' normal vector; panel skipped.' GOTO 40 ELSE A=A/FNORM B=B/FNORM C=C/FNORM ENDIF * Store the 1st panel in the buffer. IF(A*FPROJA+B*FPROJB+C*FPROJC.LE.0)THEN CALL PLABU1('STORE',IREF,3,XT,YT,ZT,-A,-B,-C, - ICOL,IVOL,IFAIL) ELSE CALL PLABU1('STORE',IREF,3,XT,YT,ZT,A,B,C, - ICOL,IVOL,IFAIL) ENDIF IF(IFAIL.NE.0)PRINT *,' !!!!!! PLASUR WARNING : Unable to'// - ' store a panel of the surface.' 40 CONTINUE 30 CONTINUE 20 CONTINUE 10 CONTINUE *** Plot the frame. CALL PROFLD(1,'Plotting frame',-1.0) CALL GRAXI3(VXMIN,VYMIN,VXMAX,VYMAX,XTXT,YTXT,ZTXT,TITLE, - 'PLOT,NOCELL') *** Project the panels. CALL PROFLD(1,'Projecting panels',-1.0) CALL PLASRP CALL PROEND *** Plot the panels. CALL PLAPLT *** Next plot. CALL GRNEXT *** Continue here in case of errors. 1000 CONTINUE *** Reset tolerances. CALL EPSSET('RESET',0.0D0,0.0D0,0.0D0) *** Restore projection matrices. DO 220 I=1,3 IPRMAT(I)=IPRSAV(I) DO 230 J=1,3 FPRMAT(I,J)=FPMSAV(I,J) FPROJ(I,J)=FPRSAV(I,J) 230 CONTINUE 220 CONTINUE FPROJA=FSAVA FPROJB=FSAVB FPROJC=FSAVC FPROJD=FSAVD FPROJN=FSAVN PRAL=PALSAV PRBL=PBLSAV PRCL=PCLSAV END +DECK,PLATRI. SUBROUTINE PLATRI(NPL,XPL,YPL,ZPL,NU,XU,YU,ZU,FMIN,FMAX) *----------------------------------------------------------------------- * PLATRI - Selects the part of a rectangle inside function values. * (Last changed on 12/11/02) *----------------------------------------------------------------------- implicit none INTEGER NPL,NU,I,J DOUBLE PRECISION XPL(*),YPL(*),ZPL(*),FMIN,FMAX,XU(*),YU(*),ZU(*) *** Start a new triangle. NU=0 *** See whether we leave the range over the line 1-2. DO 10 I=1,4 J=I+1 IF(J.GT.4)J=J-4 IF((ZPL(I)-FMIN)*(FMIN-ZPL(J)).GE.0.AND.ZPL(J).NE.ZPL(I))THEN NU=NU+1 XU(NU)=XPL(I)+(XPL(J)-XPL(I))*(FMIN-ZPL(I))/(ZPL(J)-ZPL(I)) YU(NU)=YPL(I)+(YPL(J)-YPL(I))*(FMIN-ZPL(I))/(ZPL(J)-ZPL(I)) ZU(NU)=FMIN IF(((I.EQ.1.OR.I.EQ.3).AND. - (ABS(XPL(I)-XU(NU)).LT.1E-3*ABS(XPL(I)-XPL(J)).OR. - ABS(XPL(J)-XU(NU)).LT.1E-3*ABS(XPL(I)-XPL(J)))).OR. - ((I.EQ.2.OR.I.EQ.4).AND. - (ABS(YPL(I)-YU(NU)).LT.1E-3*ABS(YPL(I)-YPL(J)).OR. - ABS(YPL(J)-YU(NU)).LT.1E-3*ABS(YPL(I)-YPL(J)))))THEN NU=NU-1 ENDIF ENDIF IF((ZPL(I)-FMAX)*(FMAX-ZPL(J)).GE.0.AND.ZPL(J).NE.ZPL(I))THEN NU=NU+1 XU(NU)=XPL(I)+(XPL(J)-XPL(I))*(FMAX-ZPL(I))/(ZPL(J)-ZPL(I)) YU(NU)=YPL(I)+(YPL(J)-YPL(I))*(FMAX-ZPL(I))/(ZPL(J)-ZPL(I)) ZU(NU)=FMAX IF(((I.EQ.1.OR.I.EQ.3).AND. - (ABS(XPL(I)-XU(NU)).LT.1E-3*ABS(XPL(I)-XPL(J)).OR. - ABS(XPL(J)-XU(NU)).LT.1E-3*ABS(XPL(I)-XPL(J)))).OR. - ((I.EQ.2.OR.I.EQ.4).AND. - (ABS(YPL(I)-YU(NU)).LT.1E-3*ABS(YPL(I)-YPL(J)).OR. - ABS(YPL(J)-YU(NU)).LT.1E-3*ABS(YPL(I)-YPL(J)))))THEN NU=NU-1 ENDIF ENDIF IF((FMIN-ZPL(I))*(ZPL(I)-FMAX).GE.0)THEN NU=NU+1 XU(NU)=XPL(I) YU(NU)=YPL(I) ZU(NU)=ZPL(I) ENDIF 10 CONTINUE *** Eliminate butterflies. CALL BUTFLD(NU,XU,YU,ZU) END +DECK,PLABEM. SUBROUTINE PLABEM(IFAIL) *----------------------------------------------------------------------- * PLABEM - Prepares panels for BEM applications: removes the contacts * and cuts polygons to rectangles and right-angle triangles. * (Last changed on 21/10/10.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,BEMDATA. +SEQ,PRINTPLOT. DOUBLE PRECISION XPL1(MXEDGE),YPL1(MXEDGE),ZPL1(MXEDGE), - XPL2(MXEDGE),YPL2(MXEDGE),ZPL2(MXEDGE), - XPL(MXEDGE),YPL(MXEDGE),ZPL(MXEDGE), - EPSANG,EPSXYZ,AN1,BN1,CN1,DN1,AN2,BN2,CN2,DN2,ROT(3,3),ZM, - VLIST(MXPLAN,4),EPSX,EPSY INTEGER I,J,K,L,NREF,NPL1,NPL2,NREFO,IREFO(MXPLAN),ITYPO(MXPLAN), - ICOL1,ICOL2,IVOL1,IVOL2,IREF1,REFOLD(MXPLAN),NOLD,M, - IFAIL,IFAIL1,LIST(MXPLAN,4),NLIST,JMIN,NREFOO,IREFOO(MXPLAN) LOGICAL MARK(MXPLAN),EQUAL1,EQUAL2,EQUAL3,EQUAL4,CHANGE *** Assume failure. IFAIL=1 *** Establish tolerances. EPSANG = BEMEPA EPSXYZ = BEMEPD CALL EPSSET('SET',EPSXYZ,EPSXYZ,EPSXYZ) *** Count panels. CALL PLABU1('QUERY',NREF,NPL1,XPL1,YPL1,ZPL1,AN1,BN1,CN1, - ICOL1,IVOL1,IFAIL1) C print *,' Found ',nref,' panels.' * Set the flags. DO 60 I=1,NREF MARK(I)=.FALSE. 60 CONTINUE * Keep track of the existing panels. NOLD=0 *** Pick up panels which coincide potentially. DO 10 I=1,NREF * Fetch one panel. CALL PLABU1('READ',I,NPL1,XPL1,YPL1,ZPL1,AN1,BN1,CN1, - ICOL1,IVOL1,IFAIL1) IF(IFAIL1.NE.0)GOTO 10 C print *,' *** Checking from panel ',i,' with ',npl1,' nodes' * Keep the references NOLD=NOLD+1 REFOLD(NOLD)=I * Skip panels already done. IF(MARK(I))GOTO 10 * Clear buffer 2. CALL PLABU2('RESET',IREF1,NPL1,XPL2,YPL2,ZPL2, - AN2,BN2,CN2,DN2,ICOL2,IFAIL1) * Establish its norm and offset. DN1=AN1*XPL1(1)+BN1*YPL1(1)+CN1*ZPL1(1) C print *,' Norm vector: ',AN1,BN1,CN1,DN1 * Rotation matrix. IF(ABS(CN1).LE.ABS(AN1).AND.ABS(CN1).LE.ABS(BN1))THEN C print *,' Rotation: removing C' ROT(1,1)= BN1/SQRT(AN1*AN1+BN1*BN1) ROT(2,1)=-AN1/SQRT(AN1*AN1+BN1*BN1) ROT(3,1)= 0.0 ELSEIF(ABS(BN1).LE.ABS(AN1).AND.ABS(BN1).LE.ABS(CN1))THEN C print *,' Rotation: removing B' ROT(1,1)= CN1/SQRT(AN1*AN1+CN1*CN1) ROT(2,1)= 0.0 ROT(3,1)=-AN1/SQRT(AN1*AN1+CN1*CN1) ELSE C print *,' Rotation: removing A' ROT(1,1)= 0.0 ROT(2,1)= CN1/SQRT(BN1*BN1+CN1*CN1) ROT(3,1)=-BN1/SQRT(BN1*BN1+CN1*CN1) ENDIF ROT(1,3)=AN1 ROT(2,3)=BN1 ROT(3,3)=CN1 ROT(1,2)=ROT(2,3)*ROT(3,1)-ROT(3,3)*ROT(2,1) ROT(2,2)=ROT(3,3)*ROT(1,1)-ROT(1,3)*ROT(3,1) ROT(3,2)=ROT(1,3)*ROT(2,1)-ROT(2,3)*ROT(1,1) C do k=1,3 C print '(3f10.3)',(rot(k,l),l=1,3) C enddo * Rotate it in place. ZM=0 DO 30 K=1,NPL1 XPL(K)=ROT(1,1)*XPL1(K)+ROT(2,1)*YPL1(K)+ROT(3,1)*ZPL1(K) YPL(K)=ROT(1,2)*XPL1(K)+ROT(2,2)*YPL1(K)+ROT(3,2)*ZPL1(K) ZPL(K)=ROT(1,3)*XPL1(K)+ROT(2,3)*YPL1(K)+ROT(3,3)*ZPL1(K) ZM=ZM+ZPL(K) 30 CONTINUE ZM=ZM/NPL1 * Store it and keep reference data. NLIST=1 CALL PLABU2('STORE',LIST(NLIST,3),NPL1,XPL,YPL,ZPL, - 0.0D0,0.0D0,1.0D0,ZM,ICOL1,IFAIL1) LIST(NLIST,1)=IVOL1 LIST(NLIST,2)=0 VLIST(NLIST,1)=AN1 VLIST(NLIST,2)=BN1 VLIST(NLIST,3)=CN1 VLIST(NLIST,4)=DN1 *** Pick up all matching planes. DO 20 J=I+1,NREF IF(MARK(J))GOTO 20 C print *,' Checking against ',j CALL PLABU1('READ',J,NPL2,XPL2,YPL2,ZPL2,AN2,BN2,CN2, - ICOL2,IVOL2,IFAIL1) * See whether this matches the first. DN2=AN2*XPL2(1)+BN2*YPL2(1)+CN2*ZPL2(1) C print *,' Norm vector: ',AN2,BN2,CN2,DN2 C print *,' inner product = ',AN1*AN2+BN1*BN2+CN1*CN2 C print *,' plane offset = ', C - DN1-DN2*(AN1*AN2+BN1*BN2+CN1*CN2) IF(ABS(ABS(AN1*AN2+BN1*BN2+CN1*CN2)-1.0).GT.EPSANG.OR. - ABS(DN1-DN2*(AN1*AN2+BN1*BN2+CN1*CN2)).GT.EPSXYZ) - GOTO 20 * Found a match C print *,' Found a matching plane' MARK(J)=.TRUE. * Rotate this plane too. ZM=0 DO 40 K=1,NPL2 XPL(K)=ROT(1,1)*XPL2(K)+ROT(2,1)*YPL2(K)+ROT(3,1)*ZPL2(K) YPL(K)=ROT(1,2)*XPL2(K)+ROT(2,2)*YPL2(K)+ROT(3,2)*ZPL2(K) ZPL(K)=ROT(1,3)*XPL2(K)+ROT(2,3)*YPL2(K)+ROT(3,3)*ZPL2(K) ZM=ZM+ZPL(K) 40 CONTINUE ZM=ZM/NPL2 * Store it. IF(NLIST+1.GT.MXPLAN)THEN PRINT *,' !!!!!! PLABEM WARNING : Too many panels.' RETURN ENDIF NLIST=NLIST+1 CALL PLABU2('STORE',LIST(NLIST,3),NPL2,XPL,YPL,ZPL, - 0.0D0,0.0D0,1.0D0,ZM,ICOL2,IFAIL1) LIST(NLIST,1)=IVOL2 LIST(NLIST,2)=0 VLIST(NLIST,1)=AN2 VLIST(NLIST,2)=BN2 VLIST(NLIST,3)=CN2 VLIST(NLIST,4)=DN2 20 CONTINUE C print *,' Listing of panels before cutting:' C do j=1,nlist C print *,' Panel ',j,': volumes ',list(j,1),list(j,2) C enddo *** Cut them as long as needed till no contacts remain. JMIN=1 100 CONTINUE DO 110 J=1,NLIST IF(LIST(J,3).LE.0.OR. - J.LT.JMIN.OR. - (LIST(J,1).GT.0.AND.LIST(J,2).GT.0))GOTO 110 DO 120 K=J+1,NLIST IF(LIST(K,3).LE.0.OR. - (LIST(K,1).GT.0.AND.LIST(K,2).GT.0))GOTO 120 C print *,' Cutting ',list(j,3),list(k,3) * Separate contact and non-contact areas. CALL PLAOVL(LIST(J,3),LIST(K,3),NREFO,IREFO,ITYPO, - EPSX,EPSY,IFAIL1) IF(LDEBUG)THEN WRITE(LUNOUT,'('' Input volumes: '',2I4,4X,2I4)') - LIST(J,1),LIST(J,2),LIST(K,1),LIST(K,2) WRITE(LUNOUT,'('' Norm 1: '',4F10.3)') - VLIST(J,1),VLIST(J,2),VLIST(J,3),VLIST(J,4) WRITE(LUNOUT,'('' Norm 2: '',4F10.3)') - VLIST(K,1),VLIST(K,2),VLIST(K,3),VLIST(K,4) WRITE(LUNOUT,'('' Output panels: '',I4)') NREFO DO 310 L=1,NREFO WRITE(LUNOUT,'('' Primitive '',I2,'' type '',I2)') - IREFO(L),ITYPO(L) CALL PLABU2('READ',IREFO(L),NPL2,XPL2,YPL2,ZPL2, - AN2,BN2,CN2,DN2,ICOL2,IFAIL1) DO 320 M=1,NPL2 WRITE(LUNOUT,'(2X,I2,'': '',3F10.3)') - M,XPL2(M),YPL2(M),ZPL2(M) 320 CONTINUE 310 CONTINUE ENDIF * If there are just 2 panels, see whether there is a new one IF(NREFO.EQ.2)THEN CALL PLAEQU(LIST(J,3),IREFO(1),EPSX,EPSY,EQUAL1) CALL PLAEQU(LIST(J,3),IREFO(2),EPSX,EPSY,EQUAL2) CALL PLAEQU(LIST(K,3),IREFO(1),EPSX,EPSY,EQUAL3) CALL PLAEQU(LIST(K,3),IREFO(2),EPSX,EPSY,EQUAL4) IF((EQUAL1.OR.EQUAL3).AND.(EQUAL2.OR.EQUAL4))THEN CHANGE=.FALSE. ELSE CHANGE=.TRUE. ENDIF ELSE CHANGE=.TRUE. ENDIF C print *,' Change flag: ',change * If there is no change, delete them. IF(.NOT.CHANGE)THEN C print *,' 2 output planes - removing them' CALL PLABU2('DELETE',IREFO(1),NPL2,XPL2,YPL2,ZPL2, - AN2,BN2,CN2,DN2,ICOL2,IFAIL1) CALL PLABU2('DELETE',IREFO(2),NPL2,XPL2,YPL2,ZPL2, - AN2,BN2,CN2,DN2,ICOL2,IFAIL1) * Buffer overflow ELSEIF(NLIST+NREFO.GT.MXPLAN)THEN PRINT *,' !!!!!! PLABEM WARNING : Overflow of panel'// - ' buffer; abandoned.' IFAIL=1 RETURN * Otherwise delete the existing planes and restart the loops ELSE C print *,' ',nrefo,' output planes, removing old planes' CALL PLABU2('DELETE',LIST(J,3),NPL2,XPL2,YPL2,ZPL2, - AN2,BN2,CN2,DN2,ICOL2,IFAIL1) CALL PLABU2('DELETE',LIST(K,3),NPL2,XPL2,YPL2,ZPL2, - AN2,BN2,CN2,DN2,ICOL2,IFAIL1) LIST(J,3)=-ABS(LIST(J,3)) LIST(K,3)=-ABS(LIST(K,3)) DO 130 L=1,NREFO IF(ITYPO(L).EQ.1)THEN LIST(NLIST+L,1)=MAX(LIST(J,1),LIST(J,2)) LIST(NLIST+L,2)=0 VLIST(NLIST+L,1)=VLIST(J,1) VLIST(NLIST+L,2)=VLIST(J,2) VLIST(NLIST+L,3)=VLIST(J,3) VLIST(NLIST+L,4)=VLIST(J,4) ELSEIF(ITYPO(L).EQ.2)THEN LIST(NLIST+L,1)=MAX(LIST(K,1),LIST(K,2)) LIST(NLIST+L,2)=0 VLIST(NLIST+L,1)=VLIST(K,1) VLIST(NLIST+L,2)=VLIST(K,2) VLIST(NLIST+L,3)=VLIST(K,3) VLIST(NLIST+L,4)=VLIST(K,4) ELSE LIST(NLIST+L,1)=MAX(LIST(J,1),LIST(J,2)) LIST(NLIST+L,2)=MAX(LIST(K,1),LIST(K,2)) VLIST(NLIST+L,1)=VLIST(J,1) VLIST(NLIST+L,2)=VLIST(J,2) VLIST(NLIST+L,3)=VLIST(J,3) VLIST(NLIST+L,4)=VLIST(J,4) ENDIF LIST(NLIST+L,3)=IREFO(L) IF(LDEBUG)WRITE(LUNOUT,'('' Panel '',I3,'' volume flags: '', - 2I4,'' NORM: '',4F10.3)') - L,LIST(NLIST+L,1),LIST(NLIST+L,2), - VLIST(NLIST+L,1),VLIST(NLIST+L,2), - VLIST(NLIST+L,3),VLIST(NLIST+L,4) 130 CONTINUE NLIST=NLIST+NREFO JMIN=J+1 GOTO 100 ENDIF IF(LDEBUG)THEN WRITE(LUNOUT,'('' Listing of panels after cutting:'')') DO 330 L=1,NLIST IF(LIST(L,3).GT.0)THEN CALL PLABU2('READ',LIST(L,3),NPL2,XPL2,YPL2,ZPL2, - AN2,BN2,CN2,DN2,ICOL2,IFAIL1) WRITE(LUNOUT,'('' Panel '',I3,'': with volumes '',2I4, - '', buf 2 ref = '',I4,'' corners: '',I4)') - L,LIST(L,1),LIST(L,2),LIST(L,3),NPL2 ENDIF 330 CONTINUE ENDIF 120 CONTINUE 110 CONTINUE *** And rotate the panels back in place. DO 200 J=1,NLIST IF(LIST(J,3).LE.0)GOTO 200 * Reduce to rectangles and right-angle triangles CALL PLATRC(LIST(J,3),NREFO,IREFO,IFAIL1) IF(IFAIL1.NE.0)PRINT *,' !!!!!! PLABEM WARNING : Reduction of'// - ' polygons to rectangles and triangles failed.' * Loop over the rectangles and triangles. DO 220 L=1,NREFO if(.false.)then * Improve their quality by further cutting. CALL PLATRQ(IREFO(L),NREFOO,IREFOO,IFAIL1) DO 230 M=1,NREFOO * Fetch CALL PLABU2('READ',IREFOO(M),NPL2,XPL2,YPL2,ZPL2, - AN2,BN2,CN2,DN2,ICOL2,IFAIL1) IF(IFAIL1.NE.0)PRINT *,' !!!!!! PLABEM WARNING : Failed'// - ' to find a panel.' * Rotate. C print *,' After rotating back' DO 210 K=1,NPL2 XPL(K)=ROT(1,1)*XPL2(K)+ROT(1,2)*YPL2(K)+ROT(1,3)*ZPL2(K) YPL(K)=ROT(2,1)*XPL2(K)+ROT(2,2)*YPL2(K)+ROT(2,3)*ZPL2(K) ZPL(K)=ROT(3,1)*XPL2(K)+ROT(3,2)*YPL2(K)+ROT(3,3)*ZPL2(K) C print '(3f10.3)',xpl1(k),ypl1(k),zpl1(k) 210 CONTINUE * Store. CALL PLABU1('STORE',IREF1,NPL2,XPL,YPL,ZPL,AN1,BN1,CN1, - LIST(J,2),LIST(J,1),IFAIL1) C print *,' Buf 1 ref = ',iref1,', Buf 2 ref = ',list(j,3), C - ', vol: ',LIST(J,1),LIST(J,2),' length: ',npl2 230 CONTINUE else CALL PLABU2('READ',IREFO(L),NPL2,XPL2,YPL2,ZPL2, - AN2,BN2,CN2,DN2,ICOL2,IFAIL1) IF(IFAIL1.NE.0)PRINT *,' !!!!!! PLABEM WARNING : Failed'// - ' to find a panel.' * Rotate. C print *,' After rotating back' DO 211 K=1,NPL2 XPL(K)=ROT(1,1)*XPL2(K)+ROT(1,2)*YPL2(K)+ROT(1,3)*ZPL2(K) YPL(K)=ROT(2,1)*XPL2(K)+ROT(2,2)*YPL2(K)+ROT(2,3)*ZPL2(K) ZPL(K)=ROT(3,1)*XPL2(K)+ROT(3,2)*YPL2(K)+ROT(3,3)*ZPL2(K) C print '(3f10.3)',xpl1(k),ypl1(k),zpl1(k) 211 CONTINUE * Store. CALL PLABU1('STORE',IREF1,NPL2,XPL,YPL,ZPL, - VLIST(J,1),VLIST(J,2),VLIST(J,3), - LIST(J,2),LIST(J,1),IFAIL1) C print *,' Buf 1 ref = ',iref1,', Buf 2 ref = ',IREFO(L), C - ', vol: ',LIST(J,1),LIST(J,2),' length: ',npl2 endif 220 CONTINUE 200 CONTINUE * Transfer the new panels. 10 CONTINUE *** Delete the original panels. DO 300 I=1,NOLD CALL PLABU1('DELETE',REFOLD(I),NPL2,XPL,YPL,ZPL, - AN2,BN2,CN2,ICOL2,IVOL2,IFAIL1) C if(ifail1.ne.0)print *,' Deleting old ',refold(i),' failed.' 300 CONTINUE *** Seems to have worked. IFAIL=0 END +DECK,PLAOVL. SUBROUTINE PLAOVL(IREF1,IREF2,NREFO,IREFO,ITYPO,EPSX,EPSY,IFAIL) *----------------------------------------------------------------------- * PLAOVL - Isolates the parts of plane 1 that are not hidden by 2. * (Last changed on 13/ 5/10.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. +SEQ,CONSTANTS. +SEQ,PARAMETERS. INTEGER MXCORN PARAMETER(MXCORN=3*MXEDGE) DOUBLE PRECISION - XPL1(MXEDGE),YPL1(MXEDGE),ZPL1(MXEDGE),APL1,BPL1,CPL1,DPL1, - XPL2(MXEDGE),YPL2(MXEDGE),ZPL2(MXEDGE),APL2,BPL2,CPL2,DPL2, - XPL(MXEDGE),YPL(MXEDGE),ZPL(MXEDGE), - EPSD,XMEAN,YMEAN,ZMEAN,XL(MXCORN,2),YL(MXCORN,2), - Q(MXCORN,2),QMIN,XAUX,YAUX,QAUX, - XC,YC,EPSX,EPSY,EPSZ,XMIN,YMIN,XMAX,YMAX, - XMIN1,YMIN1,XMAX1,YMAX1, - XMIN2,YMIN2,XMAX2,YMAX2 INTEGER NPL1,NPL2,NPL,IFAIL1,IFAIL2,IFAIL,I,J,K,N1,N2,IP1,IP2,NP, - IP1L,IP1LL,IS1,IS2,IL,M1,M2,IQMIN,IAUX,IT(MXCORN,2), - IREF(MXCORN,2,2),NFOUND,IREFO(MXPLAN),ITYPO(MXPLAN), - IREF1,IREF2,NREFO,ICOL1,ICOL2,IDIR,JP1,JP2,KP1,KP2,IMAX C - ,l LOGICAL ADD,ONLIND,OK,KEEP,MARK1(MXEDGE),MARK2(MXEDGE), - ADDED,INSIDE,EDGE,FIRST,CROSS EXTERNAL ONLIND *** Initial setting of the number of produced planes. NREFO=0 *** Retrieve both planes. CALL PLABU2('READ',IREF1,NPL1,XPL1,YPL1,ZPL1,APL1,BPL1,CPL1,DPL1, - ICOL1,IFAIL1) CALL PLABU2('READ',IREF2,NPL2,XPL2,YPL2,ZPL2,APL2,BPL2,CPL2,DPL2, - ICOL2,IFAIL2) IF(IFAIL1.NE.0.OR.IFAIL2.NE.0)THEN PRINT *,' !!!!!! PLAOVL WARNING : Unable to retrieve a'// - ' projected polygon; skipped.' IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLAOVL DEBUG :''// - '' Reference numbers: '',2I4)') IREF1,IREF2 IFAIL=1 RETURN ENDIF *** If the size of either is 0, simply return. IF(NPL1.LE.2.OR.NPL2.LE.2)THEN KEEP=.TRUE. IFAIL=0 RETURN ENDIF *** Compute the various tolerances. XMIN1=XPL1(1) YMIN1=YPL1(1) XMAX1=XPL1(1) YMAX1=YPL1(1) XMEAN=0 YMEAN=0 ZMEAN=0 DO 10 I=1,NPL1 XMIN1=MIN(XMIN1,XPL1(I)) YMIN1=MIN(YMIN1,YPL1(I)) XMAX1=MAX(XMAX1,XPL1(I)) YMAX1=MAX(YMAX1,YPL1(I)) XMEAN=XMEAN+XPL1(I) YMEAN=YMEAN+YPL1(I) ZMEAN=ZMEAN+ZPL1(I) 10 CONTINUE XMIN2=XPL2(1) YMIN2=YPL2(1) XMAX2=XPL2(1) YMAX2=YPL2(1) DO 20 I=1,NPL2 XMIN2=MIN(XMIN2,XPL2(I)) YMIN2=MIN(YMIN2,YPL2(I)) XMAX2=MAX(XMAX2,XPL2(I)) YMAX2=MAX(YMAX2,YPL2(I)) XMEAN=XMEAN+XPL2(I) YMEAN=YMEAN+YPL2(I) ZMEAN=ZMEAN+ZPL2(I) 20 CONTINUE XMIN=MIN(XMIN1,XMIN2) YMIN=MIN(YMIN1,YMIN2) XMAX=MAX(XMAX1,XMAX2) YMAX=MAX(YMAX1,YMAX2) IF(LEPSG)THEN EPSX=EPSGX EPSY=EPSGY ELSE EPSX=1.0D-6*MAX(ABS(XMAX),ABS(XMIN)) EPSY=1.0D-6*MAX(ABS(YMAX),ABS(YMIN)) ENDIF XMEAN=XMEAN/DBLE(NPL1+NPL2) YMEAN=YMEAN/DBLE(NPL1+NPL2) ZMEAN=ZMEAN/DBLE(NPL1+NPL2) * Override the z-tolerance. EPSD=1.0E-6 EPSZ=1.0E-6 * Debugging output. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLAOVL DEBUG :'', - '' Tolerances: x='',E12.5,'', y='',E12.5)') - EPSX,EPSY * Preset the ZPL array to the mean z value. DO 40 I=1,MXEDGE ZPL(I)=ZMEAN 40 CONTINUE *** Establish the list of special points around polygon 1. N1=0 OK=.TRUE. DO 100 I=1,NPL1 * Add the vertex. IF(N1+1.GT.MXCORN)THEN PRINT *,' !!!!!! PLAOVL WARNING : Too many special'// - ' points around a polygon ; list reduced.' OK=.FALSE. GOTO 150 ENDIF N1=N1+1 XL(N1,1)=XPL1(I) YL(N1,1)=YPL1(I) IT(N1,1)=1 Q(N1,1)=0 * If also on 2 or vertex of 2, flag it as crossing or foreign. DO 160 J=1,NPL2 IF(ABS(XPL2(J)-XPL1(I)).LT.EPSX.AND. - ABS(YPL2(J)-YPL1(I)).LT.EPSY)IT(N1,1)=2 IF(ONLIND(XPL2(1+MOD(J-1,NPL2)),YPL2(1+MOD(J-1,NPL2)), - XPL2(1+MOD(J ,NPL2)),YPL2(1+MOD(J ,NPL2)), - XPL1(I ),YPL1(I) ).AND. - (ABS(XPL2(1+MOD(J-1,NPL2))-XPL1(I)).GT.EPSX.OR. - ABS(YPL2(1+MOD(J-1,NPL2))-YPL1(I)).GT.EPSY).AND. - (ABS(XPL2(1+MOD(J ,NPL2))-XPL1(I)).GT.EPSX.OR. - ABS(YPL2(1+MOD(J ,NPL2))-YPL1(I)).GT.EPSY))IT(N1,1)=3 160 CONTINUE * Remember the starting point for the next list. M1=N1+1 * Go over the line segments of the other polygon. DO 110 J=1,NPL2 * Add vertices of 2 that are on this line. IF(ONLIND(XPL1(1+MOD(I-1,NPL1)),YPL1(1+MOD(I-1,NPL1)), - XPL1(1+MOD(I,NPL1)),YPL1(1+MOD(I,NPL1)), - XPL2(J),YPL2(J)).AND. - (ABS(XPL1(1+MOD(I-1,NPL1))-XPL2(J)).GT.EPSX.OR. - ABS(YPL1(1+MOD(I-1,NPL1))-YPL2(J)).GT.EPSY).AND. - (ABS(XPL1(1+MOD(I ,NPL1))-XPL2(J)).GT.EPSX.OR. - ABS(YPL1(1+MOD(I ,NPL1))-YPL2(J)).GT.EPSY))THEN IF(N1+1.GT.MXCORN)THEN PRINT *,' !!!!!! PLAOVL WARNING : Too many special'// - ' points around a polygon ; list reduced.' OK=.FALSE. GOTO 150 ENDIF N1=N1+1 XL(N1,1)=XPL2(J) YL(N1,1)=YPL2(J) IT(N1,1)=2 ENDIF * Add crossing points. CALL CRSPND( - XPL1(1+MOD(I-1,NPL1)),YPL1(1+MOD(I-1,NPL1)), - XPL1(1+MOD(I ,NPL1)),YPL1(1+MOD(I ,NPL1)), - XPL2(1+MOD(J-1,NPL2)),YPL2(1+MOD(J-1,NPL2)), - XPL2(1+MOD(J ,NPL2)),YPL2(1+MOD(J ,NPL2)), - XC,YC,ADD) IF(ADD)THEN IF((ABS(XPL1(1+MOD(I-1,NPL1))-XC).LT.EPSX.AND. - ABS(YPL1(1+MOD(I-1,NPL1))-YC).LT.EPSY).OR. - (ABS(XPL1(1+MOD(I ,NPL1))-XC).LT.EPSX.AND. - ABS(YPL1(1+MOD(I ,NPL1))-YC).LT.EPSY))ADD=.FALSE. IF((ABS(XPL2(1+MOD(J-1,NPL2))-XC).LT.EPSX.AND. - ABS(YPL2(1+MOD(J-1,NPL2))-YC).LT.EPSY).OR. - (ABS(XPL2(1+MOD(J ,NPL2))-XC).LT.EPSX.AND. - ABS(YPL2(1+MOD(J ,NPL2))-YC).LT.EPSY))ADD=.FALSE. IF((ABS(XPL1(1+MOD(I-1,NPL1))- - XPL2(1+MOD(J-1,NPL2))).LT.EPSX.AND. - ABS(YPL1(1+MOD(I-1,NPL1))- - YPL2(1+MOD(J-1,NPL2))).LT.EPSY).OR. - (ABS(XPL1(1+MOD(I-1,NPL1))- - XPL2(1+MOD(J ,NPL2))).LT.EPSX.AND. - ABS(YPL1(1+MOD(I-1,NPL1))- - YPL2(1+MOD(J ,NPL2))).LT.EPSY).OR. - (ABS(XPL1(1+MOD(I ,NPL1))- - XPL2(1+MOD(J-1,NPL2))).LT.EPSX.AND. - ABS(YPL1(1+MOD(I ,NPL1))- - YPL2(1+MOD(J-1,NPL2))).LT.EPSY).OR. - (ABS(XPL1(1+MOD(I-1,NPL1))- - XPL2(1+MOD(J-1,NPL2))).LT.EPSX.AND. - ABS(YPL1(1+MOD(I-1,NPL1))- - YPL2(1+MOD(J-1,NPL2))).LT.EPSY))ADD=.FALSE. ENDIF IF(ADD)THEN IF(N1+1.GT.MXCORN)THEN PRINT *,' !!!!!! PLAOVL WARNING : Too many special'// - ' points around a polygon ; list reduced.' OK=.FALSE. GOTO 150 ENDIF N1=N1+1 XL(N1,1)=XC YL(N1,1)=YC IT(N1,1)=3 ENDIF 110 CONTINUE * Compute the lambda's for these points. DO 120 J=M1,N1 CALL PLALAM(XPL1(1+MOD(I-1,NPL1)),XL(J,1),XPL1(1+MOD(I,NPL1)), - YPL1(1+MOD(I-1,NPL1)),YL(J,1),YPL1(1+MOD(I,NPL1)),Q(J,1)) 120 CONTINUE * Sort the list by using the lambda's. DO 140 J=M1,N1 QMIN=Q(J,1) IQMIN=J DO 130 K=J+1,N1 IF(Q(K,1).LT.QMIN)THEN IQMIN=K QMIN=Q(K,1) ENDIF 130 CONTINUE IF(J.NE.IQMIN)THEN XAUX=XL(J,1) YAUX=YL(J,1) QAUX=Q (J,1) IAUX=IT(J,1) XL(J,1)=XL(IQMIN,1) YL(J,1)=YL(IQMIN,1) Q (J,1)=Q (IQMIN,1) IT(J,1)=IT(IQMIN,1) XL(IQMIN,1)=XAUX YL(IQMIN,1)=YAUX Q (IQMIN,1)=QAUX IT(IQMIN,1)=IAUX ENDIF 140 CONTINUE * Next vertex. 100 CONTINUE *** Establish the list of special points around polygon 2. 150 CONTINUE N2=0 DO 200 I=1,NPL2 * Add the vertex. IF(N2+1.GT.MXCORN)THEN PRINT *,' !!!!!! PLAOVL WARNING : Too many special'// - ' points around a polygon ; list reduced.' OK=.FALSE. GOTO 250 ENDIF N2=N2+1 XL(N2,2)=XPL2(I) YL(N2,2)=YPL2(I) IT(N2,2)=1 Q(N2,2)=0 * If also on 1 or a vertex of 1, flag it as crossing or foreign. DO 260 J=1,NPL1 IF(ABS(XPL1(J)-XPL2(I)).LT.EPSX.AND. - ABS(YPL1(J)-YPL2(I)).LT.EPSY)IT(N2,2)=2 IF(ONLIND(XPL1(1+MOD(J-1,NPL1)),YPL1(1+MOD(J-1,NPL1)), - XPL1(1+MOD(J ,NPL1)),YPL1(1+MOD(J ,NPL1)), - XPL2(I ),YPL2(I) ).AND. - (ABS(XPL1(1+MOD(J-1,NPL1))-XPL2(I)).GT.EPSX.OR. - ABS(YPL1(1+MOD(J-1,NPL1))-YPL2(I)).GT.EPSY).AND. - (ABS(XPL1(1+MOD(J ,NPL1))-XPL2(I)).GT.EPSX.OR. - ABS(YPL1(1+MOD(J ,NPL1))-YPL2(I)).GT.EPSY))IT(N2,2)=3 260 CONTINUE * Remember the starting point for the next list. M2=N2+1 * Go over the line segments of the other polygon. DO 210 J=1,NPL1 * Add vertices of 1 that are on this line. IF(ONLIND(XPL2(1+MOD(I-1,NPL2)),YPL2(1+MOD(I-1,NPL2)), - XPL2(1+MOD(I,NPL2)),YPL2(1+MOD(I,NPL2)), - XPL1(J),YPL1(J)).AND. - (ABS(XPL2(1+MOD(I-1,NPL2))-XPL1(J)).GT.EPSX.OR. - ABS(YPL2(1+MOD(I-1,NPL2))-YPL1(J)).GT.EPSY).AND. - (ABS(XPL2(1+MOD(I ,NPL2))-XPL1(J)).GT.EPSX.OR. - ABS(YPL2(1+MOD(I ,NPL2))-YPL1(J)).GT.EPSY))THEN IF(N2+1.GT.MXCORN)THEN PRINT *,' !!!!!! PLAOVL WARNING : Too many special'// - ' points around a polygon ; list reduced.' OK=.FALSE. GOTO 250 ENDIF N2=N2+1 XL(N2,2)=XPL1(J) YL(N2,2)=YPL1(J) IT(N2,2)=2 ENDIF * Add crossing points. CALL CRSPND( - XPL2(1+MOD(I-1,NPL2)),YPL2(1+MOD(I-1,NPL2)), - XPL2(1+MOD(I ,NPL2)),YPL2(1+MOD(I ,NPL2)), - XPL1(1+MOD(J-1,NPL1)),YPL1(1+MOD(J-1,NPL1)), - XPL1(1+MOD(J ,NPL1)),YPL1(1+MOD(J ,NPL1)), - XC,YC,ADD) IF(ADD)THEN IF((ABS(XPL2(1+MOD(I-1,NPL2))-XC).LT.EPSX.AND. - ABS(YPL2(1+MOD(I-1,NPL2))-YC).LT.EPSY).OR. - (ABS(XPL2(1+MOD(I,NPL2))-XC).LT.EPSX.AND. - ABS(YPL2(1+MOD(I,NPL2))-YC).LT.EPSY))ADD=.FALSE. IF((ABS(XPL1(1+MOD(J-1,NPL1))-XC).LT.EPSX.AND. - ABS(YPL1(1+MOD(J-1,NPL1))-YC).LT.EPSY).OR. - (ABS(XPL1(1+MOD(J,NPL1))-XC).LT.EPSX.AND. - ABS(YPL1(1+MOD(J,NPL1))-YC).LT.EPSY))ADD=.FALSE. IF((ABS(XPL1(1+MOD(J-1,NPL1))- - XPL2(1+MOD(I-1,NPL2))).LT.EPSX.AND. - ABS(YPL1(1+MOD(J-1,NPL1))- - YPL2(1+MOD(I-1,NPL2))).LT.EPSY).OR. - (ABS(XPL1(1+MOD(J-1,NPL1))- - XPL2(1+MOD(I ,NPL2))).LT.EPSX.AND. - ABS(YPL1(1+MOD(J-1,NPL1))- - YPL2(1+MOD(I ,NPL2))).LT.EPSY).OR. - (ABS(XPL1(1+MOD(J ,NPL1))- - XPL2(1+MOD(I-1,NPL2))).LT.EPSX.AND. - ABS(YPL1(1+MOD(J ,NPL1))- - YPL2(1+MOD(I-1,NPL2))).LT.EPSY).OR. - (ABS(XPL1(1+MOD(J-1,NPL1))- - XPL2(1+MOD(I-1,NPL2))).LT.EPSX.AND. - ABS(YPL1(1+MOD(J-1,NPL1))- - YPL2(1+MOD(I-1,NPL2))).LT.EPSY))ADD=.FALSE. ENDIF IF(ADD)THEN IF(N2+1.GT.MXCORN)THEN PRINT *,' !!!!!! PLAOVL WARNING : Too many special'// - ' points around a polygon ; list reduced.' OK=.FALSE. GOTO 250 ENDIF N2=N2+1 XL(N2,2)=XC YL(N2,2)=YC IT(N2,2)=3 ENDIF 210 CONTINUE * Compute the lambda's for these points. DO 220 J=M2,N2 CALL PLALAM(XPL2(1+MOD(I-1,NPL2)),XL(J,2),XPL2(1+MOD(I,NPL2)), - YPL2(1+MOD(I-1,NPL2)),YL(J,2),YPL2(1+MOD(I,NPL2)),Q(J,2)) 220 CONTINUE * Sort the list by using the lambda's. DO 240 J=M2,N2 QMIN=Q(J,2) IQMIN=J DO 230 K=J+1,N2 IF(Q(K,2).LT.QMIN)THEN IQMIN=K QMIN=Q(K,2) ENDIF 230 CONTINUE IF(J.NE.IQMIN)THEN XAUX=XL(J,2) YAUX=YL(J,2) QAUX=Q (J,2) IAUX=IT(J,2) XL(J,2)=XL(IQMIN,2) YL(J,2)=YL(IQMIN,2) Q (J,2)=Q (IQMIN,2) IT(J,2)=IT(IQMIN,2) XL(IQMIN,2)=XAUX YL(IQMIN,2)=YAUX Q (IQMIN,2)=QAUX IT(IQMIN,2)=IAUX ENDIF 240 CONTINUE * Next vertex. 200 CONTINUE *** Look up the cross-links: from plane 1 to plane 2. DO 300 I=1,N1 IREF(I,1,1)=I NFOUND=0 IREF(I,1,2)=0 DO 310 J=1,N2 IF(ABS(XL(I,1)-XL(J,2)).LT.EPSX.AND. - ABS(YL(I,1)-YL(J,2)).LT.EPSY)THEN NFOUND=NFOUND+1 IREF(I,1,2)=J ENDIF 310 CONTINUE IF(NFOUND.EQ.0.AND.(IT(I,1).EQ.2.OR.IT(I,1).EQ.3))THEN PRINT *,' !!!!!! PLAOVL WARNING : Expected match not'// - ' found (1-2)' IREF(I,1,2)=0 OK=.FALSE. ELSEIF(NFOUND.GT.1)THEN PRINT *,' !!!!!! PLAOVL WARNING : More than 1 match'// - ' found (1-2).' IREF(I,1,2)=0 OK=.FALSE. ENDIF 300 CONTINUE ** Links from plane 2 to plane 1. DO 320 I=1,N2 IREF(I,2,2)=I NFOUND=0 IREF(I,2,1)=0 DO 330 J=1,N1 IF(ABS(XL(I,2)-XL(J,1)).LT.EPSX.AND. - ABS(YL(I,2)-YL(J,1)).LT.EPSY)THEN NFOUND=NFOUND+1 IREF(I,2,1)=J ENDIF 330 CONTINUE IF(NFOUND.EQ.0.AND.(IT(I,2).EQ.2.OR.IT(I,2).EQ.3))THEN PRINT *,' !!!!!! PLAOVL WARNING : Expected match not'// - ' found (2-1).' IREF(I,2,1)=0 OK=.FALSE. ELSEIF(NFOUND.GT.1)THEN PRINT *,' !!!!!! PLAOVL WARNING : More than 1 match'// - ' found (2-1).' IREF(I,2,1)=0 OK=.FALSE. ENDIF 320 CONTINUE * List the points for debugging. IF(LDEBUG)THEN DO 340 J=1,2 WRITE(LUNOUT,'('' ++++++ PLAOVL DEBUG : Polygon '',I1, - '':''/26X,''No Type x y'', - '' Q links'')') J CALL GSMK(2) IF(J.EQ.1)THEN NP=N1 CALL GSMK(2) ELSEIF(J.EQ.2)THEN NP=N2 CALL GSMK(4) ENDIF DO 350 I=1,NP WRITE(LUNOUT,'(25X,I3,I5,2F13.6,F10.3,2I3)') I,IT(I,J), - XL(I,J),YL(I,J),Q(I,J),(IREF(I,J,K),K=1,2) CALL GPM2(1,XL(I,J),YL(I,J)) 350 CONTINUE 340 CONTINUE ENDIF IF(.NOT.OK)RETURN *** See whether all of 1 is inside 2. DO 1000 I=1,N1 IF(IT(I,1).NE.1)GOTO 1200 CALL INTERD(NPL2,XPL2,YPL2,XL(I,1),YL(I,1),INSIDE,EDGE) IF(.NOT.(INSIDE.OR.EDGE))GOTO 1200 1000 CONTINUE ** Apparently 1 really is fully inside 2, write out curve 1. IF(LDEBUG)WRITE(LUNOUT,'(26X,''Curve 1 fully inside 2'')') IF(NREFO+1.LE.MXPLAN)THEN NREFO=NREFO+1 ITYPO(NREFO)=3 CALL PLABU2('STORE',IREFO(NREFO),NPL1,XPL1,YPL1,ZPL1, - APL1,BPL1,CPL1,DPL1,ICOL1,IFAIL1) ELSE PRINT *,' !!!!!! PLAOVL WARNING : Output list'// - ' too long.' RETURN ENDIF C call gpl2(npl1,xpl1,ypl1) * Check there will be room for this. IF(NPL1+NPL2.GT.MXEDGE)THEN PRINT *,' !!!!!! PLAOVL WARNING : Output panel has too'// - ' many vertices; abandoned.' RETURN ENDIF * Find 2 non-crossing connections: JP1-JP2 and KP1-KP2. FIRST=.TRUE. DO 1020 IP1=1,N1 DO 1030 IP2=1,N2 IF((.NOT.FIRST).AND.IP2.EQ.JP2)GOTO 1030 DO 1040 K=1,N1 IF(K.EQ.IP1.OR.1+MOD(K,N1).EQ.IP1)GOTO 1040 CALL CRSPND( - XL(IP1,1), YL(IP1,1) , - XL(IP2,2), YL(IP2,2) , - XL(K,1), YL(K,1) , - XL(1+MOD(K,N1),1),YL(1+MOD(K,N1),1), - XC,YC,CROSS) IF(CROSS)GOTO 1030 1040 CONTINUE DO 1050 K=1,N2 IF(K.EQ.IP2.OR.1+MOD(K,N2).EQ.IP2)GOTO 1050 CALL CRSPND( - XL(IP1,1), YL(IP1,1) , - XL(IP2,2), YL(IP2,2) , - XL(K,2), YL(K,2) , - XL(1+MOD(K,N2),2),YL(1+MOD(K,N2),2), - XC,YC,CROSS) IF(CROSS)GOTO 1030 1050 CONTINUE IF(FIRST)THEN JP1=IP1 JP2=IP2 FIRST=.FALSE. C print *,' First junction: ',jp1,' (1) ',jp2,' (2)' GOTO 1020 ELSE KP1=IP1 KP2=IP2 CALL CRSPND( - XL(IP1,1), YL(IP1,1), - XL(IP2,2), YL(IP2,2), - XL(JP1,1), YL(JP1,1), - XL(JP2,2), YL(JP2,2), - XC,YC,CROSS) IF(.NOT.CROSS)GOTO 1060 ENDIF 1030 CONTINUE 1020 CONTINUE PRINT *,' !!!!!! PLAOVL WARNING : Found no cut-out.' RETURN 1060 CONTINUE C print *,' Second junction: ',kp1,' (1) ',kp2,' (2)' ** Create part 1 of area 2. NPL=0 DO 1070 IP1=JP1,KP1 NPL=NPL+1 XPL(NPL)=XL(IP1,1) YPL(NPL)=YL(IP1,1) 1070 CONTINUE * Try one way. IF(JP2.LT.KP2)THEN IMAX=JP2+N2 ELSE IMAX=JP2 ENDIF IDIR=+1 DO 1080 I=KP2,IMAX IP2=1+MOD(I-1,N2) NPL=NPL+1 XPL(NPL)=XL(IP2,2) YPL(NPL)=YL(IP2,2) 1080 CONTINUE * Check for undesirable crossings. DO 1090 IP1=1,N1 IF(IP1.EQ.JP1.OR.IP1.EQ.KP1)GOTO 1090 CALL INTERD(NPL,XPL,YPL,XL(IP1,1),YL(IP1,1),INSIDE,EDGE) IF(INSIDE)GOTO 1110 1090 CONTINUE GOTO 1120 * Use the other way if this failed 1110 CONTINUE NPL=KP1-JP1+1 IF(JP2.LT.KP2)THEN IMAX=KP2 ELSE IMAX=KP2+N2 ENDIF IDIR=-1 DO 1130 I=IMAX,JP2,-1 IP2=1+MOD(I-1,N2) NPL=NPL+1 XPL(NPL)=XL(IP2,2) YPL(NPL)=YL(IP2,2) 1130 CONTINUE 1120 CONTINUE * Save this part. IF(NREFO+1.LE.MXPLAN)THEN NREFO=NREFO+1 ITYPO(NREFO)=2 CALL PLABU2('STORE',IREFO(NREFO),NPL,XPL,YPL,ZPL, - APL2,BPL2,CPL2,DPL2,ICOL2,IFAIL1) ELSE PRINT *,' !!!!!! PLAOVL WARNING : Output list'// - ' too long.' ENDIF C call gpl2(npl,xpl,ypl) ** Create part 2 of area 2. NPL=0 DO 1140 IP1=KP1,JP1+N1 NPL=NPL+1 XPL(NPL)=XL(1+MOD(IP1-1,N1),1) YPL(NPL)=YL(1+MOD(IP1-1,N1),1) 1140 CONTINUE * Add the part over area 2 IF(IDIR.EQ.-1)THEN IF(JP2.GT.KP2)THEN IMAX=JP2 ELSE IMAX=JP2+N2 ENDIF IDIR=-1 DO 1150 I=IMAX,KP2,-1 IP2=1+MOD(I-1,N2) NPL=NPL+1 XPL(NPL)=XL(IP2,2) YPL(NPL)=YL(IP2,2) 1150 CONTINUE ELSE IF(JP2.GT.KP2)THEN IMAX=KP2+N2 ELSE IMAX=KP2 ENDIF DO 1160 I=JP2,IMAX IP2=1+MOD(I-1,N2) NPL=NPL+1 XPL(NPL)=XL(IP2,2) YPL(NPL)=YL(IP2,2) 1160 CONTINUE ENDIF * Save this part. IF(NREFO+1.LE.MXPLAN)THEN NREFO=NREFO+1 ITYPO(NREFO)=2 CALL PLABU2('STORE',IREFO(NREFO),NPL,XPL,YPL,ZPL, - APL2,BPL2,CPL2,DPL2,ICOL2,IFAIL1) ELSE PRINT *,' !!!!!! PLAOVL WARNING : Output list'// - ' too long.' ENDIF C call gpl2(npl,xpl,ypl) RETURN *** See whether all of 2 is inside 1. 1200 CONTINUE DO 1210 I=1,N2 IF(IT(I,2).NE.1)GOTO 1400 CALL INTERD(NPL1,XPL1,YPL1,XL(I,2),YL(I,2),INSIDE,EDGE) IF(.NOT.(INSIDE.OR.EDGE))GOTO 1400 1210 CONTINUE IF(LDEBUG)WRITE(LUNOUT,'(26X,''Curve 2 inside 1'')') ** Apparently 2 really is fully inside 1, write out curve 2. IF(NREFO+1.LE.MXPLAN)THEN NREFO=NREFO+1 ITYPO(NREFO)=3 CALL PLABU2('STORE',IREFO(NREFO),NPL2,XPL2,YPL2,ZPL2, - APL2,BPL2,CPL2,DPL2,ICOL2,IFAIL1) ELSE PRINT *,' !!!!!! PLAOVL WARNING : Output list'// - ' too long.' ENDIF C call gpl2(npl2,xpl2,ypl2) * Check there will be room for this. IF(NPL1+NPL2.GT.MXEDGE)THEN PRINT *,' !!!!!! PLAOVL WARNING : Output panel has too'// - ' many vertices; abandoned.' RETURN ENDIF * Find 2 non-crossing connections: JP2-JP1 and KP2-KP1. FIRST=.TRUE. DO 1220 IP2=1,N2 DO 1230 IP1=1,N1 IF((.NOT.FIRST).AND.IP1.EQ.JP1)GOTO 1230 DO 1240 K=1,N2 IF(K.EQ.IP2.OR.1+MOD(K,N2).EQ.IP2)GOTO 1240 CALL CRSPND( - XL(IP2,2), YL(IP2,2) , - XL(IP1,1), YL(IP1,1) , - XL(K,2), YL(K,2) , - XL(1+MOD(K,N2),2),YL(1+MOD(K,N2),2), - XC,YC,CROSS) IF(CROSS)GOTO 1230 1240 CONTINUE C print *,' no crossing with 2' DO 1250 K=1,N1 IF(K.EQ.IP1.OR.1+MOD(K,N1).EQ.IP1)GOTO 1250 CALL CRSPND( - XL(IP2,2), YL(IP2,2) , - XL(IP1,1), YL(IP1,1) , - XL(K,1), YL(K,1) , - XL(1+MOD(K,N1),1),YL(1+MOD(K,N1),1), - XC,YC,CROSS) IF(CROSS)GOTO 1230 1250 CONTINUE IF(FIRST)THEN JP2=IP2 JP1=IP1 FIRST=.FALSE. C print *,' First junction: ',jp2,' (2) ',jp1,' (1)' GOTO 1220 ELSE KP2=IP2 KP1=IP1 CALL CRSPND( - XL(IP2,2), YL(IP2,2), - XL(IP1,1), YL(IP1,1), - XL(JP2,2), YL(JP2,2), - XL(JP1,1), YL(JP1,1), - XC,YC,CROSS) IF(.NOT.CROSS)GOTO 1260 ENDIF 1230 CONTINUE 1220 CONTINUE PRINT *,' !!!!!! PLAOVL WARNING : Found no cut-out.' RETURN 1260 CONTINUE C print *,' Second junction: ',kp2,' (2) ',kp1,' (1)' ** Create part 1 of area 1. NPL=0 DO 1270 IP2=JP2,KP2 NPL=NPL+1 XPL(NPL)=XL(IP2,2) YPL(NPL)=YL(IP2,2) 1270 CONTINUE * Try one way. IF(JP1.LT.KP1)THEN IMAX=JP1+N1 ELSE IMAX=JP1 ENDIF IDIR=+1 DO 1280 I=KP1,IMAX IP1=1+MOD(I-1,N1) NPL=NPL+1 XPL(NPL)=XL(IP1,1) YPL(NPL)=YL(IP1,1) 1280 CONTINUE * Check for undesirable crossings. DO 1290 IP2=1,N2 IF(IP2.EQ.JP2.OR.IP2.EQ.KP2)GOTO 1290 CALL INTERD(NPL,XPL,YPL,XL(IP2,2),YL(IP2,2),INSIDE,EDGE) IF(INSIDE)GOTO 1310 1290 CONTINUE GOTO 1320 * Use the other way if this failed 1310 CONTINUE NPL=KP2-JP2+1 IF(JP1.LT.KP1)THEN IMAX=KP1 ELSE IMAX=KP1+N1 ENDIF IDIR=-1 DO 1330 I=IMAX,JP1,-1 IP1=1+MOD(I-1,N1) NPL=NPL+1 XPL(NPL)=XL(IP1,1) YPL(NPL)=YL(IP1,1) 1330 CONTINUE 1320 CONTINUE * Save this part. IF(NREFO+1.LE.MXPLAN)THEN NREFO=NREFO+1 ITYPO(NREFO)=1 CALL PLABU2('STORE',IREFO(NREFO),NPL,XPL,YPL,ZPL, - APL1,BPL1,CPL1,DPL1,ICOL1,IFAIL1) ELSE PRINT *,' !!!!!! PLAOVL WARNING : Output list'// - ' too long.' ENDIF C call gpl2(npl,xpl,ypl) ** Create part 2 of area 1. NPL=0 DO 1340 IP2=KP2,JP2+N2 NPL=NPL+1 XPL(NPL)=XL(1+MOD(IP2-1,N2),2) YPL(NPL)=YL(1+MOD(IP2-1,N2),2) 1340 CONTINUE * Add the part over area 1 IF(IDIR.EQ.-1)THEN IF(JP1.GT.KP1)THEN IMAX=JP1 ELSE IMAX=JP1+N1 ENDIF IDIR=-1 DO 1350 I=IMAX,KP1,-1 IP1=1+MOD(I-1,N1) NPL=NPL+1 XPL(NPL)=XL(IP1,1) YPL(NPL)=YL(IP1,1) 1350 CONTINUE ELSE IF(JP1.GT.KP1)THEN IMAX=KP1+N1 ELSE IMAX=KP1 ENDIF DO 1360 I=JP1,IMAX IP1=1+MOD(I-1,N1) NPL=NPL+1 XPL(NPL)=XL(IP1,1) YPL(NPL)=YL(IP1,1) 1360 CONTINUE ENDIF * Save this part. IF(NREFO+1.LE.MXPLAN)THEN NREFO=NREFO+1 ITYPO(NREFO)=1 CALL PLABU2('STORE',IREFO(NREFO),NPL,XPL,YPL,ZPL, - APL1,BPL1,CPL1,DPL1,ICOL1,IFAIL1) ELSE PRINT *,' !!!!!! PLAOVL WARNING : Output list'// - ' too long.' ENDIF C call gpl2(npl,xpl,ypl) RETURN 1400 CONTINUE *** Identify the parts of 1 that are not overlapped, first mark. DO 400 I=1,MXEDGE MARK1(I)=.FALSE. MARK2(I)=.FALSE. 400 CONTINUE ** Try and find a new starting point 430 CONTINUE IF(LDEBUG)WRITE(LUNOUT,'(26X,''Starting search for'', - '' starting point on 1'')') DO 410 I=1,N1 * Skip parts already processed. IF(MARK1(I).OR.MARK1(1+MOD(I,N1)))GOTO 410 * Skip if mid point is inside other volume. CALL INTERD(NPL2,XPL2,YPL2, - (XL(I,1)+XL(1+MOD(I,N1),1))/2, - (YL(I,1)+YL(1+MOD(I,N1),1))/2, - INSIDE,EDGE) IF(INSIDE.OR.EDGE)GOTO 410 * Found one. IP1=I XPL(1)=XL(IP1,1) YPL(1)=YL(IP1,1) IS1=IP1 MARK1(IP1)=.TRUE. IF(LDEBUG)WRITE(LUNOUT,'(26X,''Start from point '',I5, - '' on curve 1.'')') IP1 IP1=1+MOD(IP1,N1) XPL(2)=XL(IP1,1) YPL(2)=YL(IP1,1) MARK1(IP1)=.TRUE. IF(LDEBUG)WRITE(LUNOUT,'(26X,''Next point is '',I5, - '' on 1.'')') IP1 NPL=2 IL=1 IDIR=0 GOTO 420 410 CONTINUE * Finished IF(LDEBUG)WRITE(LUNOUT,'(26X,''No further non-overlapped'', - '' areas of 1.'')') GOTO 500 * Trace this part of 1 outside 2 420 CONTINUE IF(NPL+1.GT.MXEDGE)THEN PRINT *,' !!!!!! PLAOVL WARNING : Too many vertices on 1.' RETURN * On curve 1 and not on the edge of curve 2 ? ELSEIF(IL.EQ.1.AND.IT(MAX(1,IP1),IL).EQ.1)THEN IP1=1+MOD(IP1,N1) IF(IP1.EQ.IS1)THEN IF(NREFO+1.LE.MXPLAN)THEN NREFO=NREFO+1 ITYPO(NREFO)=1 CALL PLABU2('STORE',IREFO(NREFO),NPL,XPL,YPL,ZPL, - APL1,BPL1,CPL1,DPL1,ICOL1,IFAIL1) ELSE PRINT *,' !!!!!! PLAOVL WARNING : Output list'// - ' too long.' ENDIF C call gpl2(npl,xpl,ypl) IF(LDEBUG)WRITE(LUNOUT,'(26X,''End of curve'', - '' reached, '',I5,'' points'')') NPL GOTO 430 ENDIF MARK1(IP1)=.TRUE. NPL=NPL+1 XPL(NPL)=XL(IP1,IL) YPL(NPL)=YL(IP1,IL) IF(LDEBUG)WRITE(LUNOUT,'(26X,''Went to point '',I5, - '' on curve 1.'')') IP1 * On curve 1 and on the edge of curve 2 ? ELSEIF(IL.EQ.1)THEN IP2=IREF(IP1,1,2) ADDED=.FALSE. IF(IDIR.EQ.+1.OR.IDIR.EQ.0)THEN CALL INTERD(NPL1,XPL1,YPL1, - (XL(IP2,2)+XL(1+MOD(IP2,N2),2))/2, - (YL(IP2,2)+YL(1+MOD(IP2,N2),2))/2, - INSIDE,EDGE) IF(INSIDE)THEN IP2=1+MOD(IP2,N2) IL=2 IDIR=+1 IP1=IREF(IP2,2,1) IF(IP1.EQ.IS1)THEN IF(NREFO+1.LE.MXPLAN)THEN NREFO=NREFO+1 ITYPO(NREFO)=1 CALL PLABU2('STORE',IREFO(NREFO), - NPL,XPL,YPL,ZPL, - APL1,BPL1,CPL1,DPL1,ICOL1,IFAIL1) ELSE PRINT *,' !!!!!! PLAOVL WARNING :'// - ' Output list too long.' ENDIF C call gpl2(npl,xpl,ypl) IF(LDEBUG)WRITE(LUNOUT,'(26X,''End'', - '' reached, '',I5,'' points.'')') NPL GOTO 430 ELSEIF(IP1.NE.0)THEN MARK1(IP1)=.TRUE. ENDIF NPL=NPL+1 XPL(NPL)=XL(IP2,2) YPL(NPL)=YL(IP2,2) ADDED=.TRUE. C print *,' Added point ',ip2,' along 2 +' ENDIF ENDIF IF(IDIR.EQ.-1.OR.IDIR.EQ.0)THEN CALL INTERD(NPL1,XPL1,YPL1, - (XL(IP2,2)+XL(1+MOD(IP2+N2-2,N2),2))/2, - (YL(IP2,2)+YL(1+MOD(IP2+N2-2,N2),2))/2, - INSIDE,EDGE) IF(INSIDE)THEN IP2=1+MOD(IP2+N2-2,N2) IL=2 IDIR=-1 IP1=IREF(IP2,2,1) IF(IP1.EQ.IS1)THEN IF(NREFO+1.LE.MXPLAN)THEN NREFO=NREFO+1 ITYPO(NREFO)=1 CALL PLABU2('STORE',IREFO(NREFO), - NPL,XPL,YPL,ZPL, - APL1,BPL1,CPL1,DPL1,ICOL1,IFAIL1) ELSE PRINT *,' !!!!!! PLAOVL WARNING :'// - ' Output list too long.' ENDIF C call gpl2(npl,xpl,ypl) IF(LDEBUG)WRITE(LUNOUT,'(26X,''End of curve'', - '' reached, '',I5,'' points.'')') NPL GOTO 430 ELSEIF(IP1.NE.0)THEN MARK1(IP1)=.TRUE. ENDIF NPL=NPL+1 XPL(NPL)=XL(IP2,2) YPL(NPL)=YL(IP2,2) ADDED=.TRUE. C print *,' Added point ',ip2,' along 2 -' ENDIF ENDIF IF(.NOT.ADDED)THEN IP1=1+MOD(IP1,N1) IF(IP1.EQ.IS1)THEN IF(NREFO+1.LE.MXPLAN)THEN NREFO=NREFO+1 ITYPO(NREFO)=1 CALL PLABU2('STORE',IREFO(NREFO), - NPL,XPL,YPL,ZPL, - APL1,BPL1,CPL1,DPL1,ICOL1,IFAIL1) ELSE PRINT *,' !!!!!! PLAOVL WARNING :'// - ' Output list too long.' ENDIF C call gpl2(npl,xpl,ypl) IF(LDEBUG)WRITE(LUNOUT,'(26X,''End of curve'', - '' reached, '',I5,'' points.'')') NPL GOTO 430 ELSEIF(IP1.NE.0)THEN MARK1(IP1)=.TRUE. ENDIF NPL=NPL+1 XPL(NPL)=XL(IP1,IL) YPL(NPL)=YL(IP1,IL) IF(LDEBUG)WRITE(LUNOUT,'(26X,''Continued over 1'')') ENDIF * On curve 2 normal vertex (outside 1 hopefully). ELSEIF(IL.EQ.2.AND.IT(MAX(1,IP2),2).EQ.1)THEN IP2=1+MOD(IP2+IDIR-1+N2,N2) IP1=IREF(IP2,2,1) IF(IP1.EQ.IS1)THEN IF(NREFO+1.LE.MXPLAN)THEN NREFO=NREFO+1 ITYPO(NREFO)=1 CALL PLABU2('STORE',IREFO(NREFO),NPL,XPL,YPL,ZPL, - APL1,BPL1,CPL1,DPL1,ICOL1,IFAIL1) ELSE PRINT *,' !!!!!! PLAOVL WARNING : Output list'// - ' too long.' ENDIF C call gpl2(npl,xpl,ypl) IF(LDEBUG)WRITE(LUNOUT,'(26X,''End of curve'', - '' reached, '',I5,'' points.'')') NPL GOTO 430 ELSEIF(IP1.NE.0)THEN MARK1(IP1)=.TRUE. ENDIF NPL=NPL+1 XPL(NPL)=XL(IP2,IL) YPL(NPL)=YL(IP2,IL) C print *,' Went to point ',ip2,' on 2.' * On curve 2 and on edge of 1 ELSEIF(IL.EQ.2)THEN IP1=IREF(IP2,2,1) IP1=1+MOD(IP1,N1) IL=1 IF(IP1.EQ.IS1)THEN IF(NREFO+1.LE.MXPLAN)THEN NREFO=NREFO+1 ITYPO(NREFO)=1 CALL PLABU2('STORE',IREFO(NREFO),NPL,XPL,YPL,ZPL, - APL1,BPL1,CPL1,DPL1,ICOL1,IFAIL1) ELSE PRINT *,' !!!!!! PLAOVL WARNING : Output list'// - ' too long.' ENDIF C call gpl2(npl,xpl,ypl) IF(LDEBUG)WRITE(LUNOUT,'(26X,''End of curve'', - '' reached, '',I5,'' points.'')') NPL GOTO 430 ENDIF NPL=NPL+1 XPL(NPL)=XL(IP1,IL) YPL(NPL)=YL(IP1,IL) C print *,' Resumed 1 at point ',ip1 * Other cases should not occur ELSE PRINT *,' !!!!!! PLAOVL : Unexpected case.' ENDIF GOTO 420 *** Same for curve 2. 500 CONTINUE IF(LDEBUG)WRITE(LUNOUT,'(26X,''Starting search for'', - '' starting point on 2'')') DO 510 I=1,N2 * Skip parts already processed. IF(MARK2(I).OR.MARK2(1+MOD(I,N2)))GOTO 510 * Skip if mid point is inside other volume. CALL INTERD(NPL1,XPL1,YPL1, - (XL(I,2)+XL(1+MOD(I,N2),2))/2, - (YL(I,2)+YL(1+MOD(I,N2),2))/2, - INSIDE,EDGE) IF(INSIDE.OR.EDGE)GOTO 510 * Found one. IP2=I XPL(1)=XL(IP2,2) YPL(1)=YL(IP2,2) IS2=IP2 MARK2(IP2)=.TRUE. C print *,' Start from point ',ip2,' on 2.' IP2=1+MOD(IP2,N2) XPL(2)=XL(IP2,2) YPL(2)=YL(IP2,2) MARK2(IP2)=.TRUE. C print *,' Next point is ',ip2,' on 2.' NPL=2 IL=2 IDIR=0 GOTO 520 510 CONTINUE * Finished IF(LDEBUG)WRITE(LUNOUT,'(26X,''No further non-overlapped'', - '' areas of 2.'')') GOTO 600 * Trace this part of 2 outside 1 520 CONTINUE IF(NPL+1.GT.MXEDGE)THEN PRINT *,' !!!!!! PLAOVL WARNING : Too many vertices on 2.' RETURN * On curve 2 and not on the edge of curve 1 ? ELSEIF(IL.EQ.2.AND.IT(MAX(1,IP2),IL).EQ.1)THEN IP2=1+MOD(IP2,N2) IF(IP2.EQ.IS2)THEN IF(NREFO+1.LE.MXPLAN)THEN NREFO=NREFO+1 ITYPO(NREFO)=2 CALL PLABU2('STORE',IREFO(NREFO),NPL,XPL,YPL,ZPL, - APL2,BPL2,CPL2,DPL2,ICOL2,IFAIL1) ELSE PRINT *,' !!!!!! PLAOVL WARNING : Output list'// - ' too long.' ENDIF C call gpl2(npl,xpl,ypl) IF(LDEBUG)WRITE(LUNOUT,'(26X,''End of curve'', - '' reached, '',I5,'' points.'')') NPL GOTO 500 ENDIF MARK2(IP2)=.TRUE. NPL=NPL+1 XPL(NPL)=XL(IP2,IL) YPL(NPL)=YL(IP2,IL) C print *,' Went to point ',ip2,' on 2.' * On curve 2 and on the edge of curve 1 ? ELSEIF(IL.EQ.2)THEN IP1=IREF(IP2,2,1) ADDED=.FALSE. IF(IDIR.EQ.+1.OR.IDIR.EQ.0)THEN CALL INTERD(NPL2,XPL2,YPL2, - (XL(IP1,1)+XL(1+MOD(IP1,N1),1))/2, - (YL(IP1,1)+YL(1+MOD(IP1,N1),1))/2, - INSIDE,EDGE) IF(INSIDE)THEN IP1=1+MOD(IP1,N1) IL=1 IDIR=+1 IP2=IREF(IP1,1,2) IF(IP2.EQ.IS2)THEN IF(NREFO+1.LE.MXPLAN)THEN NREFO=NREFO+1 ITYPO(NREFO)=2 CALL PLABU2('STORE',IREFO(NREFO), - NPL,XPL,YPL,ZPL, - APL2,BPL2,CPL2,DPL2,ICOL2,IFAIL1) ELSE PRINT *,' !!!!!! PLAOVL WARNING :'// - ' Output list too long.' ENDIF C call gpl2(npl,xpl,ypl) C print *,' End reached, ',npl,' points' GOTO 500 ELSEIF(IP2.NE.0)THEN MARK2(IP2)=.TRUE. ENDIF NPL=NPL+1 XPL(NPL)=XL(IP1,1) YPL(NPL)=YL(IP1,1) ADDED=.TRUE. C print *,' Added point ',ip1,' along 1 +' ENDIF ENDIF IF(IDIR.EQ.-1.OR.IDIR.EQ.0)THEN CALL INTERD(NPL2,XPL2,YPL2, - (XL(IP1,1)+XL(1+MOD(IP1+N1-2,N1),1))/2, - (YL(IP1,1)+YL(1+MOD(IP1+N1-2,N1),1))/2, - INSIDE,EDGE) IF(INSIDE)THEN IP1=1+MOD(IP1+N1-2,N1) IL=1 IDIR=-1 IP2=IREF(IP1,1,2) IF(IP2.EQ.IS2)THEN IF(NREFO+1.LE.MXPLAN)THEN NREFO=NREFO+1 ITYPO(NREFO)=2 CALL PLABU2('STORE',IREFO(NREFO), - NPL,XPL,YPL,ZPL, - APL2,BPL2,CPL2,DPL2,ICOL2,IFAIL1) ELSE PRINT *,' !!!!!! PLAOVL WARNING :'// - ' Output list too long.' ENDIF C call gpl2(npl,xpl,ypl) C print *,' End reached, ',npl,' points' GOTO 500 ELSEIF(IP2.NE.0)THEN MARK2(IP2)=.TRUE. ENDIF NPL=NPL+1 XPL(NPL)=XL(IP1,1) YPL(NPL)=YL(IP1,1) ADDED=.TRUE. C print *,' Added point ',ip1,' along 1 -' ENDIF ENDIF IF(.NOT.ADDED)THEN IP2=1+MOD(IP2,N2) IF(IP2.EQ.IS2)THEN IF(NREFO+1.LE.MXPLAN)THEN NREFO=NREFO+1 ITYPO(NREFO)=2 CALL PLABU2('STORE',IREFO(NREFO), - NPL,XPL,YPL,ZPL, - APL2,BPL2,CPL2,DPL2,ICOL2,IFAIL1) ELSE PRINT *,' !!!!!! PLAOVL WARNING :'// - ' Output list too long.' ENDIF C call gpl2(npl,xpl,ypl) IF(LDEBUG)WRITE(LUNOUT,'(26X,''End of curve'', - '' reached, '',I5,'' points.'')') NPL GOTO 500 ELSEIF(IP2.NE.0)THEN MARK2(IP2)=.TRUE. ENDIF NPL=NPL+1 XPL(NPL)=XL(IP2,IL) YPL(NPL)=YL(IP2,IL) C print *,' Continued over 2' ENDIF * On curve 1 normal vertex (outside 2 hopefully). ELSEIF(IL.EQ.1.AND.IT(MAX(1,IP1),1).EQ.1)THEN IP1=1+MOD(IP1+IDIR-1+N1,N1) IP2=IREF(IP1,1,2) IF(IP2.EQ.IS2)THEN IF(NREFO+1.LE.MXPLAN)THEN NREFO=NREFO+1 ITYPO(NREFO)=2 CALL PLABU2('STORE',IREFO(NREFO),NPL,XPL,YPL,ZPL, - APL2,BPL2,CPL2,DPL2,ICOL2,IFAIL1) ELSE PRINT *,' !!!!!! PLAOVL WARNING : Output list'// - ' too long.' ENDIF C call gpl2(npl,xpl,ypl) IF(LDEBUG)WRITE(LUNOUT,'(26X,''End of curve'', - '' reached, '',I5,'' points.'')') NPL GOTO 500 ELSEIF(IP2.NE.0)THEN MARK2(IP2)=.TRUE. ENDIF NPL=NPL+1 XPL(NPL)=XL(IP1,IL) YPL(NPL)=YL(IP1,IL) C print *,' Went to point ',ip1,' on 1.' * On curve 1 and on edge of 2 ELSEIF(IL.EQ.1)THEN IP2=IREF(IP1,1,2) IP2=1+MOD(IP2,N2) IL=2 IF(IP2.EQ.IS2)THEN IF(NREFO+1.LE.MXPLAN)THEN NREFO=NREFO+1 ITYPO(NREFO)=2 CALL PLABU2('STORE',IREFO(NREFO),NPL,XPL,YPL,ZPL, - APL2,BPL2,CPL2,DPL2,ICOL2,IFAIL1) ELSE PRINT *,' !!!!!! PLAOVL WARNING : Output list'// - ' too long.' ENDIF C call gpl2(npl,xpl,ypl) IF(LDEBUG)WRITE(LUNOUT,'(26X,''End of curve'', - '' reached, '',I5,'' points.'')') NPL GOTO 500 ENDIF NPL=NPL+1 XPL(NPL)=XL(IP2,IL) YPL(NPL)=YL(IP2,IL) C print *,' Resumed 1 at point ',ip2 * Other cases should not occur ELSE PRINT *,' !!!!!! PLAOVL : Unexpected case.' ENDIF GOTO 520 *** Reset the flags. 600 CONTINUE DO 640 I=1,N1 MARK1(I)=.FALSE. 640 CONTINUE *** Look for the overlapped parts. 630 CONTINUE IF(LDEBUG)WRITE(LUNOUT,'(26X,''Starting search for'', - '' starting point on overlap.'')') DO 610 I=1,N1 * Skip points already processed. IF(MARK1(I))GOTO 610 * Skip if not an edge point on both 1 and 2 or internal in 2. IF(LDEBUG)WRITE(LUNOUT,'(26X,''ip1 = '',2I5,'' ip2 = '', - 2I5)') I,IT(I,1),IREF(I,1,2),IT(MAX(1,IREF(I,1,2)),2) IP1=I IP2=IREF(IP1,1,2) IF(IP2.EQ.0.OR.IT(IP1,1).EQ.1)THEN CALL INTERD(NPL2,XPL2,YPL2,XL(IP1,1),YL(IP1,1), - INSIDE,EDGE) IF(.NOT.(INSIDE.OR.EDGE))GOTO 610 ELSEIF(IT(IP2,2).EQ.1)THEN GOTO 610 ENDIF * Found one. NPL=1 XPL(1)=XL(IP1,1) YPL(1)=YL(IP1,1) IS1=IP1 IS2=IP2 IL=1 IDIR=0 MARK1(IP1)=.TRUE. IF(LDEBUG)WRITE(LUNOUT,'(26X,''Start from point '',I5, - '' on curve '',I5)') IP1,IL GOTO 620 610 CONTINUE * Finished IF(LDEBUG)WRITE(LUNOUT,'(26X,''No further overlapped areas.'')') GOTO 700 * Trace this overlapped part. IP1L=-1 IP1LL=-1 620 CONTINUE IP1LL=IP1L IP1L=IP1 ** Is there still room ? IF(NPL+1.GT.MXEDGE)THEN PRINT *,' !!!!!! PLAOVL WARNING : Too many vertices in'// - ' overlapped part.' RETURN ** On curve 1, see which way to continue. ELSEIF(IL.EQ.1)THEN * Maybe finished over line 1 ? IF(1+MOD(IP1,N1).EQ.IS1)THEN IF(NPL.LE.2)THEN IF(LDEBUG)WRITE(LUNOUT,'(26X,''Too few points'')') ELSEIF(NREFO+1.LE.MXPLAN)THEN NREFO=NREFO+1 ITYPO(NREFO)=3 CALL PLABU2('STORE',IREFO(NREFO),NPL,XPL,YPL,ZPL, - APL1,BPL1,CPL1,DPL1,ICOL1,IFAIL1) ELSE PRINT *,' !!!!!! PLAOVL WARNING : Output list'// - ' too long.' ENDIF C call gpl2(npl,xpl,ypl) IF(LDEBUG)WRITE(LUNOUT,'(26X,''End of curve'', - '' reached, '',I5,'' points.'')') NPL GOTO 630 ENDIF * See whether the next point of 1 is on the edge or inside of 2. INSIDE=.FALSE. EDGE=.FALSE. IF(IREF(1+MOD(IP1,N1),1,2).GT.0)THEN EDGE=.TRUE. ELSEIF(IT(1+MOD(IP1,N1),1).EQ.1)THEN CALL INTERD(NPL2,XPL2,YPL2, - XL(1+MOD(IP1,N1),1),YL(1+MOD(IP1,N1),1), - INSIDE,EDGE) ENDIF * If it is, check that it doesn't leave 2 at any stage. IF(INSIDE.OR.EDGE)CALL INTERD(NPL2,XPL2,YPL2, - 0.5*(XL(IP1,1)+XL(1+MOD(IP1,N1),1)), - 0.5*(YL(IP1,1)+YL(1+MOD(IP1,N1),1)), - INSIDE,EDGE) * If it is, continue over 1. IF(INSIDE.OR.EDGE)THEN IP1=1+MOD(IP1,N1) IF(LDEBUG)WRITE(LUNOUT,'(26X,''Continued to point '', - I5,'' on '',I5)') IP1,IL NPL=NPL+1 XPL(NPL)=XL(IP1,1) YPL(NPL)=YL(IP1,1) MARK1(IP1)=.TRUE. GOTO 620 ENDIF * Else we have to continue over 2, ensure we really are on curve 2. IP2=IREF(IP1,1,2) IF(IP2.EQ.0)THEN PRINT *,' !!!!!! PLAOVL WARNING : No point 2'// - ' reference found; abandoned.' RETURN ENDIF * Impose a direction on 2 to avoid returning. IF(IDIR.EQ.0)THEN IF(LDEBUG)WRITE(LUNOUT,'(26X,''Checking directions'', - '' at point '',I5,'' of curve 2.''/26X, - ''2+ ref on 1: '',I5,'', 2- ref on 1: '',I5)') - IP2,IREF(1+MOD(IP2,N2),2,1), - IREF(1+MOD(IP2-2+N2,N2),2,1) IF(IREF(1+MOD(IP2,N2),2,1).EQ.IP1LL.AND. - IREF(1+MOD(IP2-2+N2,N2),2,1).EQ.IP1LL)THEN PRINT *,' !!!!!! PLAOVL WARNING : Both 2+'// - ' and 2- return on 1; not stored.' GOTO 630 ELSEIF(IREF(1+MOD(IP2,N2),2,1).EQ.IP1LL)THEN IF(LDEBUG)WRITE(LUNOUT,'(26X,''2+ is a return'', - '' to previous point on 1.'')') IDIR=-1 ELSEIF(IREF(1+MOD(IP2-2+N2,N2),2,1).EQ.IP1LL)THEN IF(LDEBUG)WRITE(LUNOUT,'(26X,''2- is a return'', - '' to previous point on 1.'')') IDIR=+1 ELSE IF(LDEBUG)WRITE(LUNOUT,'(26X,''Both ways are OK.'')') ENDIF ENDIF * If not, try to continue over 2 in the + direction.. IF(IDIR.EQ.+1.OR.IDIR.EQ.0)THEN IP2=1+MOD(IP2,N2) IF(IP2.EQ.IS2)THEN IF(LDEBUG)WRITE(LUNOUT,'(26X, - ''Return to start over 2+'')') IF(NPL.LE.2)THEN IF(LDEBUG)WRITE(LUNOUT,'(26X, - ''Too few points'')') ELSEIF(NREFO+1.LE.MXPLAN)THEN NREFO=NREFO+1 ITYPO(NREFO)=3 CALL PLABU2('STORE',IREFO(NREFO), - NPL,XPL,YPL,ZPL, - APL1,BPL1,CPL1,DPL1,ICOL1,IFAIL1) ELSE PRINT *,' !!!!!! PLAOVL WARNING : Output'// - ' list too long.' ENDIF GOTO 630 ENDIF CALL INTERD(NPL1,XPL1,YPL1,XL(IP2,2),YL(IP2,2), - INSIDE,EDGE) IF(INSIDE.OR.EDGE)THEN IF(LDEBUG)WRITE(LUNOUT,'(26X,''Going to 2+'', - '' (point '',I5,'' of 2)'')') IP2 NPL=NPL+1 XPL(NPL)=XL(IP2,2) YPL(NPL)=YL(IP2,2) IDIR=+1 IF(IREF(IP2,2,1).NE.0)THEN IP1=IREF(IP2,2,1) MARK1(IP1)=.TRUE. IL=1 IF(LDEBUG)WRITE(LUNOUT,'(26X,''This point'', - '' is also on curve 1: '',I5)') IP1 ELSE IL=2 ENDIF GOTO 620 ENDIF IP2=1+MOD(IP2-2+N2,N2) ENDIF * Or if this still fails, try 2 in the - direction.. IF(IDIR.EQ.-1.OR.IDIR.EQ.0)THEN IP2=1+MOD(IP2-2+N2,N2) IF(IP2.EQ.IS2)THEN IF(LDEBUG)WRITE(LUNOUT,'(26X, - ''Return to start over 2-'')') IF(NPL.LE.2)THEN IF(LDEBUG)WRITE(LUNOUT,'(26X, - ''Too few points'')') ELSEIF(NREFO+1.LE.MXPLAN)THEN NREFO=NREFO+1 ITYPO(NREFO)=3 CALL PLABU2('STORE',IREFO(NREFO), - NPL,XPL,YPL,ZPL, - APL1,BPL1,CPL1,DPL1,ICOL1,IFAIL1) ELSE PRINT *,' !!!!!! PLAOVL WARNING : Output'// - ' list too long.' ENDIF GOTO 630 ENDIF CALL INTERD(NPL1,XPL1,YPL1,XL(IP2,2),YL(IP2,2), - INSIDE,EDGE) IF(INSIDE.OR.EDGE)THEN IF(LDEBUG)WRITE(LUNOUT,'(26X,''Going to 2-'', - '' (point '',I5,'' of 2)'')') IP2 NPL=NPL+1 XPL(NPL)=XL(IP2,2) YPL(NPL)=YL(IP2,2) IDIR=-1 IF(IREF(IP2,2,1).NE.0)THEN IP1=IREF(IP2,2,1) MARK1(IP1)=.TRUE. IL=1 IF(LDEBUG)WRITE(LUNOUT,'(26X,''This point'', - '' is also on 1: '',I5)') IP1 ELSE IL=2 ENDIF GOTO 620 ENDIF ENDIF * Should not get here IF(LDEBUG)WRITE(LUNOUT,'(26X,''Dead end.'')') GOTO 630 ** If we are on curve 2 ELSEIF(IL.EQ.2)THEN * Ensure the direction is set IF(IDIR.EQ.0)THEN PRINT *,' !!!!!! PLAOVL WARNING : Direction not'// - ' set; abandoned.' RETURN ENDIF * Maybe finished over line 2 ? IP2=1+MOD(IP2+IDIR-1+N2,N2) IF(IP2.EQ.IS2)THEN IF(NPL.LE.2)THEN IF(LDEBUG)WRITE(LUNOUT,'(26X,''Too few points'')') ELSEIF(NREFO+1.LE.MXPLAN)THEN NREFO=NREFO+1 ITYPO(NREFO)=3 CALL PLABU2('STORE',IREFO(NREFO),NPL,XPL,YPL,ZPL, - APL1,BPL1,CPL1,DPL1,ICOL1,IFAIL1) ELSE PRINT *,' !!!!!! PLAOVL WARNING : Output list'// - ' too long.' ENDIF C call gpl2(npl,xpl,ypl) IF(LDEBUG)WRITE(LUNOUT,'(26X,''End of curve'', - '' reached, '',I5,'' points.'')') NPL GOTO 630 ENDIF * Next step over 2. IF(LDEBUG)WRITE(LUNOUT,'(26X,''Stepped over 2 to point '', - I5,'' of 2.'')') IP2 NPL=NPL+1 XPL(NPL)=XL(IP2,2) YPL(NPL)=YL(IP2,2) IF(IREF(IP2,2,1).NE.0)THEN IP1=IREF(IP2,2,1) MARK1(IP1)=.TRUE. IL=1 IF(LDEBUG)WRITE(LUNOUT,'(26X,''This point is also'', - '' on curve 1: '',I5)') IP1 ELSE IL=2 ENDIF GOTO 620 ENDIF 700 CONTINUE IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLAOVL DEBUG : Ready'', - '' - no errors.'')') *** Seems to have worked. IFAIL=0 RETURN *** Error. 250 CONTINUE PRINT *,' !!!!!! PLAOVL WARNING : Abandoning after error. ' IFAIL=1 END +DECK,PLAEQU. SUBROUTINE PLAEQU(IREF1,IREF2,EPSX,EPSY,EQUAL) *----------------------------------------------------------------------- * PLAEQU - Determines whether 2 planes are equal. * (Last changed on 8/ 5/10.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. LOGICAL EQUAL,ONLIND INTEGER IREF1,IREF2,NPL1,NPL2,ICOL1,IFAIL1,ICOL2,IFAIL2,I,J DOUBLE PRECISION EPSX,EPSY, - XPL1(MXEDGE),YPL1(MXEDGE),ZPL1(MXEDGE),APL1,BPL1,CPL1,DPL1, - XPL2(MXEDGE),YPL2(MXEDGE),ZPL2(MXEDGE),APL2,BPL2,CPL2,DPL2 EXTERNAL ONLIND *** Initial value. EQUAL=.FALSE. *** Retrieve both planes. CALL PLABU2('READ',IREF1,NPL1,XPL1,YPL1,ZPL1,APL1,BPL1,CPL1,DPL1, - ICOL1,IFAIL1) CALL PLABU2('READ',IREF2,NPL2,XPL2,YPL2,ZPL2,APL2,BPL2,CPL2,DPL2, - ICOL2,IFAIL2) IF(IFAIL1.NE.0.OR.IFAIL2.NE.0)THEN PRINT *,' !!!!!! PLAEQU WARNING : Unable to retrieve a'// - ' projected polygon; declared not equal.' IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLAEQU DEBUG :''// - '' Reference numbers: '',2I4)') IREF1,IREF2 EQUAL=.FALSE. RETURN ENDIF IF(LDEBUG)THEN WRITE(LUNOUT,'('' ++++++ PLAEQU DEBUG : Curve 1'', - '' has '',I5,'' points.'')') NPL1 DO 50 I=1,NPL1 WRITE(LUNOUT,'(2X,I3,F13.6,2X,F13.6)') I,XPL1(I),YPL1(I) 50 CONTINUE WRITE(LUNOUT,'('' Curve 2'', - '' has '',I5,'' points.'')') NPL2 DO 60 I=1,NPL2 WRITE(LUNOUT,'(2X,I3,F13.6,2X,F13.6)') I,XPL2(I),YPL2(I) 60 CONTINUE ENDIF *** If 0 length, simply return. IF(NPL1.LE.0.OR.NPL2.LE.0)THEN EQUAL=.FALSE. RETURN ENDIF *** Compare all points of 1 with all points of 2. DO 10 I=1,NPL1 * Loop over 2 until a match is found. DO 20 J=1,NPL2 IF(ABS(XPL2(J)-XPL1(I)).LT.EPSX.AND. - ABS(YPL2(J)-YPL1(I)).LT.EPSY)GOTO 10 IF(ONLIND(XPL2(1+MOD(J-1,NPL2)),YPL2(1+MOD(J-1,NPL2)), - XPL2(1+MOD(J ,NPL2)),YPL2(1+MOD(J ,NPL2)), - XPL1(I ),YPL1(I) ))GOTO 10 20 CONTINUE IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLAEQU DEBUG :'', - '' No match on 2 for point '',I5,'' of 1.'')') I EQUAL=.FALSE. RETURN 10 CONTINUE *** Compare all points of 2 with all points of 1. DO 30 I=1,NPL2 * Loop over 2 until a match is found. DO 40 J=1,NPL1 IF(ABS(XPL2(J)-XPL1(I)).LT.EPSX.AND. - ABS(YPL2(J)-YPL1(I)).LT.EPSY)GOTO 30 IF(ONLIND(XPL1(1+MOD(J-1,NPL1)),YPL1(1+MOD(J-1,NPL1)), - XPL1(1+MOD(J ,NPL1)),YPL1(1+MOD(J ,NPL1)), - XPL2(I ),YPL2(I) ))GOTO 30 40 CONTINUE IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLAEQU DEBUG :'', - '' No match on 1 for point '',I5,'' of 2.'')') I EQUAL=.FALSE. RETURN 30 CONTINUE *** If we get this far, the curves are the same. EQUAL=.TRUE. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLAEQU DEBUG :'', - '' Curves match.'')') END +DECK,PLATRO. SUBROUTINE PLATRO(IREF,NREFO,IREFO,IFAIL) *----------------------------------------------------------------------- * PLATRO - Cuts a polygon into right-angled triangles. * (Last changed on 21/10/10.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CONSTANTS. +SEQ,BEMDATA. DOUBLE PRECISION XPL1(MXEDGE),YPL1(MXEDGE),ZPL1(MXEDGE),ZMEAN, - XPL(MXEDGE),YPL(MXEDGE),ZPL(MXEDGE),XC,YC, - EPSANG,EPSXYZ,AN1,BN1,CN1,DN1,DIST,A1,A2,A3 C ,PROD INTEGER I,IREF,IFAIL,IFAIL1,IFAIL2,NPL1,ICOL1,IP1,JP1,I1,I2,I3, - IREFO(MXPLAN),NREFO LOGICAL CROSSD,INSIDE,EDGE EXTERNAL CROSSD *** Assume failure. IFAIL=1 *** Establish tolerances. EPSANG = BEMEPA EPSXYZ = BEMEPD CALL EPSSET('SET',EPSXYZ,EPSXYZ,EPSXYZ) *** Zero the output buffer. NREFO=0 *** Retrieve the polygon. CALL PLABU2('READ',IREF,NPL1,XPL1,YPL1,ZPL1, - AN1,BN1,CN1,DN1,ICOL1,IFAIL1) C print *,' Polygon of ',npl1,' nodes' * Delete the original. CALL PLABU2('DELETE',IREF,NPL1,XPL1,YPL1,ZPL1, - AN1,BN1,CN1,DN1,ICOL1,IFAIL2) * Resume for another pass. 100 CONTINUE * Check successful reading. IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! PLATRO WARNING : Panel ',IREF, - ' does not exist.' IFAIL=1 RETURN * Too few nodes ELSEIF(NPL1.LE.2)THEN IFAIL=0 RETURN * See whether this is a right-angled triangle. ELSEIF(NPL1.EQ.3.AND. - ABS((XPL1(1)-XPL1(2))*(XPL1(3)-XPL1(2))+ - (YPL1(1)-YPL1(2))*(YPL1(3)-YPL1(2))).LT.EPSANG* - SQRT(((XPL1(1)-XPL1(2))**2+(YPL1(1)-YPL1(2))**2)* - ((XPL1(3)-XPL1(2))**2+(YPL1(3)-YPL1(2))**2)))THEN C print *,' Right-angled triangle node 2' IF(NREFO+1.LE.MXPLAN)THEN NREFO=NREFO+1 CALL PLABU2('STORE',IREFO(NREFO),NPL1,XPL1,YPL1,ZPL1, - AN1,BN1,CN1,DN1,ICOL1,IFAIL1) ELSE PRINT *,' !!!!!! PLATRO WARNING : Output list'// - ' too long.' RETURN ENDIF IFAIL=0 RETURN * See whether this is a right-angled triangle. ELSEIF(NPL1.EQ.3.AND. - ABS((XPL1(1)-XPL1(3))*(XPL1(2)-XPL1(3))+ - (YPL1(1)-YPL1(3))*(YPL1(2)-YPL1(3))).LT.EPSANG* - SQRT(((XPL1(1)-XPL1(3))**2+(YPL1(1)-YPL1(3))**2)* - ((XPL1(2)-XPL1(3))**2+(YPL1(2)-YPL1(3))**2)))THEN C print *,' Right-angled triangle node 3' XPL(1)=XPL1(2) YPL(1)=YPL1(2) ZPL(1)=ZPL1(2) XPL(2)=XPL1(3) YPL(2)=YPL1(3) ZPL(2)=ZPL1(3) XPL(3)=XPL1(1) YPL(3)=YPL1(1) ZPL(3)=ZPL1(1) IF(NREFO+1.LE.MXPLAN)THEN NREFO=NREFO+1 CALL PLABU2('STORE',IREFO(NREFO),3,XPL,YPL,ZPL, - AN1,BN1,CN1,DN1,ICOL1,IFAIL1) ELSE PRINT *,' !!!!!! PLATRO WARNING : Output list'// - ' too long.' RETURN ENDIF IFAIL=0 RETURN * See whether this is a right-angled triangle. ELSEIF(NPL1.EQ.3.AND. - ABS((XPL1(3)-XPL1(1))*(XPL1(2)-XPL1(1))+ - (YPL1(3)-YPL1(1))*(YPL1(2)-YPL1(1))).LT.EPSANG* - SQRT(((XPL1(3)-XPL1(1))**2+(YPL1(3)-YPL1(1))**2)* - ((XPL1(2)-XPL1(1))**2+(YPL1(2)-YPL1(1))**2)))THEN C print *,' Right-angled triangle node 1' XPL(1)=XPL1(3) YPL(1)=YPL1(3) ZPL(1)=ZPL1(3) XPL(2)=XPL1(1) YPL(2)=YPL1(1) ZPL(2)=ZPL1(1) XPL(3)=XPL1(2) YPL(3)=YPL1(2) ZPL(3)=ZPL1(2) IF(NREFO+1.LE.MXPLAN)THEN NREFO=NREFO+1 CALL PLABU2('STORE',IREFO(NREFO),3,XPL,YPL,ZPL, - AN1,BN1,CN1,DN1,ICOL1,IFAIL1) ELSE PRINT *,' !!!!!! PLATRO WARNING : Output list'// - ' too long.' RETURN ENDIF IFAIL=0 RETURN * See whether this is a rectangle. ELSEIF(NPL1.EQ.4.AND. - ABS((XPL1(1)-XPL1(2))*(XPL1(3)-XPL1(2))+ - (YPL1(1)-YPL1(2))*(YPL1(3)-YPL1(2))).LT.EPSANG* - SQRT(((XPL1(1)-XPL1(2))**2+(YPL1(1)-YPL1(2))**2)* - ((XPL1(3)-XPL1(2))**2+(YPL1(3)-YPL1(2))**2)).AND. - ABS((XPL1(2)-XPL1(3))*(XPL1(4)-XPL1(3))+ - (YPL1(2)-YPL1(3))*(YPL1(4)-YPL1(3))).LT.EPSANG* - SQRT(((XPL1(2)-XPL1(3))**2+(YPL1(2)-YPL1(3))**2)* - ((XPL1(4)-XPL1(3))**2+(YPL1(4)-YPL1(3))**2)).AND. - ABS((XPL1(1)-XPL1(4))*(XPL1(3)-XPL1(4))+ - (YPL1(1)-YPL1(4))*(YPL1(3)-YPL1(4))).LT.EPSANG* - SQRT(((XPL1(1)-XPL1(4))**2+(YPL1(1)-YPL1(4))**2)* - ((XPL1(3)-XPL1(4))**2+(YPL1(3)-YPL1(4))**2)))THEN C print *,' Rectangle' IF(NREFO+1.LE.MXPLAN)THEN NREFO=NREFO+1 CALL PLABU2('STORE',IREFO(NREFO),NPL1,XPL1,YPL1,ZPL1, - AN1,BN1,CN1,DN1,ICOL1,IFAIL1) ELSE PRINT *,' !!!!!! PLATRO WARNING : Output list'// - ' too long.' RETURN ENDIF IFAIL=0 RETURN ENDIF *** Scan over the nodes, finding the right angles ZMEAN=0 DO 10 IP1=1,NPL1 * Check for zero-length edges. DIST=SQRT(((XPL1(1+MOD(IP1-2+NPL1,NPL1))-XPL1(IP1))**2+ - (YPL1(1+MOD(IP1-2+NPL1,NPL1))-YPL1(IP1))**2)* - ((XPL1(1+MOD(IP1,NPL1)) -XPL1(IP1))**2+ - (YPL1(1+MOD(IP1,NPL1)) -YPL1(IP1))**2)) IF(DIST.LE.0)THEN PRINT *,' !!!!!! PLATRO WARNING : Found zero-length', - ' edge in panel ',IREF,'; rejected.' RETURN ENDIF C PROD=((XPL1(1+MOD(IP1-2+NPL1,NPL1))-XPL1(IP1))* C - (XPL1(1+MOD(IP1,NPL1)) -XPL1(IP1))+ C - (YPL1(1+MOD(IP1-2+NPL1,NPL1))-YPL1(IP1))* C - (YPL1(1+MOD(IP1,NPL1)) -YPL1(IP1)))/DIST * Track the mean z. ZMEAN=ZMEAN+ZPL1(IP1) 10 CONTINUE ZMEAN=ZMEAN/NPL1 * Preset the ZPL array to the mean z value. DO 40 I=1,MXEDGE ZPL(I)=ZMEAN 40 CONTINUE *** Find a corner we can cut off. DO 20 IP1=1,NPL1 * Ensure the midpoint is internal. IF(NPL1.GT.3)THEN CALL INTERD(NPL1,XPL1,YPL1, - (XPL1(1+MOD(IP1-2+NPL1,NPL1))+XPL1(1+MOD(IP1,NPL1)))/2, - (YPL1(1+MOD(IP1-2+NPL1,NPL1))+YPL1(1+MOD(IP1,NPL1)))/2, - INSIDE,EDGE) IF(.NOT.INSIDE)GOTO 20 ENDIF *** Check all vertex crossings. DO 30 JP1=1,NPL1 * Accept immediate contact. IF( JP1 .EQ.1+MOD(IP1-2+NPL1,NPL1).OR. - JP1 .EQ.IP1.OR. - JP1 .EQ.1+MOD(IP1,NPL1).OR. - 1+MOD(JP1,NPL1).EQ.1+MOD(IP1-2+NPL1,NPL1).OR. - 1+MOD(JP1,NPL1).EQ.IP1.OR. - 1+MOD(JP1,NPL1).EQ.1+MOD(IP1,NPL1))GOTO 30 * Check crossing. IF(CROSSD(XPL1(1+MOD(IP1-2+NPL1,NPL1)), - YPL1(1+MOD(IP1-2+NPL1,NPL1)), - XPL1(1+MOD(IP1,NPL1)), - YPL1(1+MOD(IP1,NPL1)), - XPL1(JP1), - YPL1(JP1), - XPL1(1+MOD(JP1,NPL1)), - YPL1(1+MOD(JP1,NPL1))))GOTO 20 30 CONTINUE *** Found a triangle, introduce shorthand node references. I1=1+MOD(IP1-2+NPL1,NPL1) I2=IP1 I3=1+MOD(IP1,NPL1) * Find the biggest opening angle. A1= ((XPL1(I2)-XPL1(I1))*(XPL1(I3)-XPL1(I1))+ - (YPL1(I2)-YPL1(I1))*(YPL1(I3)-YPL1(I1)))/ - SQRT(((XPL1(I2)-XPL1(I1))**2+(YPL1(I2)-YPL1(I1))**2)* - ((XPL1(I3)-XPL1(I1))**2+(YPL1(I3)-YPL1(I1))**2)) A2= ((XPL1(I3)-XPL1(I2))*(XPL1(I1)-XPL1(I2))+ - (YPL1(I3)-YPL1(I2))*(YPL1(I1)-YPL1(I2)))/ - SQRT(((XPL1(I3)-XPL1(I2))**2+(YPL1(I3)-YPL1(I2))**2)* - ((XPL1(I1)-XPL1(I2))**2+(YPL1(I1)-YPL1(I2))**2)) A3= ((XPL1(I1)-XPL1(I3))*(XPL1(I2)-XPL1(I3))+ - (YPL1(I1)-YPL1(I3))*(YPL1(I2)-YPL1(I3)))/ - SQRT(((XPL1(I1)-XPL1(I3))**2+(YPL1(I1)-YPL1(I3))**2)* - ((XPL1(I2)-XPL1(I3))**2+(YPL1(I2)-YPL1(I3))**2)) C print *,' Angles: ', C - 180.0*acos(a1)/pi,180*acos(a2)/pi,180*acos(a3)/pi, C - ', sum = ',180.0*(acos(a1)+acos(a2)+acos(a3))/pi * See whether one angle is more or less right-angled IF(ABS(A1).LT.EPSANG.OR.ABS(A2).LT.EPSANG.OR. - ABS(A3).LT.EPSANG)THEN IF(ABS(A1).LT.EPSANG)THEN XPL(1)=XPL1(I3) YPL(1)=YPL1(I3) XPL(2)=XPL1(I1) YPL(2)=YPL1(I1) XPL(3)=XPL1(I2) YPL(3)=YPL1(I2) ELSEIF(ABS(A2).LT.EPSANG)THEN XPL(1)=XPL1(I1) YPL(1)=YPL1(I1) XPL(2)=XPL1(I2) YPL(2)=YPL1(I2) XPL(3)=XPL1(I3) YPL(3)=YPL1(I3) ELSE XPL(1)=XPL1(I2) YPL(1)=YPL1(I2) XPL(2)=XPL1(I3) YPL(2)=YPL1(I3) XPL(3)=XPL1(I1) YPL(3)=YPL1(I1) ENDIF IF(NREFO+1.LE.MXPLAN)THEN NREFO=NREFO+1 CALL PLABU2('STORE',IREFO(NREFO),3,XPL,YPL,ZPL, - AN1,BN1,CN1,DN1,ICOL1,IFAIL1) ELSE PRINT *,' !!!!!! PLATRO WARNING : Output list'// - ' too long.' RETURN ENDIF ELSEIF(A1.LE.A2.AND.A1.LE.A3)THEN XC=XPL1(I2)+A2*(XPL1(I3)-XPL1(I2))*SQRT( - ((XPL1(I1)-XPL1(I2))**2+(YPL1(I1)-YPL1(I2))**2)/ - ((XPL1(I3)-XPL1(I2))**2+(YPL1(I3)-YPL1(I2))**2)) YC=YPL1(I2)+A2*(YPL1(I3)-YPL1(I2))*SQRT( - ((XPL1(I1)-XPL1(I2))**2+(YPL1(I1)-YPL1(I2))**2)/ - ((XPL1(I3)-XPL1(I2))**2+(YPL1(I3)-YPL1(I2))**2)) XPL(1)=XPL1(I3) YPL(1)=YPL1(I3) XPL(2)=XC YPL(2)=YC XPL(3)=XPL1(I1) YPL(3)=YPL1(I1) IF(NREFO+1.LE.MXPLAN)THEN NREFO=NREFO+1 CALL PLABU2('STORE',IREFO(NREFO),3,XPL,YPL,ZPL, - AN1,BN1,CN1,DN1,ICOL1,IFAIL1) ELSE PRINT *,' !!!!!! PLATRO WARNING : Output list'// - ' too long.' RETURN ENDIF XPL(1)=XPL1(I2) YPL(1)=YPL1(I2) XPL(2)=XC YPL(2)=YC XPL(3)=XPL1(I1) YPL(3)=YPL1(I1) IF(NREFO+1.LE.MXPLAN)THEN NREFO=NREFO+1 CALL PLABU2('STORE',IREFO(NREFO),3,XPL,YPL,ZPL, - AN1,BN1,CN1,DN1,ICOL1,IFAIL1) ELSE PRINT *,' !!!!!! PLATRO WARNING : Output list'// - ' too long.' RETURN ENDIF ELSEIF(A2.LE.A1.AND.A2.LE.A3)THEN XC=XPL1(I3)+A3*(XPL1(I1)-XPL1(I3))*SQRT( - ((XPL1(I2)-XPL1(I3))**2+(YPL1(I2)-YPL1(I3))**2)/ - ((XPL1(I1)-XPL1(I3))**2+(YPL1(I1)-YPL1(I3))**2)) YC=YPL1(I3)+A3*(YPL1(I1)-YPL1(I3))*SQRT( - ((XPL1(I2)-XPL1(I3))**2+(YPL1(I2)-YPL1(I3))**2)/ - ((XPL1(I1)-XPL1(I3))**2+(YPL1(I1)-YPL1(I3))**2)) XPL(1)=XPL1(I1) YPL(1)=YPL1(I1) XPL(2)=XC YPL(2)=YC XPL(3)=XPL1(I2) YPL(3)=YPL1(I2) IF(NREFO+1.LE.MXPLAN)THEN NREFO=NREFO+1 CALL PLABU2('STORE',IREFO(NREFO),3,XPL,YPL,ZPL, - AN1,BN1,CN1,DN1,ICOL1,IFAIL1) ELSE PRINT *,' !!!!!! PLATRO WARNING : Output list'// - ' too long.' RETURN ENDIF XPL(1)=XPL1(I3) YPL(1)=YPL1(I3) XPL(2)=XC YPL(2)=YC XPL(3)=XPL1(I2) YPL(3)=YPL1(I2) IF(NREFO+1.LE.MXPLAN)THEN NREFO=NREFO+1 CALL PLABU2('STORE',IREFO(NREFO),3,XPL,YPL,ZPL, - AN1,BN1,CN1,DN1,ICOL1,IFAIL1) ELSE PRINT *,' !!!!!! PLATRO WARNING : Output list'// - ' too long.' RETURN ENDIF ELSE XC=XPL1(I1)+A1*(XPL1(I2)-XPL1(I1))*SQRT( - ((XPL1(I3)-XPL1(I1))**2+(YPL1(I3)-YPL1(I1))**2)/ - ((XPL1(I2)-XPL1(I1))**2+(YPL1(I2)-YPL1(I1))**2)) YC=YPL1(I1)+A1*(YPL1(I2)-YPL1(I1))*SQRT( - ((XPL1(I3)-XPL1(I1))**2+(YPL1(I3)-YPL1(I1))**2)/ - ((XPL1(I2)-XPL1(I1))**2+(YPL1(I2)-YPL1(I1))**2)) XPL(1)=XPL1(I1) YPL(1)=YPL1(I1) XPL(2)=XC YPL(2)=YC XPL(3)=XPL1(I3) YPL(3)=YPL1(I3) IF(NREFO+1.LE.MXPLAN)THEN NREFO=NREFO+1 CALL PLABU2('STORE',IREFO(NREFO),3,XPL,YPL,ZPL, - AN1,BN1,CN1,DN1,ICOL1,IFAIL1) ELSE PRINT *,' !!!!!! PLATRO WARNING : Output list'// - ' too long.' RETURN ENDIF XPL(1)=XPL1(I2) YPL(1)=YPL1(I2) XPL(2)=XC YPL(2)=YC XPL(3)=XPL1(I3) YPL(3)=YPL1(I3) IF(NREFO+1.LE.MXPLAN)THEN NREFO=NREFO+1 CALL PLABU2('STORE',IREFO(NREFO),3,XPL,YPL,ZPL, - AN1,BN1,CN1,DN1,ICOL1,IFAIL1) ELSE PRINT *,' !!!!!! PLATRO WARNING : Output list'// - ' too long.' RETURN ENDIF ENDIF *** Eliminate this node from the polygon. DO 50 JP1=1,NPL1 IF(JP1.GT.IP1)THEN XPL1(JP1-1)=XPL1(JP1) YPL1(JP1-1)=YPL1(JP1) ELSEIF(JP1.LT.IP1)THEN XPL1(JP1)=XPL1(JP1) YPL1(JP1)=YPL1(JP1) ENDIF 50 CONTINUE NPL1=NPL1-1 GOTO 100 20 CONTINUE *** Seems to have worked. IFAIL=0 END +DECK,PLATRC. SUBROUTINE PLATRC(IREF,NREFO,IREFO,IFAIL) *----------------------------------------------------------------------- * PLATRC - Cuts a polygon into right-angled triangles. * (Last changed on 27/10/11.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CONSTANTS. +SEQ,BEMDATA. DOUBLE PRECISION XPL1(MXEDGE),YPL1(MXEDGE),ZPL1(MXEDGE),ZMEAN, - XPL(MXEDGE),YPL(MXEDGE),ZPL(MXEDGE),XC,YC, - EPSANG,EPSXYZ,AN1,BN1,CN1,DN1,A1,A2,A3, - XL1, XL2, XL3, XL4 INTEGER I,IREF,IFAIL,IFAIL1,IFAIL2,NPL1,ICOL1,IP1,JP1,I1,I2,I3, - IREFO(MXPLAN),NREFO,JREFO,NNEW LOGICAL CROSSD,INSIDE,EDGE,CORNER EXTERNAL CROSSD *** Assume failure. IFAIL=1 *** Establish tolerances. EPSANG = BEMEPA EPSXYZ = BEMEPD CALL EPSSET('SET',EPSXYZ,EPSXYZ,EPSXYZ) *** Zero the output buffer. NREFO=1 IREFO(NREFO)=IREF JREFO=1 *** Next polygon. 1000 CONTINUE C print *,' At JREFo = ',jrefo,' / NREFo = ',nrefo C read '(a)' * If done, remove spurious elements from the list. IF(JREFO.GT.NREFO)THEN NNEW=0 DO 1010 I=1,NREFO IF(IREFO(I).GT.0)THEN NNEW=NNEW+1 IREFO(NNEW)=IREFO(I) ENDIF 1010 CONTINUE NREFO=NNEW C print *,' Done, produced ',NREFO,' panels' IFAIL=0 RETURN ENDIF *** Retrieve the polygon. IF(IREFO(JREFO).LT.0)THEN C print *,' *** No polygon for JREFO = ',jrefo jrefo=jrefo+1 goto 1000 ENDIF CALL PLABU2('READ',IREFO(JREFO),NPL1,XPL1,YPL1,ZPL1, - AN1,BN1,CN1,DN1,ICOL1,IFAIL1) C print *,' Polygon of ',npl1,' nodes, IFAIL =',ifail1 *** Dump IF(LBDUMP.AND.JREFO.EQ.1)THEN OPEN(UNIT=12,FILE='platrc.dump',ACCESS='APPEND') WRITE(12,'(I5,4E15.8)') NPL1,AN1,BN1,CN1,DN1 DO 1020 I=1,NPL1 WRITE(12,'(3E15.8)') XPL1(I),YPL1(I),ZPL1(I) 1020 CONTINUE CLOSE(UNIT=12) ENDIF * Check successful reading. IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! PLATRC WARNING : Panel ',IREFO(JREFO), - ' does not exist.' JREFO=JREFO+1 GOTO 1000 * Too few nodes ELSEIF(NPL1.LE.2)THEN C print *,' *** Too few points: ',npl1 CALL PLABU2('DELETE',IREFO(JREFO),NPL1,XPL1,YPL1,ZPL1, - AN1,BN1,CN1,DN1,ICOL1,IFAIL2) IREFO(JREFO)=-1 JREFO=JREFO+1 GOTO 1000 ENDIF * Track the mean z and preset ZPL to the mean z value ZMEAN=0 DO 10 IP1=1,NPL1 ZMEAN=ZMEAN+ZPL1(IP1) 10 CONTINUE ZMEAN=ZMEAN/NPL1 DO 40 I=1,MXEDGE ZPL(I)=ZMEAN 40 CONTINUE *** Resume for another pass with the same polygon. 100 CONTINUE * Fewer than 3 points: done IF(NPL1.LE.2)THEN C print *,' Only NPL = ',npl1,' points left - done' CALL PLABU2('DELETE',IREFO(JREFO),NPL1,XPL1,YPL1,ZPL1, - AN1,BN1,CN1,DN1,ICOL1,IFAIL2) IREFO(JREFO)=-1 JREFO=JREFO+1 GOTO 1000 * See whether this is a right-angled triangle. ELSEIF(NPL1.EQ.3.AND. - ABS((XPL1(1)-XPL1(2))*(XPL1(3)-XPL1(2))+ - (YPL1(1)-YPL1(2))*(YPL1(3)-YPL1(2))).LT.EPSANG* - SQRT(((XPL1(1)-XPL1(2))**2+(YPL1(1)-YPL1(2))**2)* - ((XPL1(3)-XPL1(2))**2+(YPL1(3)-YPL1(2))**2)))THEN C print *,' Right-angled triangle node 2 - done' JREFO=JREFO+1 GOTO 1000 * See whether this is a right-angled triangle. ELSEIF(NPL1.EQ.3.AND. - ABS((XPL1(1)-XPL1(3))*(XPL1(2)-XPL1(3))+ - (YPL1(1)-YPL1(3))*(YPL1(2)-YPL1(3))).LT.EPSANG* - SQRT(((XPL1(1)-XPL1(3))**2+(YPL1(1)-YPL1(3))**2)* - ((XPL1(2)-XPL1(3))**2+(YPL1(2)-YPL1(3))**2)))THEN C print *,' Right-angled triangle node 3 - rearrange' XPL(1)=XPL1(2) YPL(1)=YPL1(2) ZPL(1)=ZPL1(2) XPL(2)=XPL1(3) YPL(2)=YPL1(3) ZPL(2)=ZPL1(3) XPL(3)=XPL1(1) YPL(3)=YPL1(1) ZPL(3)=ZPL1(1) CALL PLABU2('DELETE',IREFO(JREFO),NPL1,XPL1,YPL1,ZPL1, - AN1,BN1,CN1,DN1,ICOL1,IFAIL2) IREFO(JREFO)=-1 IF(NREFO+1.LE.MXPLAN)THEN NREFO=NREFO+1 CALL PLABU2('STORE',IREFO(NREFO),3,XPL,YPL,ZPL, - AN1,BN1,CN1,DN1,ICOL1,IFAIL1) ELSE PRINT *,' !!!!!! PLATRC WARNING : Output list'// - ' too long.' RETURN ENDIF JREFO=JREFO+1 GOTO 1000 * See whether this is a right-angled triangle. ELSEIF(NPL1.EQ.3.AND. - ABS((XPL1(3)-XPL1(1))*(XPL1(2)-XPL1(1))+ - (YPL1(3)-YPL1(1))*(YPL1(2)-YPL1(1))).LT.EPSANG* - SQRT(((XPL1(3)-XPL1(1))**2+(YPL1(3)-YPL1(1))**2)* - ((XPL1(2)-XPL1(1))**2+(YPL1(2)-YPL1(1))**2)))THEN C print *,' Right-angled triangle node 1 - rearrange' XPL(1)=XPL1(3) YPL(1)=YPL1(3) ZPL(1)=ZPL1(3) XPL(2)=XPL1(1) YPL(2)=YPL1(1) ZPL(2)=ZPL1(1) XPL(3)=XPL1(2) YPL(3)=YPL1(2) ZPL(3)=ZPL1(2) CALL PLABU2('DELETE',IREFO(JREFO),NPL1,XPL1,YPL1,ZPL1, - AN1,BN1,CN1,DN1,ICOL1,IFAIL2) IREFO(JREFO)=-1 IF(NREFO+1.LE.MXPLAN)THEN NREFO=NREFO+1 CALL PLABU2('STORE',IREFO(NREFO),3,XPL,YPL,ZPL, - AN1,BN1,CN1,DN1,ICOL1,IFAIL1) ELSE PRINT *,' !!!!!! PLATRC WARNING : Output list'// - ' too long.' RETURN ENDIF JREFO=JREFO+1 GOTO 1000 * See whether this is a rectangle. ELSEIF(NPL1.EQ.4.AND. - ABS((XPL1(1)-XPL1(2))*(XPL1(3)-XPL1(2))+ - (YPL1(1)-YPL1(2))*(YPL1(3)-YPL1(2))).LT.EPSANG* - SQRT(((XPL1(1)-XPL1(2))**2+(YPL1(1)-YPL1(2))**2)* - ((XPL1(3)-XPL1(2))**2+(YPL1(3)-YPL1(2))**2)).AND. - ABS((XPL1(2)-XPL1(3))*(XPL1(4)-XPL1(3))+ - (YPL1(2)-YPL1(3))*(YPL1(4)-YPL1(3))).LT.EPSANG* - SQRT(((XPL1(2)-XPL1(3))**2+(YPL1(2)-YPL1(3))**2)* - ((XPL1(4)-XPL1(3))**2+(YPL1(4)-YPL1(3))**2)).AND. - ABS((XPL1(1)-XPL1(4))*(XPL1(3)-XPL1(4))+ - (YPL1(1)-YPL1(4))*(YPL1(3)-YPL1(4))).LT.EPSANG* - SQRT(((XPL1(1)-XPL1(4))**2+(YPL1(1)-YPL1(4))**2)* - ((XPL1(3)-XPL1(4))**2+(YPL1(3)-YPL1(4))**2)))THEN C print *,' Rectangle' JREFO=JREFO+1 GOTO 1000 ** See whether there are parallel sides, e.g. a trapezium (UK English). ELSEIF(NPL1.GE.4)THEN DO 200 IP1=1,NPL1 DO 210 JP1=IP1+2,NPL1 * Skip adjacent segments. IF( IP1.EQ.JP1.OR. - IP1.EQ.1+MOD(JP1,NPL1).OR. - 1+MOD(IP1,NPL1).EQ.JP1.OR. - 1+MOD(IP1,NPL1).EQ.1+MOD(JP1,NPL1))GOTO 210 * Require parallelism. IF(ABS((XPL1(IP1)-XPL1(1+MOD(IP1,NPL1)))* - (XPL1(JP1)-XPL1(1+MOD(JP1,NPL1)))+ - (YPL1(IP1)-YPL1(1+MOD(IP1,NPL1)))* - (YPL1(JP1)-YPL1(1+MOD(JP1,NPL1)))+ - SQRT(((XPL1(IP1)-XPL1(1+MOD(IP1,NPL1)))**2+ - (YPL1(IP1)-YPL1(1+MOD(IP1,NPL1)))**2)* - ((XPL1(JP1)-XPL1(1+MOD(JP1,NPL1)))**2+ - (YPL1(JP1)-YPL1(1+MOD(JP1,NPL1)))**2))).GT.EPSANG* - SQRT(((XPL1(IP1)-XPL1(1+MOD(IP1,NPL1)))**2+ - (YPL1(IP1)-YPL1(1+MOD(IP1,NPL1)))**2)* - ((XPL1(JP1)-XPL1(1+MOD(JP1,NPL1)))**2+ - (YPL1(JP1)-YPL1(1+MOD(JP1,NPL1)))**2)))GOTO 210 C print *,' Found parallel sections: ',IP1,JP1 * Avoid division by zero IF( (XPL1(JP1)-XPL1(1+MOD(JP1,NPL1)))**2+ - (YPL1(JP1)-YPL1(1+MOD(JP1,NPL1)))**2.LE.0.OR. - (XPL1(IP1)-XPL1(1+MOD(IP1,NPL1)))**2+ - (YPL1(IP1)-YPL1(1+MOD(IP1,NPL1)))**2.LE.0)THEN PRINT *,' !!!!!! PLATRC WARNING : Zero norm'// - ' segment found; skipped.' GOTO 210 ENDIF * Establish the cutting lines XL1 =((XPL1(IP1) -XPL1(JP1))* - (XPL1(1+MOD(JP1,NPL1))-XPL1(JP1))+ - (YPL1(IP1) -YPL1(JP1))* - (YPL1(1+MOD(JP1,NPL1))-YPL1(JP1)))/ - ((XPL1(JP1)-XPL1(1+MOD(JP1,NPL1)))**2+ - (YPL1(JP1)-YPL1(1+MOD(JP1,NPL1)))**2) XL2 =((XPL1(1+MOD(IP1,NPL1))-XPL1(JP1))* - (XPL1(1+MOD(JP1,NPL1))-XPL1(JP1))+ - (YPL1(1+MOD(IP1,NPL1))-YPL1(JP1))* - (YPL1(1+MOD(JP1,NPL1))-YPL1(JP1)))/ - ((XPL1(JP1)-XPL1(1+MOD(JP1,NPL1)))**2+ - (YPL1(JP1)-YPL1(1+MOD(JP1,NPL1)))**2) XL3 =((XPL1(JP1) -XPL1(IP1))* - (XPL1(1+MOD(IP1,NPL1))-XPL1(IP1))+ - (YPL1(JP1) -YPL1(IP1))* - (YPL1(1+MOD(IP1,NPL1))-YPL1(IP1)))/ - ((XPL1(IP1)-XPL1(1+MOD(IP1,NPL1)))**2+ - (YPL1(IP1)-YPL1(1+MOD(IP1,NPL1)))**2) XL4 =((XPL1(1+MOD(JP1,NPL1))-XPL1(IP1))* - (XPL1(1+MOD(IP1,NPL1))-XPL1(IP1))+ - (YPL1(1+MOD(JP1,NPL1))-YPL1(IP1))* - (YPL1(1+MOD(IP1,NPL1))-YPL1(IP1)))/ - ((XPL1(IP1)-XPL1(1+MOD(IP1,NPL1)))**2+ - (YPL1(IP1)-YPL1(1+MOD(IP1,NPL1)))**2) C print *,' xl1 = ',xl1,' xl2 = ',xl2,' xl3 = ',xl3,' xl4 = ',xl4 * Check that there is at all a rectangle. IF(((XL1+EPSANG)*(1+EPSANG-XL1).LT.0.AND. - (XL4+EPSANG)*(1+EPSANG-XL4).LT.0).OR. - ((XL2+EPSANG)*(1+EPSANG-XL2).LT.0.AND. - (XL3+EPSANG)*(1+EPSANG-XL3).LT.0))THEN C print *,' No rectangle' GOTO 210 ENDIF * Add the rectangular part. IF((XL1+EPSANG)*(1+EPSANG-XL1).GE.0)THEN XPL(1)=XPL1(IP1) YPL(1)=YPL1(IP1) XPL(2)=XPL1(JP1)+XL1*(XPL1(1+MOD(JP1,NPL1))-XPL1(JP1)) YPL(2)=YPL1(JP1)+XL1*(YPL1(1+MOD(JP1,NPL1))-YPL1(JP1)) ELSEIF((XL4+EPSANG)*(1+EPSANG-XL4).GE.0)THEN XPL(1)=XPL1(IP1)+XL4*(XPL1(1+MOD(IP1,NPL1))-XPL1(IP1)) YPL(1)=YPL1(IP1)+XL4*(YPL1(1+MOD(IP1,NPL1))-YPL1(IP1)) XPL(2)=XPL1(1+MOD(JP1,NPL1)) YPL(2)=YPL1(1+MOD(JP1,NPL1)) ENDIF IF((XL2+EPSANG)*(1+EPSANG-XL2).GE.0)THEN XPL(3)=XPL1(JP1)+XL2*(XPL1(1+MOD(JP1,NPL1))-XPL1(JP1)) YPL(3)=YPL1(JP1)+XL2*(YPL1(1+MOD(JP1,NPL1))-YPL1(JP1)) XPL(4)=XPL1(1+MOD(IP1,NPL1)) YPL(4)=YPL1(1+MOD(IP1,NPL1)) ELSEIF((XL3+EPSANG)*(1+EPSANG-XL3).GE.0)THEN XPL(3)=XPL1(JP1) YPL(3)=YPL1(JP1) XPL(4)=XPL1(IP1)+XL3*(XPL1(1+MOD(IP1,NPL1))-XPL1(IP1)) YPL(4)=YPL1(IP1)+XL3*(YPL1(1+MOD(IP1,NPL1))-YPL1(IP1)) ENDIF * Verify that the midpoints of these lines are internal CALL INTERD(NPL1,XPL1,YPL1, - (XPL(1)+XPL(2))/2,(YPL(1)+YPL(2))/2, - INSIDE,EDGE) IF(.NOT.(INSIDE.OR.EDGE))THEN C print *,' *** Midpoint 1 not internal' GOTO 210 ENDIF CALL INTERD(NPL1,XPL1,YPL1, - (XPL(3)+XPL(4))/2,(YPL(3)+YPL(4))/2, - INSIDE,EDGE) IF(.NOT.(INSIDE.OR.EDGE))THEN C print *,' *** Midpoint 2 not internal' GOTO 210 ENDIF * Ensure there are no crossings, accepting contact. DO 240 I=1,NPL1 IF((I.EQ.1+MOD(IP1-2+NPL1,NPL1).AND. - (XL1+EPSANG)*(1+EPSANG-XL1).GE.0) .OR. - I.EQ.IP1 .OR. - (I.EQ.1+MOD(IP1,NPL1).AND. - (XL2+EPSANG)*(1+EPSANG-XL2).GE.0) .OR. - (I.EQ.1+MOD(JP1-2+NPL1,NPL1).AND. - (XL3+EPSANG)*(1+EPSANG-XL3).GE.0) .OR. - I.EQ.JP1 .OR. - (I.EQ.1+MOD(JP1,NPL1).AND. - (XL4+EPSANG)*(1+EPSANG-XL4).GE.0))GOTO 240 IF(CROSSD(XPL1(I),YPL1(I), - XPL1(1+MOD(I,NPL1)),YPL1(1+MOD(I,NPL1)), - XPL(1),YPL(1),XPL(2),YPL(2)).OR. - CROSSD(XPL1(I),YPL1(I), - XPL1(1+MOD(I,NPL1)),YPL1(1+MOD(I,NPL1)), - XPL(3),YPL(3),XPL(4),YPL(4)))THEN C print *,' *** Crossing' C print *,' Edge I/I+1',I,I+1 C print *,' IP1 = ',IP1,' JP1 = ',JP1 C do j=1,4 C print '(2x,i10,2f10.3)',j,xpl(j),ypl(j) C enddo GOTO 210 ENDIF 240 CONTINUE * Add the rectangular part. IF( (ABS(XL1).LT.EPSANG.AND.ABS(XL3).LT.EPSANG).OR. - (ABS(1-XL2).LT.EPSANG.AND.ABS(1-XL4).LT.EPSANG))THEN C print *,' *** Not stored, degenerate' C do i=1,4 C print '(2x,i10,2f10.3)',i,xpl(i),ypl(i) C enddo ELSEIF(NREFO+1.LE.MXPLAN)THEN NREFO=NREFO+1 CALL PLABU2('STORE',IREFO(NREFO),4,XPL,YPL,ZPL, - AN1,BN1,CN1,DN1,ICOL1,IFAIL1) C print *,' Adding rectangle' C print *,' Ref = ',IREFO(NREFO) C do i=1,4 C print '(2x,i10,2f10.3)',i,xpl(i),ypl(i) C enddo ELSE PRINT *,' !!!!!! PLATRC WARNING : Output list'// - ' too long.' RETURN ENDIF * First non-rectangular section. DO 220 I=JP1+1,IP1+NPL1 XPL(I-JP1)=XPL1(1+MOD(I-1+NPL1,NPL1)) YPL(I-JP1)=YPL1(1+MOD(I-1+NPL1,NPL1)) 220 CONTINUE IF( (XL1+EPSANG)*(1+EPSANG-XL1).GE.0.AND. - (XL4+EPSANG)*(1+EPSANG-XL4).GE.0)THEN C print *,' 1-4 degenerate' NNEW=IP1+NPL1-JP1 ELSEIF((XL1+EPSANG)*(1+EPSANG-XL1).GE.0)THEN C print *,' Using 1' NNEW=IP1+NPL1-JP1+1 XPL(NNEW)= - XPL1(JP1)+XL1*(XPL1(1+MOD(JP1,NPL1))-XPL1(JP1)) YPL(NNEW)= - YPL1(JP1)+XL1*(YPL1(1+MOD(JP1,NPL1))-YPL1(JP1)) ELSEIF((XL4+EPSANG)*(1+EPSANG-XL4).GE.0)THEN C print *,' Using 4' NNEW=IP1+NPL1-JP1+1 XPL(NNEW)= - XPL1(IP1)+XL4*(XPL1(1+MOD(IP1,NPL1))-XPL1(IP1)) YPL(NNEW)= - YPL1(IP1)+XL4*(YPL1(1+MOD(IP1,NPL1))-YPL1(IP1)) ELSE C print *,' *** Neither 1 nor 4, should not happen' ENDIF IF(NNEW.LT.3)THEN C print *,' *** Not stored, only ',nnew,' vertices' ELSEIF(NREFO+1.LE.MXPLAN)THEN NREFO=NREFO+1 CALL PLABU2('STORE',IREFO(NREFO),NNEW,XPL,YPL,ZPL, - AN1,BN1,CN1,DN1,ICOL1,IFAIL1) C print *,' Ref = ',IREFO(NREFO) C do i=1,nnew C print '(2x,i10,2f10.3)',i,xpl(i),ypl(i) C enddo ELSE PRINT *,' !!!!!! PLATRC WARNING : Output list'// - ' too long.' RETURN ENDIF * Second non-rectangular section. DO 230 I=IP1+1,JP1 XPL(I-IP1)=XPL1(1+MOD(I-1+NPL1,NPL1)) YPL(I-IP1)=YPL1(1+MOD(I-1+NPL1,NPL1)) 230 CONTINUE IF( (XL2+EPSANG)*(1+EPSANG-XL2).GE.0.AND. - (XL3+EPSANG)*(1+EPSANG-XL3).GE.0)THEN C print *,' 2-3 degenerate' NNEW=JP1-IP1 ELSEIF((XL2+EPSANG)*(1+EPSANG-XL2).GE.0)THEN C print *,' Using 2' NNEW=JP1-IP1+1 XPL(NNEW)= - XPL1(JP1)+XL2*(XPL1(1+MOD(JP1,NPL1))-XPL1(JP1)) YPL(NNEW)= - YPL1(JP1)+XL2*(YPL1(1+MOD(JP1,NPL1))-YPL1(JP1)) ELSEIF((XL3+EPSANG)*(1+EPSANG-XL3).GE.0)THEN C print *,' Using 3' NNEW=JP1-IP1+1 XPL(NNEW)= - XPL1(IP1)+XL3*(XPL1(1+MOD(IP1,NPL1))-XPL1(IP1)) YPL(NNEW)= - YPL1(IP1)+XL3*(YPL1(1+MOD(IP1,NPL1))-YPL1(IP1)) ELSE C print *,' *** Neither 2 nor 3, should not happen' ENDIF IF(NNEW.LT.3)THEN print *,' *** Not stored, only ',nnew,' vertices' ELSEIF(NREFO+1.LE.MXPLAN)THEN NREFO=NREFO+1 CALL PLABU2('STORE',IREFO(NREFO),NNEW,XPL,YPL,ZPL, - AN1,BN1,CN1,DN1,ICOL1,IFAIL1) C print *,' Ref = ',IREFO(NREFO) C do i=1,nnew C print '(2x,i10,2f10.3)',i,xpl(i),ypl(i) C enddo ELSE PRINT *,' !!!!!! PLATRC WARNING : Output list'// - ' too long.' RETURN ENDIF * Delete the original and restart a cycle CALL PLABU2('DELETE',IREFO(JREFO),NPL1,XPL1,YPL1,ZPL1, - AN1,BN1,CN1,DN1,ICOL1,IFAIL2) IREFO(JREFO)=-1 JREFO=JREFO+1 GOTO 1000 210 CONTINUE 200 CONTINUE ENDIF *** Find a right-angled corner we can cut off. C print *,' Trying to find a right-angle' CORNER=.FALSE. DO 70 IP1=1,NPL1 * Take only right angles IF(ABS((XPL1(1+MOD(IP1-2+NPL1,NPL1))-XPL1(IP1))* - (XPL1(1+MOD(IP1,NPL1))- XPL1(IP1))+ - (YPL1(1+MOD(IP1-2+NPL1,NPL1))-YPL1(IP1))* - (YPL1(1+MOD(IP1,NPL1))- YPL1(IP1))).GT.EPSANG* - SQRT(((XPL1(1+MOD(IP1-2+NPL1,NPL1))-XPL1(IP1))**2+ - (YPL1(1+MOD(IP1-2+NPL1,NPL1))-YPL1(IP1))**2)* - ((XPL1(1+MOD(IP1,NPL1))-XPL1(IP1))**2+ - (YPL1(1+MOD(IP1,NPL1))-YPL1(IP1))**2)))GOTO 70 * Ensure the midpoint is internal. IF(NPL1.GT.3)THEN CALL INTERD(NPL1,XPL1,YPL1, - (XPL1(1+MOD(IP1-2+NPL1,NPL1))+XPL1(1+MOD(IP1,NPL1)))/2, - (YPL1(1+MOD(IP1-2+NPL1,NPL1))+YPL1(1+MOD(IP1,NPL1)))/2, - INSIDE,EDGE) IF(.NOT.INSIDE)GOTO 70 ENDIF *** Check all vertex crossings. DO 80 JP1=1,NPL1 * Accept immediate contact. IF( JP1 .EQ.1+MOD(IP1-2+NPL1,NPL1).OR. - JP1 .EQ.IP1.OR. - JP1 .EQ.1+MOD(IP1,NPL1).OR. - 1+MOD(JP1,NPL1).EQ.1+MOD(IP1-2+NPL1,NPL1).OR. - 1+MOD(JP1,NPL1).EQ.IP1.OR. - 1+MOD(JP1,NPL1).EQ.1+MOD(IP1,NPL1))GOTO 80 * Check crossing. IF(CROSSD(XPL1(1+MOD(IP1-2+NPL1,NPL1)), - YPL1(1+MOD(IP1-2+NPL1,NPL1)), - XPL1(1+MOD(IP1,NPL1)), - YPL1(1+MOD(IP1,NPL1)), - XPL1(JP1), - YPL1(JP1), - XPL1(1+MOD(JP1,NPL1)), - YPL1(1+MOD(JP1,NPL1))))GOTO 70 80 CONTINUE *** Found a triangle, introduce shorthand node references. C print *,' Cutting at right-angled corner ',IP1 CORNER=.TRUE. XPL(1)=XPL1(1+MOD(IP1-2+NPL1,NPL1)) YPL(1)=YPL1(1+MOD(IP1-2+NPL1,NPL1)) XPL(2)=XPL1(IP1) YPL(2)=YPL1(IP1) XPL(3)=XPL1(1+MOD(IP1,NPL1)) YPL(3)=YPL1(1+MOD(IP1,NPL1)) IF(NREFO+1.LE.MXPLAN)THEN NREFO=NREFO+1 CALL PLABU2('STORE',IREFO(NREFO),3,XPL,YPL,ZPL, - AN1,BN1,CN1,DN1,ICOL1,IFAIL1) ELSE PRINT *,' !!!!!! PLAXXX WARNING : Output list'// - ' too long.' RETURN ENDIF *** Eliminate this node from the polygon. DO 90 JP1=1,NPL1 IF(JP1.GT.IP1)THEN XPL1(JP1-1)=XPL1(JP1) YPL1(JP1-1)=YPL1(JP1) ELSEIF(JP1.LT.IP1)THEN XPL1(JP1)=XPL1(JP1) YPL1(JP1)=YPL1(JP1) ENDIF 90 CONTINUE NPL1=NPL1-1 C print *,' Going for another pass, NPL = ',npl1 GOTO 100 70 CONTINUE *** Find any corner we can cut off. C print *,' Trying to find a corner' CORNER=.FALSE. DO 20 IP1=1,NPL1 * Ensure the midpoint is internal. IF(NPL1.GT.3)THEN CALL INTERD(NPL1,XPL1,YPL1, - (XPL1(1+MOD(IP1-2+NPL1,NPL1))+XPL1(1+MOD(IP1,NPL1)))/2, - (YPL1(1+MOD(IP1-2+NPL1,NPL1))+YPL1(1+MOD(IP1,NPL1)))/2, - INSIDE,EDGE) IF(.NOT.INSIDE)GOTO 20 ENDIF *** Check all vertex crossings. DO 30 JP1=1,NPL1 * Accept immediate contact. IF( JP1 .EQ.1+MOD(IP1-2+NPL1,NPL1).OR. - JP1 .EQ.IP1.OR. - JP1 .EQ.1+MOD(IP1,NPL1).OR. - 1+MOD(JP1,NPL1).EQ.1+MOD(IP1-2+NPL1,NPL1).OR. - 1+MOD(JP1,NPL1).EQ.IP1.OR. - 1+MOD(JP1,NPL1).EQ.1+MOD(IP1,NPL1))GOTO 30 * Check crossing. IF(CROSSD(XPL1(1+MOD(IP1-2+NPL1,NPL1)), - YPL1(1+MOD(IP1-2+NPL1,NPL1)), - XPL1(1+MOD(IP1,NPL1)), - YPL1(1+MOD(IP1,NPL1)), - XPL1(JP1), - YPL1(JP1), - XPL1(1+MOD(JP1,NPL1)), - YPL1(1+MOD(JP1,NPL1))))GOTO 20 30 CONTINUE *** Found a triangle, introduce shorthand node references. C print *,' Cutting at corner ',IP1 CORNER=.TRUE. I1=1+MOD(IP1-2+NPL1,NPL1) I2=IP1 I3=1+MOD(IP1,NPL1) * Find the biggest opening angle. A1= ((XPL1(I2)-XPL1(I1))*(XPL1(I3)-XPL1(I1))+ - (YPL1(I2)-YPL1(I1))*(YPL1(I3)-YPL1(I1)))/ - SQRT(((XPL1(I2)-XPL1(I1))**2+(YPL1(I2)-YPL1(I1))**2)* - ((XPL1(I3)-XPL1(I1))**2+(YPL1(I3)-YPL1(I1))**2)) A2= ((XPL1(I3)-XPL1(I2))*(XPL1(I1)-XPL1(I2))+ - (YPL1(I3)-YPL1(I2))*(YPL1(I1)-YPL1(I2)))/ - SQRT(((XPL1(I3)-XPL1(I2))**2+(YPL1(I3)-YPL1(I2))**2)* - ((XPL1(I1)-XPL1(I2))**2+(YPL1(I1)-YPL1(I2))**2)) A3= ((XPL1(I1)-XPL1(I3))*(XPL1(I2)-XPL1(I3))+ - (YPL1(I1)-YPL1(I3))*(YPL1(I2)-YPL1(I3)))/ - SQRT(((XPL1(I1)-XPL1(I3))**2+(YPL1(I1)-YPL1(I3))**2)* - ((XPL1(I2)-XPL1(I3))**2+(YPL1(I2)-YPL1(I3))**2)) C print *,' Angles: ', C - 180.0*acos(a1)/pi,180*acos(a2)/pi,180*acos(a3)/pi, C - ', sum = ',180.0*(acos(a1)+acos(a2)+acos(a3))/pi * See whether one angle is more or less right-angled IF(ABS(A1).LT.EPSANG.OR.ABS(A2).LT.EPSANG.OR. - ABS(A3).LT.EPSANG)THEN C print *,' Right-angled corner cut off' IF(ABS(A1).LT.EPSANG)THEN XPL(1)=XPL1(I3) YPL(1)=YPL1(I3) XPL(2)=XPL1(I1) YPL(2)=YPL1(I1) XPL(3)=XPL1(I2) YPL(3)=YPL1(I2) ELSEIF(ABS(A2).LT.EPSANG)THEN XPL(1)=XPL1(I1) YPL(1)=YPL1(I1) XPL(2)=XPL1(I2) YPL(2)=YPL1(I2) XPL(3)=XPL1(I3) YPL(3)=YPL1(I3) ELSE XPL(1)=XPL1(I2) YPL(1)=YPL1(I2) XPL(2)=XPL1(I3) YPL(2)=YPL1(I3) XPL(3)=XPL1(I1) YPL(3)=YPL1(I1) ENDIF IF(NREFO+1.LE.MXPLAN)THEN NREFO=NREFO+1 CALL PLABU2('STORE',IREFO(NREFO),3,XPL,YPL,ZPL, - AN1,BN1,CN1,DN1,ICOL1,IFAIL1) ELSE PRINT *,' !!!!!! PLATRC WARNING : Output list'// - ' too long.' RETURN ENDIF ELSEIF(A1.LE.A2.AND.A1.LE.A3)THEN C print *,' A1 < A2, A3 - adding 2 triangles' XC=XPL1(I2)+A2*(XPL1(I3)-XPL1(I2))*SQRT( - ((XPL1(I1)-XPL1(I2))**2+(YPL1(I1)-YPL1(I2))**2)/ - ((XPL1(I3)-XPL1(I2))**2+(YPL1(I3)-YPL1(I2))**2)) YC=YPL1(I2)+A2*(YPL1(I3)-YPL1(I2))*SQRT( - ((XPL1(I1)-XPL1(I2))**2+(YPL1(I1)-YPL1(I2))**2)/ - ((XPL1(I3)-XPL1(I2))**2+(YPL1(I3)-YPL1(I2))**2)) XPL(1)=XPL1(I3) YPL(1)=YPL1(I3) XPL(2)=XC YPL(2)=YC XPL(3)=XPL1(I1) YPL(3)=YPL1(I1) IF(NREFO+1.LE.MXPLAN)THEN NREFO=NREFO+1 CALL PLABU2('STORE',IREFO(NREFO),3,XPL,YPL,ZPL, - AN1,BN1,CN1,DN1,ICOL1,IFAIL1) ELSE PRINT *,' !!!!!! PLATRC WARNING : Output list'// - ' too long.' RETURN ENDIF XPL(1)=XPL1(I2) YPL(1)=YPL1(I2) XPL(2)=XC YPL(2)=YC XPL(3)=XPL1(I1) YPL(3)=YPL1(I1) IF(NREFO+1.LE.MXPLAN)THEN NREFO=NREFO+1 CALL PLABU2('STORE',IREFO(NREFO),3,XPL,YPL,ZPL, - AN1,BN1,CN1,DN1,ICOL1,IFAIL1) ELSE PRINT *,' !!!!!! PLATRC WARNING : Output list'// - ' too long.' RETURN ENDIF ELSEIF(A2.LE.A1.AND.A2.LE.A3)THEN C print *,' A2 < A1, A3 - adding 2 triangles' XC=XPL1(I3)+A3*(XPL1(I1)-XPL1(I3))*SQRT( - ((XPL1(I2)-XPL1(I3))**2+(YPL1(I2)-YPL1(I3))**2)/ - ((XPL1(I1)-XPL1(I3))**2+(YPL1(I1)-YPL1(I3))**2)) YC=YPL1(I3)+A3*(YPL1(I1)-YPL1(I3))*SQRT( - ((XPL1(I2)-XPL1(I3))**2+(YPL1(I2)-YPL1(I3))**2)/ - ((XPL1(I1)-XPL1(I3))**2+(YPL1(I1)-YPL1(I3))**2)) XPL(1)=XPL1(I1) YPL(1)=YPL1(I1) XPL(2)=XC YPL(2)=YC XPL(3)=XPL1(I2) YPL(3)=YPL1(I2) IF(NREFO+1.LE.MXPLAN)THEN NREFO=NREFO+1 CALL PLABU2('STORE',IREFO(NREFO),3,XPL,YPL,ZPL, - AN1,BN1,CN1,DN1,ICOL1,IFAIL1) ELSE PRINT *,' !!!!!! PLATRC WARNING : Output list'// - ' too long.' RETURN ENDIF XPL(1)=XPL1(I3) YPL(1)=YPL1(I3) XPL(2)=XC YPL(2)=YC XPL(3)=XPL1(I2) YPL(3)=YPL1(I2) IF(NREFO+1.LE.MXPLAN)THEN NREFO=NREFO+1 CALL PLABU2('STORE',IREFO(NREFO),3,XPL,YPL,ZPL, - AN1,BN1,CN1,DN1,ICOL1,IFAIL1) ELSE PRINT *,' !!!!!! PLATRC WARNING : Output list'// - ' too long.' RETURN ENDIF ELSE C print *,' A3 < A1, A2 - adding 2 triangles' XC=XPL1(I1)+A1*(XPL1(I2)-XPL1(I1))*SQRT( - ((XPL1(I3)-XPL1(I1))**2+(YPL1(I3)-YPL1(I1))**2)/ - ((XPL1(I2)-XPL1(I1))**2+(YPL1(I2)-YPL1(I1))**2)) YC=YPL1(I1)+A1*(YPL1(I2)-YPL1(I1))*SQRT( - ((XPL1(I3)-XPL1(I1))**2+(YPL1(I3)-YPL1(I1))**2)/ - ((XPL1(I2)-XPL1(I1))**2+(YPL1(I2)-YPL1(I1))**2)) XPL(1)=XPL1(I1) YPL(1)=YPL1(I1) XPL(2)=XC YPL(2)=YC XPL(3)=XPL1(I3) YPL(3)=YPL1(I3) IF(NREFO+1.LE.MXPLAN)THEN NREFO=NREFO+1 CALL PLABU2('STORE',IREFO(NREFO),3,XPL,YPL,ZPL, - AN1,BN1,CN1,DN1,ICOL1,IFAIL1) ELSE PRINT *,' !!!!!! PLATRC WARNING : Output list'// - ' too long.' RETURN ENDIF XPL(1)=XPL1(I2) YPL(1)=YPL1(I2) XPL(2)=XC YPL(2)=YC XPL(3)=XPL1(I3) YPL(3)=YPL1(I3) IF(NREFO+1.LE.MXPLAN)THEN NREFO=NREFO+1 CALL PLABU2('STORE',IREFO(NREFO),3,XPL,YPL,ZPL, - AN1,BN1,CN1,DN1,ICOL1,IFAIL1) ELSE PRINT *,' !!!!!! PLATRC WARNING : Output list'// - ' too long.' RETURN ENDIF ENDIF *** Eliminate this node from the polygon. DO 50 JP1=1,NPL1 IF(JP1.GT.IP1)THEN XPL1(JP1-1)=XPL1(JP1) YPL1(JP1-1)=YPL1(JP1) ELSEIF(JP1.LT.IP1)THEN XPL1(JP1)=XPL1(JP1) YPL1(JP1)=YPL1(JP1) ENDIF 50 CONTINUE NPL1=NPL1-1 C print *,' Going for another pass, NPL = ',npl1 GOTO 100 20 CONTINUE IF(.NOT.CORNER)PRINT *,' !!!!!! PLATRC WARNING : Unable to'// - ' identify a corner to cut, probably a degenerate polygon.' *** Next stack element. CALL PLABU2('DELETE',IREFO(JREFO),NPL1,XPL1,YPL1,ZPL1, - AN1,BN1,CN1,DN1,ICOL1,IFAIL2) IREFO(JREFO)=-1 JREFO=JREFO+1 GOTO 1000 END +DECK,PLATRQ. SUBROUTINE PLATRQ(IREF,NREFO,IREFO,IFAIL) *----------------------------------------------------------------------- * PLATRQ - Cuts a triangle into better quality pieces * (Last changed on 22/ 3/09.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,BEMDATA. +SEQ,CONSTANTS. DOUBLE PRECISION XPL1(MXEDGE),YPL1(MXEDGE),ZPL1(MXEDGE),ZMEAN, - XPL(MXEDGE),YPL(MXEDGE),ZPL(MXEDGE), - AN1,BN1,CN1,DN1,D12,D32,XL,XAUX,YAUX INTEGER I,IREF,IFAIL,IFAIL1,NPL1,ICOL1,IP1,IREFO(MXPLAN),NREFO *** Assume failure. IFAIL=1 *** Zero the output buffer. NREFO=0 *** Retrieve the polygon. CALL PLABU2('READ',IREF,NPL1,XPL1,YPL1,ZPL1, - AN1,BN1,CN1,DN1,ICOL1,IFAIL1) * Check this is a triangle. IF(NPL1.NE.3)THEN C print *,' Not a triangle, n=',npl1 NREFO=1 IREFO(1)=IREF RETURN ENDIF *** Work out aspect ratio D12=SQRT((XPL1(1)-XPL1(2))**2+(YPL1(1)-YPL1(2))**2) D32=SQRT((XPL1(3)-XPL1(2))**2+(YPL1(3)-YPL1(2))**2) * Anything to be done ? IF(D12.LT.BEMQTH*D32.AND.D32.LT.BEMQTH*D12)THEN C print *,' Initial aspect ratio below threshold' NREFO=1 IREFO(1)=IREF RETURN ELSEIF(D12*D32/2.LT.BEMSTH)THEN C print *,' Initial size below threshold' NREFO=1 IREFO(1)=IREF RETURN ENDIF * Rearrange to make corner 1 the sharp one. IF(D12.LT.D32)THEN XAUX=XPL1(3) YAUX=YPL1(3) XPL1(3)=XPL1(1) YPL1(3)=YPL1(1) XPL1(1)=XAUX YPL1(1)=YAUX XAUX=D12 D12=D32 D32=XAUX ENDIF * We'll need the average z ZMEAN=0 DO 10 IP1=1,NPL1 ZMEAN=ZMEAN+ZPL1(IP1) 10 CONTINUE ZMEAN=ZMEAN/NPL1 * Delete the original. CALL PLABU2('DELETE',IREF,NPL1,XPL1,YPL1,ZPL1, - AN1,BN1,CN1,DN1,ICOL1,IFAIL1) * Preset the ZPL array to the mean z value. DO 20 I=1,MXEDGE ZPL(I)=ZMEAN 20 CONTINUE *** Resume for another pass. 100 CONTINUE C print *,' *** New pass' * Chop off corner 2 XL=MIN(0.5,BEMQTH*D32/D12) XPL(1)=XPL1(2)+(XPL1(1)-XPL1(2))*XL YPL(1)=YPL1(2)+(YPL1(1)-YPL1(2))*XL XPL(2)=XPL1(2) YPL(2)=YPL1(2) XPL(3)=XPL1(3) YPL(3)=YPL1(3) IF(NREFO+1.LE.MXPLAN)THEN NREFO=NREFO+1 CALL PLABU2('STORE',IREFO(NREFO),3,XPL,YPL,ZPL, - AN1,BN1,CN1,DN1,ICOL1,IFAIL1) ELSE PRINT *,' !!!!!! PLATRQ WARNING : Output overflow.' RETURN ENDIF * Drop the perpendicular on the hypothenusa. XL=((XPL1(3)-XPL(1))*(XPL1(3)-XPL1(1))+ - (YPL1(3)-YPL(1))*(YPL1(3)-YPL1(1)))/ - ((XPL1(3)-XPL1(1))**2+(YPL1(3)-YPL1(1))**2) XPL(2)=XPL1(3)+XL*(XPL1(1)-XPL1(3)) YPL(2)=YPL1(3)+XL*(YPL1(1)-YPL1(3)) IF(NREFO+1.LE.MXPLAN)THEN NREFO=NREFO+1 CALL PLABU2('STORE',IREFO(NREFO),3,XPL,YPL,ZPL, - AN1,BN1,CN1,DN1,ICOL1,IFAIL1) ELSE PRINT *,' !!!!!! PLATRQ WARNING : Output overflow.' RETURN ENDIF * Store the new corners. XPL1(2)=XPL(2) YPL1(2)=YPL(2) XPL1(3)=XPL(1) YPL1(3)=YPL(1) * Work out the new aspect ratios D12=SQRT((XPL1(1)-XPL1(2))**2+(YPL1(1)-YPL1(2))**2) D32=SQRT((XPL1(3)-XPL1(2))**2+(YPL1(3)-YPL1(2))**2) * Anything to be done ? IF(D12.LT.BEMQTH*D32.AND.D32.LT.BEMQTH*D12)THEN C print *,' Current aspect ratio below threshold' IF(NREFO+1.LE.MXPLAN)THEN NREFO=NREFO+1 CALL PLABU2('STORE',IREFO(NREFO),3,XPL1,YPL1,ZPL1, - AN1,BN1,CN1,DN1,ICOL1,IFAIL1) ELSE PRINT *,' !!!!!! PLATRQ WARNING : Output overflow.' RETURN ENDIF print *,' Triangle cut in ',nrefo,' pieces (A/R).' RETURN ELSEIF(D12*D32/2.LT.BEMSTH)THEN C print *,' Current size below threshold' IF(NREFO+1.LE.MXPLAN)THEN NREFO=NREFO+1 CALL PLABU2('STORE',IREFO(NREFO),3,XPL1,YPL1,ZPL1, - AN1,BN1,CN1,DN1,ICOL1,IFAIL1) ELSE PRINT *,' !!!!!! PLATRQ WARNING : Output overflow.' RETURN ENDIF print *,' Triangle cut in ',nrefo,' pieces (QTH).' RETURN ENDIF GOTO 100 *** Seems to have worked. IFAIL=0 END +PATCH,ROUTINES. +DECK,ARGGET,IF=UNIX,CYGWIN. subroutine argget(iarg,string,nc) *----------------------------------------------------------------------- * ARGGET - Returns an argument with its length, for Unix systems only. * (Last changed on 4/ 6/92.) *----------------------------------------------------------------------- character*(*) string call getarg(iarg,string) do i=len(string),1,-1 if(string(i:i).ne.' ')then nc=i return endif enddo nc=0 end +DECK,BOXIN2. SUBROUTINE BOXIN2(VALUE,XAXIS,YAXIS,MAXX,MAXY,NX,NY,X,Y,F,IORDER, - IFAIL) *----------------------------------------------------------------------- * BOXIN2 - Interpolation of order 1 and 2 in an irregular rectangular * 2-dimensional grid. * (Last changed on 24/ 1/00.) *----------------------------------------------------------------------- implicit none INTEGER MAXX,MAXY,NX,NY,IORDER,IFAIL,I,INODE,IGRID,IX,IX0,IX1, - IY,IY0,IY1 REAL VALUE(MAXX,MAXY),XAXIS(MAXX),YAXIS(MAXY),X,Y,F,DIST, - XLOCAL,YLOCAL,XALPHA,YALPHA,FX(3),FY(3) *** Ensure we are in the grid. IF((XAXIS(NX)-X)*(X-XAXIS(1)).LT.0.OR. - (YAXIS(NY)-Y)*(Y-YAXIS(1)).LT.0)THEN C PRINT *,' !!!!!! BOXIN2 WARNING : Point not in the grid;'// C ' no interpolation.' F=0 IFAIL=1 RETURN * Make sure we have enough points. ELSEIF(IORDER.LT.0.OR.IORDER.GT.2.OR. - NX.LT.1.OR.NX.GT.MAXX.OR.NY.LT.1.OR.NY.GT.MAXY)THEN PRINT *,' !!!!!! BOXIN2 WARNING : Incorrect order or'// - ' number of points; no interpolation.' F=0 IFAIL=1 RETURN ENDIF *** Zeroth order interpolation in x. IF(IORDER.EQ.0.OR.NX.LE.1)THEN * Find the nearest node. DIST=ABS(X-XAXIS(1)) INODE=1 DO 10 I=2,NX IF(ABS(X-XAXIS(I)).LT.DIST)THEN DIST=ABS(X-XAXIS(I)) INODE=I ENDIF 10 CONTINUE * Set the summing range. IX0=INODE IX1=INODE * Establish the shape functions. FX(1)=1 FX(2)=0 FX(3)=0 *** First order interpolation in x. ELSEIF(IORDER.EQ.1.OR.NX.LE.2)THEN * Find the grid segment containing this point. IGRID=0 DO 20 I=2,NX IF((XAXIS(I-1)-X)*(X-XAXIS(I)).GE.0)IGRID=I 20 CONTINUE * Ensure there won't be divisions by zero. IF(XAXIS(IGRID).EQ.XAXIS(IGRID-1))THEN PRINT *,' !!!!!! BOXIN2 WARNING : Incorrect grid;'// - ' no interpolation.' F=0 IFAIL=1 RETURN ENDIF * Compute local coordinates. XLOCAL=(X-XAXIS(IGRID-1))/(XAXIS(IGRID)-XAXIS(IGRID-1)) * Set the summing range. IX0=IGRID-1 IX1=IGRID * Set the shape functions. FX(1)=1-XLOCAL FX(2)=XLOCAL FX(3)=0 *** Second order interpolation in x. ELSEIF(IORDER.EQ.2)THEN * Find the nearest node and the grid segment. DIST=ABS(X-XAXIS(1)) INODE=1 DO 30 I=2,NX IF(ABS(X-XAXIS(I)).LT.DIST)THEN DIST=ABS(X-XAXIS(I)) INODE=I ENDIF 30 CONTINUE * Find the nearest fitting 2x2 matrix. IGRID=MAX(2,MIN(NX-1,INODE)) * Ensure there won't be divisions by zero. IF(XAXIS(IGRID+1).EQ.XAXIS(IGRID-1))THEN PRINT *,' !!!!!! BOXIN2 WARNING : Incorrect grid;'// - ' no interpolation.' F=0 IFAIL=1 RETURN ENDIF * Compute the alpha and local coordinate for this grid segment. XALPHA=(XAXIS(IGRID)-XAXIS(IGRID-1))/ - (XAXIS(IGRID+1)-XAXIS(IGRID-1)) XLOCAL=(X-XAXIS(IGRID-1))/(XAXIS(IGRID+1)-XAXIS(IGRID-1)) * Ensure there won't be divisions by zero. IF(XALPHA.LE.0.OR.XALPHA.GE.1)THEN PRINT *,' !!!!!! BOXIN2 WARNING : Incorrect grid;'// - ' no interpolation.' F=0 IFAIL=1 RETURN ENDIF * Set the summing range. IX0=IGRID-1 IX1=IGRID+1 * Set the shape functions. FX(1)=XLOCAL**2/XALPHA-XLOCAL*(1+XALPHA)/XALPHA+1 FX(2)=(XLOCAL**2-XLOCAL)/(XALPHA**2-XALPHA) FX(3)=(XLOCAL**2-XLOCAL*XALPHA)/(1-XALPHA) ENDIF *** Zeroth order interpolation in y. IF(IORDER.EQ.0.OR.NY.LE.1)THEN * Find the nearest node. DIST=ABS(Y-YAXIS(1)) INODE=1 DO 40 I=2,NY IF(ABS(Y-YAXIS(I)).LT.DIST)THEN DIST=ABS(Y-YAXIS(I)) INODE=I ENDIF 40 CONTINUE * Set the summing range. IY0=INODE IY1=INODE * Establish the shape functions. FY(1)=1 FY(2)=0 FY(3)=0 *** First order interpolation in y. ELSEIF(IORDER.EQ.1.OR.NY.LE.2)THEN * Find the grid segment containing this point. IGRID=0 DO 50 I=2,NY IF((YAXIS(I-1)-Y)*(Y-YAXIS(I)).GE.0)IGRID=I 50 CONTINUE * Ensure there won't be divisions by zero. IF(YAXIS(IGRID).EQ.YAXIS(IGRID-1))THEN PRINT *,' !!!!!! BOXIN2 WARNING : Incorrect grid;'// - ' no interpolation.' F=0 IFAIL=1 RETURN ENDIF * Compute local coordinates. YLOCAL=(Y-YAXIS(IGRID-1))/(YAXIS(IGRID)-YAXIS(IGRID-1)) * Set the summing range. IY0=IGRID-1 IY1=IGRID * Set the shape functions. FY(1)=1-YLOCAL FY(2)=YLOCAL FY(3)=0 *** Second order interpolation in y. ELSEIF(IORDER.EQ.2)THEN * Find the nearest node and the grid segment. DIST=ABS(Y-YAXIS(1)) INODE=1 DO 60 I=2,NY IF(ABS(Y-YAXIS(I)).LT.DIST)THEN DIST=ABS(Y-YAXIS(I)) INODE=I ENDIF 60 CONTINUE * Find the nearest fitting 2x2 matrix. IGRID=MAX(2,MIN(NY-1,INODE)) * Ensure there won't be divisions by zero. IF(YAXIS(IGRID+1).EQ.YAXIS(IGRID-1))THEN PRINT *,' !!!!!! BOXIN2 WARNING : Incorrect grid;'// - ' no interpolation.' F=0 IFAIL=1 RETURN ENDIF * Compute the alpha and local coordinate for this grid segment. YALPHA=(YAXIS(IGRID)-YAXIS(IGRID-1))/ - (YAXIS(IGRID+1)-YAXIS(IGRID-1)) YLOCAL=(Y-YAXIS(IGRID-1))/(YAXIS(IGRID+1)-YAXIS(IGRID-1)) * Ensure there won't be divisions by zero. IF(YALPHA.LE.0.OR.YALPHA.GE.1)THEN PRINT *,' !!!!!! BOXIN2 WARNING : Incorrect grid;'// - ' no interpolation.' F=0 IFAIL=1 RETURN ENDIF * Set the summing range. IY0=IGRID-1 IY1=IGRID+1 * Set the shape functions. FY(1)=YLOCAL**2/YALPHA-YLOCAL*(1+YALPHA)/YALPHA+1 FY(2)=(YLOCAL**2-YLOCAL)/(YALPHA**2-YALPHA) FY(3)=(YLOCAL**2-YLOCAL*YALPHA)/(1-YALPHA) ENDIF *** Sum the shape functions. F=0 DO 100 IX=IX0,IX1 DO 110 IY=IY0,IY1 F=F+VALUE(IX,IY)*FX(IX-IX0+1)*FY(IY-IY0+1) 110 CONTINUE 100 CONTINUE *** Seems to have worked. IFAIL=0 END +DECK,BOXIN3. SUBROUTINE BOXIN3(VALUE,XAXIS,YAXIS,ZAXIS,MAXX,MAXY,MAXZ, - NX,NY,NZ,XX,YY,ZZ,F,IORDER,IFAIL) *----------------------------------------------------------------------- * BOXIN3 - Interpolation of order 1 and 2 in an irregular rectangular * 3-dimensional grid. * (Last changed on 13/ 2/00.) *----------------------------------------------------------------------- implicit none INTEGER MAXX,MAXY,MAXZ,NX,NY,NZ,IORDER,IFAIL,I,INODE,IGRID, - IX,IX0,IX1,IY,IY0,IY1,IZ,IZ0,IZ1 REAL VALUE(MAXX,MAXY,MAXZ),XAXIS(MAXX),YAXIS(MAXY),ZAXIS(MAXZ), - X,Y,Z,F,DIST,XLOCAL,YLOCAL,ZLOCAL, - FX(4),FY(4),FZ(4),XX,YY,ZZ *** Ensure we are in the grid. X=MIN(MAX(XX,MIN(XAXIS(1),XAXIS(NX))),MAX(XAXIS(1),XAXIS(NX))) Y=MIN(MAX(YY,MIN(YAXIS(1),YAXIS(NY))),MAX(YAXIS(1),YAXIS(NY))) Z=MIN(MAX(ZZ,MIN(ZAXIS(1),ZAXIS(NZ))),MAX(ZAXIS(1),ZAXIS(NZ))) * Make sure we have enough points. IF(IORDER.LT.0.OR.IORDER.GT.2.OR. - NX.LT.1.OR.NX.GT.MAXX.OR. - NY.LT.1.OR.NY.GT.MAXY.OR. - NZ.LT.1.OR.NZ.GT.MAXZ)THEN PRINT *,' !!!!!! BOXIN3 WARNING : Incorrect order or'// - ' number of points; no interpolation.' F=0 IFAIL=1 RETURN ENDIF *** Zeroth order interpolation in x. IF(IORDER.EQ.0.OR.NX.LE.1)THEN * Find the nearest node. DIST=ABS(X-XAXIS(1)) INODE=1 DO 10 I=2,NX IF(ABS(X-XAXIS(I)).LT.DIST)THEN DIST=ABS(X-XAXIS(I)) INODE=I ENDIF 10 CONTINUE * Set the summing range. IX0=INODE IX1=INODE * Establish the shape functions. FX(1)=1 FX(2)=0 FX(3)=0 *** First order interpolation in x. ELSEIF(IORDER.EQ.1.OR.NX.LE.2)THEN * Find the grid segment containing this point. IGRID=0 DO 20 I=2,NX IF((XAXIS(I-1)-X)*(X-XAXIS(I)).GE.0)IGRID=I 20 CONTINUE * Ensure there won't be divisions by zero. IF(XAXIS(IGRID).EQ.XAXIS(IGRID-1))THEN PRINT *,' !!!!!! BOXIN3 WARNING : Incorrect grid;'// - ' no interpolation.' F=0 IFAIL=1 RETURN ENDIF * Compute local coordinates. XLOCAL=(X-XAXIS(IGRID-1))/(XAXIS(IGRID)-XAXIS(IGRID-1)) * Set the summing range. IX0=IGRID-1 IX1=IGRID * Set the shape functions. FX(1)=1-XLOCAL FX(2)=XLOCAL FX(3)=0 *** Second order interpolation in x. ELSEIF(IORDER.EQ.2)THEN * Find the grid segment containing this point. IGRID=0 DO 30 I=2,NX IF((XAXIS(I-1)-X)*(X-XAXIS(I)).GE.0)IGRID=I 30 CONTINUE * Compute the local coordinate for this grid segment. XLOCAL=(X-XAXIS(IGRID-1))/(XAXIS(IGRID)-XAXIS(IGRID-1)) * Set the summing range and shape functions. IF(IGRID.EQ.2)THEN IX0=IGRID-1 IX1=IGRID+1 IF( XAXIS(IX0 ).EQ.XAXIS(IX0+1).OR. - XAXIS(IX0 ).EQ.XAXIS(IX0+2).OR. - XAXIS(IX0+1).EQ.XAXIS(IX0+2))GOTO 3010 FX(1)=(X -XAXIS(IX0+1))* - (X -XAXIS(IX0+2))/ - ((XAXIS(IX0 )-XAXIS(IX0+1))* - (XAXIS(IX0 )-XAXIS(IX0+2))) FX(2)=(X -XAXIS(IX0 ))* - (X -XAXIS(IX0+2))/ - ((XAXIS(IX0+1)-XAXIS(IX0 ))* - (XAXIS(IX0+1)-XAXIS(IX0+2))) FX(3)=(X -XAXIS(IX0 ))* - (X -XAXIS(IX0+1))/ - ((XAXIS(IX0+2)-XAXIS(IX0 ))* - (XAXIS(IX0+2)-XAXIS(IX0+1))) ELSEIF(IGRID.EQ.NX)THEN IX0=IGRID-2 IX1=IGRID IF( XAXIS(IX0 ).EQ.XAXIS(IX0+1).OR. - XAXIS(IX0 ).EQ.XAXIS(IX0+2).OR. - XAXIS(IX0+1).EQ.XAXIS(IX0+2))GOTO 3010 FX(1)=(X -XAXIS(IX0+1))* - (X -XAXIS(IX0+2))/ - ((XAXIS(IX0 )-XAXIS(IX0+1))* - (XAXIS(IX0 )-XAXIS(IX0+2))) FX(2)=(X -XAXIS(IX0 ))* - (X -XAXIS(IX0+2))/ - ((XAXIS(IX0+1)-XAXIS(IX0 ))* - (XAXIS(IX0+1)-XAXIS(IX0+2))) FX(3)=(X -XAXIS(IX0 ))* - (X -XAXIS(IX0+1))/ - ((XAXIS(IX0+2)-XAXIS(IX0 ))* - (XAXIS(IX0+2)-XAXIS(IX0+1))) ELSE IX0=IGRID-2 IX1=IGRID+1 IF( XAXIS(IX0 ).EQ.XAXIS(IX0+1).OR. - XAXIS(IX0 ).EQ.XAXIS(IX0+2).OR. - XAXIS(IX0 ).EQ.XAXIS(IX0+3).OR. - XAXIS(IX0+1).EQ.XAXIS(IX0+2).OR. - XAXIS(IX0+1).EQ.XAXIS(IX0+3).OR. - XAXIS(IX0+2).EQ.XAXIS(IX0+3))GOTO 3010 FX(1)=(1-XLOCAL)* - (X -XAXIS(IX0+1))* - (X -XAXIS(IX0+2))/ - ((XAXIS(IX0 )-XAXIS(IX0+1))* - (XAXIS(IX0 )-XAXIS(IX0+2))) FX(2)=(1-XLOCAL)* - (X -XAXIS(IX0 ))* - (X -XAXIS(IX0+2))/ - ((XAXIS(IX0+1)-XAXIS(IX0 ))* - (XAXIS(IX0+1)-XAXIS(IX0+2)))+ - XLOCAL* - (X -XAXIS(IX0+2))* - (X -XAXIS(IX0+3))/ - ((XAXIS(IX0+1)-XAXIS(IX0+2))* - (XAXIS(IX0+1)-XAXIS(IX0+3))) FX(3)=(1-XLOCAL)* - (X -XAXIS(IX0 ))* - (X -XAXIS(IX0+1))/ - ((XAXIS(IX0+2)-XAXIS(IX0 ))* - (XAXIS(IX0+2)-XAXIS(IX0+1)))+ - XLOCAL* - (X -XAXIS(IX0+1))* - (X -XAXIS(IX0+3))/ - ((XAXIS(IX0+2)-XAXIS(IX0+1))* - (XAXIS(IX0+2)-XAXIS(IX0+3))) FX(4)=XLOCAL* - (X -XAXIS(IX0+1))* - (X -XAXIS(IX0+2))/ - ((XAXIS(IX0+3)-XAXIS(IX0+1))* - (XAXIS(IX0+3)-XAXIS(IX0+2))) ENDIF ENDIF *** Zeroth order interpolation in y. IF(IORDER.EQ.0.OR.NY.LE.1)THEN * Find the nearest node. DIST=ABS(Y-YAXIS(1)) INODE=1 DO 40 I=2,NY IF(ABS(Y-YAXIS(I)).LT.DIST)THEN DIST=ABS(Y-YAXIS(I)) INODE=I ENDIF 40 CONTINUE * Set the summing range. IY0=INODE IY1=INODE * Establish the shape functions. FY(1)=1 FY(2)=0 FY(3)=0 *** First order interpolation in y. ELSEIF(IORDER.EQ.1.OR.NY.LE.2)THEN * Find the grid segment containing this point. IGRID=0 DO 50 I=2,NY IF((YAXIS(I-1)-Y)*(Y-YAXIS(I)).GE.0)IGRID=I 50 CONTINUE * Ensure there won't be divisions by zero. IF(YAXIS(IGRID).EQ.YAXIS(IGRID-1))THEN PRINT *,' !!!!!! BOXIN3 WARNING : Incorrect grid;'// - ' no interpolation.' F=0 IFAIL=1 RETURN ENDIF * Compute local coordinates. YLOCAL=(Y-YAXIS(IGRID-1))/(YAXIS(IGRID)-YAXIS(IGRID-1)) * Set the summing range. IY0=IGRID-1 IY1=IGRID * Set the shape functions. FY(1)=1-YLOCAL FY(2)=YLOCAL FY(3)=0 *** Second order interpolation in y. ELSEIF(IORDER.EQ.2)THEN * Find the grid segment containing this point. IGRID=0 DO 60 I=2,NY IF((YAXIS(I-1)-Y)*(Y-YAXIS(I)).GE.0)IGRID=I 60 CONTINUE * Compute the local coordinate for this grid segment. YLOCAL=(Y-YAXIS(IGRID-1))/(YAXIS(IGRID)-YAXIS(IGRID-1)) * Set the summing range and shape functions. IF(IGRID.EQ.2)THEN IY0=IGRID-1 IY1=IGRID+1 IF( YAXIS(IY0 ).EQ.YAXIS(IY0+1).OR. - YAXIS(IY0 ).EQ.YAXIS(IY0+2).OR. - YAXIS(IY0+1).EQ.YAXIS(IY0+2))GOTO 3010 FY(1)=(Y -YAXIS(IY0+1))* - (Y -YAXIS(IY0+2))/ - ((YAXIS(IY0 )-YAXIS(IY0+1))* - (YAXIS(IY0 )-YAXIS(IY0+2))) FY(2)=(Y -YAXIS(IY0 ))* - (Y -YAXIS(IY0+2))/ - ((YAXIS(IY0+1)-YAXIS(IY0 ))* - (YAXIS(IY0+1)-YAXIS(IY0+2))) FY(3)=(Y -YAXIS(IY0 ))* - (Y -YAXIS(IY0+1))/ - ((YAXIS(IY0+2)-YAXIS(IY0 ))* - (YAXIS(IY0+2)-YAXIS(IY0+1))) ELSEIF(IGRID.EQ.NY)THEN IY0=IGRID-2 IY1=IGRID IF( YAXIS(IY0 ).EQ.YAXIS(IY0+1).OR. - YAXIS(IY0 ).EQ.YAXIS(IY0+2).OR. - YAXIS(IY0+1).EQ.YAXIS(IY0+2))GOTO 3010 FY(1)=(Y -YAXIS(IY0+1))* - (Y -YAXIS(IY0+2))/ - ((YAXIS(IY0 )-YAXIS(IY0+1))* - (YAXIS(IY0 )-YAXIS(IY0+2))) FY(2)=(Y -YAXIS(IY0 ))* - (Y -YAXIS(IY0+2))/ - ((YAXIS(IY0+1)-YAXIS(IY0 ))* - (YAXIS(IY0+1)-YAXIS(IY0+2))) FY(3)=(Y -YAXIS(IY0 ))* - (Y -YAXIS(IY0+1))/ - ((YAXIS(IY0+2)-YAXIS(IY0 ))* - (YAXIS(IY0+2)-YAXIS(IY0+1))) ELSE IY0=IGRID-2 IY1=IGRID+1 IF( YAXIS(IY0 ).EQ.YAXIS(IY0+1).OR. - YAXIS(IY0 ).EQ.YAXIS(IY0+2).OR. - YAXIS(IY0 ).EQ.YAXIS(IY0+3).OR. - YAXIS(IY0+1).EQ.YAXIS(IY0+2).OR. - YAXIS(IY0+1).EQ.YAXIS(IY0+3).OR. - YAXIS(IY0+2).EQ.YAXIS(IY0+3))GOTO 3010 FY(1)=(1-YLOCAL)* - (Y -YAXIS(IY0+1))* - (Y -YAXIS(IY0+2))/ - ((YAXIS(IY0 )-YAXIS(IY0+1))* - (YAXIS(IY0 )-YAXIS(IY0+2))) FY(2)=(1-YLOCAL)* - (Y -YAXIS(IY0 ))* - (Y -YAXIS(IY0+2))/ - ((YAXIS(IY0+1)-YAXIS(IY0 ))* - (YAXIS(IY0+1)-YAXIS(IY0+2)))+ - YLOCAL* - (Y -YAXIS(IY0+2))* - (Y -YAXIS(IY0+3))/ - ((YAXIS(IY0+1)-YAXIS(IY0+2))* - (YAXIS(IY0+1)-YAXIS(IY0+3))) FY(3)=(1-YLOCAL)* - (Y -YAXIS(IY0 ))* - (Y -YAXIS(IY0+1))/ - ((YAXIS(IY0+2)-YAXIS(IY0 ))* - (YAXIS(IY0+2)-YAXIS(IY0+1)))+ - YLOCAL* - (Y -YAXIS(IY0+1))* - (Y -YAXIS(IY0+3))/ - ((YAXIS(IY0+2)-YAXIS(IY0+1))* - (YAXIS(IY0+2)-YAXIS(IY0+3))) FY(4)=YLOCAL* - (Y -YAXIS(IY0+1))* - (Y -YAXIS(IY0+2))/ - ((YAXIS(IY0+3)-YAXIS(IY0+1))* - (YAXIS(IY0+3)-YAXIS(IY0+2))) ENDIF ENDIF *** Zeroth order interpolation in z. IF(IORDER.EQ.0.OR.NZ.LE.1)THEN * Find the nearest node. DIST=ABS(Z-ZAXIS(1)) INODE=1 DO 70 I=2,NZ IF(ABS(Z-ZAXIS(I)).LT.DIST)THEN DIST=ABS(Z-ZAXIS(I)) INODE=I ENDIF 70 CONTINUE * Set the summing range. IZ0=INODE IZ1=INODE * Establish the shape functions. FZ(1)=1 FZ(2)=0 FZ(3)=0 *** First order interpolation in z. ELSEIF(IORDER.EQ.1.OR.NZ.LE.2)THEN * Find the grid segment containing this point. IGRID=0 DO 80 I=2,NZ IF((ZAXIS(I-1)-Z)*(Z-ZAXIS(I)).GE.0)IGRID=I 80 CONTINUE * Ensure there won't be divisions by zero. IF(ZAXIS(IGRID).EQ.ZAXIS(IGRID-1))THEN PRINT *,' !!!!!! BOXIN3 WARNING : Incorrect grid;'// - ' no interpolation.' F=0 IFAIL=1 RETURN ENDIF * Compute local coordinates. ZLOCAL=(Z-ZAXIS(IGRID-1))/(ZAXIS(IGRID)-ZAXIS(IGRID-1)) * Set the summing range. IZ0=IGRID-1 IZ1=IGRID * Set the shape functions. FZ(1)=1-ZLOCAL FZ(2)=ZLOCAL FZ(3)=0 *** Second order interpolation in z. ELSEIF(IORDER.EQ.2)THEN * Find the grid segment containing this point. IGRID=0 DO 90 I=2,NZ IF((ZAXIS(I-1)-Z)*(Z-ZAXIS(I)).GE.0)IGRID=I 90 CONTINUE * Compute the local coordinate for this grid segment. ZLOCAL=(Z-ZAXIS(IGRID-1))/(ZAXIS(IGRID)-ZAXIS(IGRID-1)) * Set the summing range and shape functions. IF(IGRID.EQ.2)THEN IZ0=IGRID-1 IZ1=IGRID+1 IF( ZAXIS(IZ0 ).EQ.ZAXIS(IZ0+1).OR. - ZAXIS(IZ0 ).EQ.ZAXIS(IZ0+2).OR. - ZAXIS(IZ0+1).EQ.ZAXIS(IZ0+2))GOTO 3010 FZ(1)=(Z -ZAXIS(IZ0+1))* - (Z -ZAXIS(IZ0+2))/ - ((ZAXIS(IZ0 )-ZAXIS(IZ0+1))* - (ZAXIS(IZ0 )-ZAXIS(IZ0+2))) FZ(2)=(Z -ZAXIS(IZ0 ))* - (Z -ZAXIS(IZ0+2))/ - ((ZAXIS(IZ0+1)-ZAXIS(IZ0 ))* - (ZAXIS(IZ0+1)-ZAXIS(IZ0+2))) FZ(3)=(Z -ZAXIS(IZ0 ))* - (Z -ZAXIS(IZ0+1))/ - ((ZAXIS(IZ0+2)-ZAXIS(IZ0 ))* - (ZAXIS(IZ0+2)-ZAXIS(IZ0+1))) ELSEIF(IGRID.EQ.NZ)THEN IZ0=IGRID-2 IZ1=IGRID IF( ZAXIS(IZ0 ).EQ.ZAXIS(IZ0+1).OR. - ZAXIS(IZ0 ).EQ.ZAXIS(IZ0+2).OR. - ZAXIS(IZ0+1).EQ.ZAXIS(IZ0+2))GOTO 3010 FZ(1)=(Z -ZAXIS(IZ0+1))* - (Z -ZAXIS(IZ0+2))/ - ((ZAXIS(IZ0 )-ZAXIS(IZ0+1))* - (ZAXIS(IZ0 )-ZAXIS(IZ0+2))) FZ(2)=(Z -ZAXIS(IZ0 ))* - (Z -ZAXIS(IZ0+2))/ - ((ZAXIS(IZ0+1)-ZAXIS(IZ0 ))* - (ZAXIS(IZ0+1)-ZAXIS(IZ0+2))) FZ(3)=(Z -ZAXIS(IZ0 ))* - (Z -ZAXIS(IZ0+1))/ - ((ZAXIS(IZ0+2)-ZAXIS(IZ0 ))* - (ZAXIS(IZ0+2)-ZAXIS(IZ0+1))) ELSE IZ0=IGRID-2 IZ1=IGRID+1 IF( ZAXIS(IZ0 ).EQ.ZAXIS(IZ0+1).OR. - ZAXIS(IZ0 ).EQ.ZAXIS(IZ0+2).OR. - ZAXIS(IZ0 ).EQ.ZAXIS(IZ0+3).OR. - ZAXIS(IZ0+1).EQ.ZAXIS(IZ0+2).OR. - ZAXIS(IZ0+1).EQ.ZAXIS(IZ0+3).OR. - ZAXIS(IZ0+2).EQ.ZAXIS(IZ0+3))GOTO 3010 FZ(1)=(1-ZLOCAL)* - (Z -ZAXIS(IZ0+1))* - (Z -ZAXIS(IZ0+2))/ - ((ZAXIS(IZ0 )-ZAXIS(IZ0+1))* - (ZAXIS(IZ0 )-ZAXIS(IZ0+2))) FZ(2)=(1-ZLOCAL)* - (Z -ZAXIS(IZ0 ))* - (Z -ZAXIS(IZ0+2))/ - ((ZAXIS(IZ0+1)-ZAXIS(IZ0 ))* - (ZAXIS(IZ0+1)-ZAXIS(IZ0+2)))+ - ZLOCAL* - (Z -ZAXIS(IZ0+2))* - (Z -ZAXIS(IZ0+3))/ - ((ZAXIS(IZ0+1)-ZAXIS(IZ0+2))* - (ZAXIS(IZ0+1)-ZAXIS(IZ0+3))) FZ(3)=(1-ZLOCAL)* - (Z -ZAXIS(IZ0 ))* - (Z -ZAXIS(IZ0+1))/ - ((ZAXIS(IZ0+2)-ZAXIS(IZ0 ))* - (ZAXIS(IZ0+2)-ZAXIS(IZ0+1)))+ - ZLOCAL* - (Z -ZAXIS(IZ0+1))* - (Z -ZAXIS(IZ0+3))/ - ((ZAXIS(IZ0+2)-ZAXIS(IZ0+1))* - (ZAXIS(IZ0+2)-ZAXIS(IZ0+3))) FZ(4)=ZLOCAL* - (Z -ZAXIS(IZ0+1))* - (Z -ZAXIS(IZ0+2))/ - ((ZAXIS(IZ0+3)-ZAXIS(IZ0+1))* - (ZAXIS(IZ0+3)-ZAXIS(IZ0+2))) ENDIF ENDIF *** Sum the shape functions. F=0 DO 100 IX=IX0,IX1 DO 110 IY=IY0,IY1 DO 120 IZ=IZ0,IZ1 F=F+VALUE(IX,IY,IZ)*FX(IX-IX0+1)*FY(IY-IY0+1)*FZ(IZ-IZ0+1) 120 CONTINUE 110 CONTINUE 100 CONTINUE *** Seems to have worked. IFAIL=0 RETURN *** Error handling. 3010 CONTINUE PRINT *,' !!!!!! BOXIN3 WARNING : One or more grid points in'// - ' x coincide; no interpolation.' F=0 IFAIL=1 END +DECK,BUTFLY. SUBROUTINE BUTFLY(NPL,XPL,YPL,ZPL) *---------------------------------------------------------------------- * BUTFLY - Tries to eliminate "butterflies", i.e. the crossing of 2 * adjacent segments of a polygon, by point exchanges. * (Last changed on 28/10/07.) *---------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. +SEQ,PARAMETERS. INTEGER NPL,I,J,K,NPASS,IAXIS,NNEW REAL XPL(NPL),YPL(NPL),ZPL(NPL),XAUX,YAUX,ZAUX, - XMIN,XMAX,YMIN,YMAX,ZMIN,ZMAX,EPSX,EPSY,EPSZ, - XSURF,YSURF,ZSURF LOGICAL CROSS,REPASS,MARK(MXEDGE) EXTERNAL CROSS *** Check the number of points. IF(NPL.GT.MXEDGE)THEN PRINT *,' !!!!!! BUTFLY WARNING : Received more than'// - ' MXEDGE points; data not processed.' RETURN ELSEIF(NPL.LT.3)THEN RETURN ENDIF *** Compute range. XMIN=XPL(1) XMAX=XPL(1) YMIN=YPL(1) YMAX=YPL(1) ZMIN=ZPL(1) ZMAX=ZPL(1) XSURF=0 YSURF=0 ZSURF=0 DO 100 I=2,NPL XMIN=MIN(XMIN,XPL(I)) XMAX=MAX(XMAX,XPL(I)) YMIN=MIN(YMIN,YPL(I)) YMAX=MAX(YMAX,YPL(I)) ZMIN=MIN(ZMIN,ZPL(I)) ZMAX=MAX(ZMAX,ZPL(I)) IF(I.GE.3)THEN XSURF=XSURF+ABS( - (YPL(I )-YPL(1))*(ZPL(I-1)-ZPL(1))- - (YPL(I-1)-YPL(1))*(ZPL(I )-ZPL(1))) YSURF=YSURF+ABS( - (XPL(I )-XPL(1))*(ZPL(I-1)-ZPL(1))- - (XPL(I-1)-XPL(1))*(ZPL(I )-ZPL(1))) ZSURF=ZSURF+ABS( - (XPL(I )-XPL(1))*(YPL(I-1)-YPL(1))- - (XPL(I-1)-XPL(1))*(YPL(I )-YPL(1))) ENDIF 100 CONTINUE *** Set tolerances. IF(LEPSG)THEN EPSX=EPSGX EPSY=EPSGY EPSZ=EPSGZ ELSE EPSX=1.0E-5*ABS(XMAX-XMIN) EPSY=1.0E-5*ABS(YMAX-YMIN) EPSZ=1.0E-5*ABS(ZMAX-ZMIN) IF(EPSX.LE.1E-6)EPSX=1.0E-6 IF(EPSY.LE.1E-6)EPSY=1.0E-6 IF(EPSZ.LE.1E-6)EPSZ=1.0E-6 ENDIF *** Eliminate points appearing twice, initialise marks. DO 50 I=1,NPL MARK(I)=.FALSE. 50 CONTINUE * Scan the list. DO 110 I=1,NPL IF(MARK(I))GOTO 110 DO 120 J=I+1,NPL IF(ABS(XPL(I)-XPL(J)).LE.EPSX.AND. - ABS(YPL(I)-YPL(J)).LE.EPSY.AND. - ABS(ZPL(I)-ZPL(J)).LE.EPSZ)MARK(J)=.TRUE. 120 CONTINUE 110 CONTINUE * And remove the duplicate points. NNEW=0 DO 130 I=1,NPL IF(.NOT.MARK(I))THEN NNEW=NNEW+1 XPL(NNEW)=XPL(I) YPL(NNEW)=YPL(I) ZPL(NNEW)=ZPL(I) ENDIF 130 CONTINUE * Update the number of points. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ BUTFLY DEBUG : Old /'', - '' new number of points: '',2I3)') NPL,NNEW NPL=NNEW *** No risk of having a butterfly with less than 4 points. IF(NPL.LE.3)RETURN *** Select the axis with the largest norm. IF(XSURF.GT.YSURF.AND.XSURF.GT.ZSURF)THEN IAXIS=1 ELSEIF(YSURF.GT.ZSURF)THEN IAXIS=2 ELSE IAXIS=3 ENDIF IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ BUTFLY DEBUG : Main'', - '' axis: '',I3/26X,''x-Surface: '',E15.8/ - 26X,''y-Surface: '',E15.8/26X,''z-Surface: '',E15.8)') - IAXIS,XSURF,YSURF,ZSURF *** Set number of passes to avoid endless loop. NPASS=0 *** Make a pass. 40 CONTINUE NPASS=NPASS+1 REPASS=.FALSE. DO 10 I=1,NPL DO 20 J=I+2,NPL IF(J+1.GT.NPL.AND.1+MOD(J,NPL).GE.I)GOTO 20 * Check for a crossing. IF((IAXIS.EQ.1.AND.CROSS( - YPL(1+MOD(I-1,NPL)),ZPL(1+MOD(I-1,NPL)), - YPL(1+MOD(I ,NPL)),ZPL(1+MOD(I ,NPL)), - YPL(1+MOD(J-1,NPL)),ZPL(1+MOD(J-1,NPL)), - YPL(1+MOD(J ,NPL)),ZPL(1+MOD(J ,NPL)))).OR. - (IAXIS.EQ.2.AND.CROSS( - XPL(1+MOD(I-1,NPL)),ZPL(1+MOD(I-1,NPL)), - XPL(1+MOD(I ,NPL)),ZPL(1+MOD(I ,NPL)), - XPL(1+MOD(J-1,NPL)),ZPL(1+MOD(J-1,NPL)), - XPL(1+MOD(J ,NPL)),ZPL(1+MOD(J ,NPL)))).OR. - (IAXIS.EQ.3.AND.CROSS( - XPL(1+MOD(I-1,NPL)),YPL(1+MOD(I-1,NPL)), - XPL(1+MOD(I ,NPL)),YPL(1+MOD(I ,NPL)), - XPL(1+MOD(J-1,NPL)),YPL(1+MOD(J-1,NPL)), - XPL(1+MOD(J ,NPL)),YPL(1+MOD(J ,NPL)))))THEN * If there is a crossing, exchange the portion in between. DO 30 K=1,(J-I)/2 XAUX=XPL(1+MOD(I+K-1,NPL)) YAUX=YPL(1+MOD(I+K-1,NPL)) ZAUX=ZPL(1+MOD(I+K-1,NPL)) XPL(1+MOD(I+K-1,NPL))=XPL(1+MOD(J-K,NPL)) YPL(1+MOD(I+K-1,NPL))=YPL(1+MOD(J-K,NPL)) ZPL(1+MOD(I+K-1,NPL))=ZPL(1+MOD(J-K,NPL)) XPL(1+MOD(J-K,NPL))=XAUX YPL(1+MOD(J-K,NPL))=YAUX ZPL(1+MOD(J-K,NPL))=ZAUX 30 CONTINUE * And remember we have to do another pass after this. REPASS=.TRUE. ENDIF 20 CONTINUE 10 CONTINUE *** See whether we have to do another pass. IF(REPASS.AND.NPASS.LE.NPL)THEN GOTO 40 ELSEIF(REPASS)THEN PRINT *,' !!!!!! BUTFLY WARNING : Unable to eliminate'// - ' the internal crossings; plot probably incorrect.' IF(LGSTOP)THEN OPEN(UNIT=12,FILE='butfly.dat',STATUS='UNKNOWN') WRITE(12,*) EPSGX,EPSGY,EPSGZ,LEPSG WRITE(12,*) NPL DO 60 I=1,NPL WRITE(12,*) XPL(I),YPL(I),ZPL(I) 60 CONTINUE CLOSE(12) CALL QUIT ENDIF ENDIF END +DECK,BUTFLD. SUBROUTINE BUTFLD(NPL,XPL,YPL,ZPL) *---------------------------------------------------------------------- * BUTFLD - Tries to eliminate "butterflies", i.e. the crossing of 2 * adjacent segments of a polygon, by point exchanges. * (Last changed on 16/11/07.) *---------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. +SEQ,PARAMETERS. INTEGER NPL,I,J,K,NPASS,IAXIS,NNEW DOUBLE PRECISION XPL(NPL),YPL(NPL),ZPL(NPL),XAUX,YAUX,ZAUX, - XMIN,XMAX,YMIN,YMAX,ZMIN,ZMAX,EPSX,EPSY,EPSZ, - XSURF,YSURF,ZSURF LOGICAL CROSSD,REPASS,MARK(MXEDGE) EXTERNAL CROSSD *** Check the number of points. IF(NPL.GT.MXEDGE)THEN PRINT *,' !!!!!! BUTFLD WARNING : Received more than'// - ' MXEDGE points; data not processed.' RETURN ELSEIF(NPL.LE.3)THEN RETURN ENDIF *** Compute range. XMIN=XPL(1) XMAX=XPL(1) YMIN=YPL(1) YMAX=YPL(1) ZMIN=ZPL(1) ZMAX=ZPL(1) XSURF=0 YSURF=0 ZSURF=0 DO 100 I=2,NPL XMIN=MIN(XMIN,XPL(I)) XMAX=MAX(XMAX,XPL(I)) YMIN=MIN(YMIN,YPL(I)) YMAX=MAX(YMAX,YPL(I)) ZMIN=MIN(ZMIN,ZPL(I)) ZMAX=MAX(ZMAX,ZPL(I)) IF(I.GE.3)THEN XSURF=XSURF+ABS( - (YPL(I )-YPL(1))*(ZPL(I-1)-ZPL(1))- - (YPL(I-1)-YPL(1))*(ZPL(I )-ZPL(1))) YSURF=YSURF+ABS( - (XPL(I )-XPL(1))*(ZPL(I-1)-ZPL(1))- - (XPL(I-1)-XPL(1))*(ZPL(I )-ZPL(1))) ZSURF=ZSURF+ABS( - (XPL(I )-XPL(1))*(YPL(I-1)-YPL(1))- - (XPL(I-1)-XPL(1))*(YPL(I )-YPL(1))) ENDIF 100 CONTINUE *** Set tolerances. IF(LEPSG)THEN EPSX=EPSGX EPSY=EPSGY EPSZ=EPSGZ ELSE EPSX=1.0D-10*ABS(XMAX-XMIN) EPSY=1.0D-10*ABS(YMAX-YMIN) EPSZ=1.0D-10*ABS(ZMAX-ZMIN) IF(EPSX.LE.1D-6)EPSX=1.0D-6 IF(EPSY.LE.1D-6)EPSY=1.0D-6 IF(EPSZ.LE.1D-6)EPSZ=1.0D-6 ENDIF *** Eliminate points appearing twice, initialise marks. DO 50 I=1,NPL MARK(I)=.FALSE. 50 CONTINUE * Scan the list. DO 110 I=1,NPL IF(MARK(I))GOTO 110 DO 120 J=I+1,NPL IF(ABS(XPL(I)-XPL(J)).LE.EPSX.AND. - ABS(YPL(I)-YPL(J)).LE.EPSY.AND. - ABS(ZPL(I)-ZPL(J)).LE.EPSZ)MARK(J)=.TRUE. 120 CONTINUE 110 CONTINUE * And remove the duplicate points. NNEW=0 DO 130 I=1,NPL IF(.NOT.MARK(I))THEN NNEW=NNEW+1 XPL(NNEW)=XPL(I) YPL(NNEW)=YPL(I) ZPL(NNEW)=ZPL(I) ENDIF 130 CONTINUE * Update the number of points. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ BUTFLD DEBUG : Old /'', - '' new number of points: '',2I3)') NPL,NNEW NPL=NNEW *** No risk of having a butterfly with less than 4 points. IF(NPL.LE.3)RETURN *** Select the axis with the largest norm. IF(XSURF.GT.YSURF.AND.XSURF.GT.ZSURF)THEN IAXIS=1 ELSEIF(YSURF.GT.ZSURF)THEN IAXIS=2 ELSE IAXIS=3 ENDIF IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ BUTFLD DEBUG : Main'', - '' axis: '',I3/26X,''x-Surface: '',E15.8/ - 26X,''y-Surface: '',E15.8/26X,''z-Surface: '',E15.8)') - IAXIS,XSURF,YSURF,ZSURF *** Set number of passes to avoid endless loop. NPASS=0 *** Make a pass. 40 CONTINUE NPASS=NPASS+1 REPASS=.FALSE. DO 10 I=1,NPL DO 20 J=I+2,NPL IF(J+1.GT.NPL.AND.1+MOD(J,NPL).GE.I)GOTO 20 * Check for a crossing. IF((IAXIS.EQ.1.AND.CROSSD( - YPL(1+MOD(I-1,NPL)),ZPL(1+MOD(I-1,NPL)), - YPL(1+MOD(I ,NPL)),ZPL(1+MOD(I ,NPL)), - YPL(1+MOD(J-1,NPL)),ZPL(1+MOD(J-1,NPL)), - YPL(1+MOD(J ,NPL)),ZPL(1+MOD(J ,NPL)))).OR. - (IAXIS.EQ.2.AND.CROSSD( - XPL(1+MOD(I-1,NPL)),ZPL(1+MOD(I-1,NPL)), - XPL(1+MOD(I ,NPL)),ZPL(1+MOD(I ,NPL)), - XPL(1+MOD(J-1,NPL)),ZPL(1+MOD(J-1,NPL)), - XPL(1+MOD(J ,NPL)),ZPL(1+MOD(J ,NPL)))).OR. - (IAXIS.EQ.3.AND.CROSSD( - XPL(1+MOD(I-1,NPL)),YPL(1+MOD(I-1,NPL)), - XPL(1+MOD(I ,NPL)),YPL(1+MOD(I ,NPL)), - XPL(1+MOD(J-1,NPL)),YPL(1+MOD(J-1,NPL)), - XPL(1+MOD(J ,NPL)),YPL(1+MOD(J ,NPL)))))THEN * If there is a crossing, exchange the portion in between. DO 30 K=1,(J-I)/2 XAUX=XPL(1+MOD(I+K-1,NPL)) YAUX=YPL(1+MOD(I+K-1,NPL)) ZAUX=ZPL(1+MOD(I+K-1,NPL)) XPL(1+MOD(I+K-1,NPL))=XPL(1+MOD(J-K,NPL)) YPL(1+MOD(I+K-1,NPL))=YPL(1+MOD(J-K,NPL)) ZPL(1+MOD(I+K-1,NPL))=ZPL(1+MOD(J-K,NPL)) XPL(1+MOD(J-K,NPL))=XAUX YPL(1+MOD(J-K,NPL))=YAUX ZPL(1+MOD(J-K,NPL))=ZAUX 30 CONTINUE * And remember we have to do another pass after this. REPASS=.TRUE. ENDIF 20 CONTINUE 10 CONTINUE *** See whether we have to do another pass. IF(REPASS.AND.NPASS.LE.NPL)THEN GOTO 40 ELSEIF(REPASS)THEN PRINT *,' !!!!!! BUTFLD WARNING : Unable to eliminate'// - ' the internal crossings; plot probably incorrect.' IF(LGSTOP)THEN OPEN(UNIT=12,FILE='butfld.dat',STATUS='UNKNOWN') WRITE(12,*) EPSGX,EPSGY,EPSGZ,LEPSG WRITE(12,*) NPL DO 60 I=1,NPL WRITE(12,*) XPL(I),YPL(I),ZPL(I) 60 CONTINUE CLOSE(12) CALL QUIT ENDIF ENDIF END +DECK,CROSS. LOGICAL FUNCTION CROSS(X1S,Y1S,X2S,Y2S,U1S,V1S,U2S,V2S) *----------------------------------------------------------------------- * CROSS - Determines whether the 2 straight lines (X1,Y1) to (X2,Y2) * and (U1,U2) to (V1,V2) cross at an intermediate point for * both lines. The variables have been introduced to make this * already elementary routine more understandable. * VARIABLES : A : Matrix storing direction vectors. * DET : Determinant of A. * EPS : Minimum value for DET to be non-zero. * (Last changed on 3/ 9/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PARAMETERS. DOUBLE PRECISION X1,X2,Y1,Y2,U1,U2,V1,V2,A(2,2),DET,EPSX,EPSY, - AUX,XC,YC REAL X1S,Y1S,X2S,Y2S,U1S,U2S,V1S,V2S LOGICAL ONLIND EXTERNAL ONLIND *** Convert input (single precision) variables to double precision. X1=DBLE(X1S) X2=DBLE(X2S) Y1=DBLE(Y1S) Y2=DBLE(Y2S) U1=DBLE(U1S) U2=DBLE(U2S) V1=DBLE(V1S) V2=DBLE(V2S) *** Matrix to compute the crossing point. A(1,1)=Y2-Y1 A(2,1)=V2-V1 A(1,2)=X1-X2 A(2,2)=U1-U2 DET=A(1,1)*A(2,2)-A(1,2)*A(2,1) *** Set tolerances. IF(LEPSG)THEN EPSX=EPSGX EPSY=EPSGY ELSE EPSX=1.0D-5*MAX(ABS(X1),ABS(X2),ABS(U1),ABS(U2)) EPSY=1.0D-5*MAX(ABS(Y1),ABS(Y2),ABS(V1),ABS(V2)) IF(EPSX.LE.0)EPSX=1.0D-5 IF(EPSY.LE.0)EPSY=1.0D-5 ENDIF * Verify the tolerances. IF(EPSX.LE.0.OR.EPSY.LE.0)THEN PRINT *,' !!!!!! CROSS WARNING : Tolerances not'// - ' > 0; returning False.' CROSS=.FALSE. RETURN ENDIF *** Check for a point of one line located on the other line. IF( ONLIND(X1,Y1,X2,Y2,U1,V1).OR.ONLIND(X1,Y1,X2,Y2,U2,V2).OR. - ONLIND(U1,V1,U2,V2,X1,Y1).OR.ONLIND(U1,V1,U2,V2,X2,Y2))THEN C print *,' Point on other line' CROSS=.TRUE. *** Otherwise parallel lines do not cross. ELSEIF(ABS(DET).LT.EPSX*EPSY)THEN C print *,' Parallel, non-touching' CROSS=.FALSE. ELSE *** Crossing, non-trivial lines: solve crossing equations. AUX=A(2,2) A(2,2)=A(1,1)/DET A(1,1)=AUX/DET A(1,2)=-A(1,2)/DET A(2,1)=-A(2,1)/DET * Compute crossing point. XC=A(1,1)*(X1*Y2-X2*Y1)+A(1,2)*(U1*V2-U2*V1) YC=A(2,1)*(X1*Y2-X2*Y1)+A(2,2)*(U1*V2-U2*V1) * See whether the crossing point is on both lines. IF( ONLIND(X1,Y1,X2,Y2,XC,YC).AND. - ONLIND(U1,V1,U2,V2,XC,YC))THEN C print *,' Intersecting lines at ',xc,yc CROSS=.TRUE. ELSE C print *,' Crossing point not on both lines ',xc,yc CROSS=.FALSE. ENDIF ENDIF END +DECK,CROSSD. LOGICAL FUNCTION CROSSD(X1,Y1,X2,Y2,U1,V1,U2,V2) *----------------------------------------------------------------------- * CROSSD - Determines whether the 2 straight lines (X1,Y1) to (X2,Y2) * and (U1,U2) to (V1,V2) cross at an intermediate point for * both lines. The variables have been introduced to make this * already elementary routine more understandable. * VARIABLES : A : Matrix storing direction vectors. * DET : Determinant of A. * EPS : Minimum value for DET to be non-zero. * (Last changed on 3/ 9/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PARAMETERS. DOUBLE PRECISION X1,X2,Y1,Y2,U1,U2,V1,V2,A(2,2),DET,EPSX,EPSY, - AUX,XC,YC LOGICAL ONLIND EXTERNAL ONLIND *** Matrix to compute the crossing point. A(1,1)=Y2-Y1 A(2,1)=V2-V1 A(1,2)=X1-X2 A(2,2)=U1-U2 DET=A(1,1)*A(2,2)-A(1,2)*A(2,1) *** Set tolerances. IF(LEPSG)THEN EPSX=EPSGX EPSY=EPSGY ELSE EPSX=1.0D-10*MAX(ABS(X1),ABS(X2),ABS(U1),ABS(U2)) EPSY=1.0D-10*MAX(ABS(Y1),ABS(Y2),ABS(V1),ABS(V2)) IF(EPSX.LE.0)EPSX=1.0D-10 IF(EPSY.LE.0)EPSY=1.0D-10 ENDIF * Verify the tolerances. IF(EPSX.LE.0.OR.EPSY.LE.0)THEN PRINT *,' !!!!!! CROSSD WARNING : Tolerances not'// - ' > 0; returning False.' CROSSD=.FALSE. RETURN ENDIF *** Check for a point of one line located on the other line. IF( ONLIND(X1,Y1,X2,Y2,U1,V1).OR.ONLIND(X1,Y1,X2,Y2,U2,V2).OR. - ONLIND(U1,V1,U2,V2,X1,Y1).OR.ONLIND(U1,V1,U2,V2,X2,Y2))THEN C print *,' Point on other line' CROSSD=.TRUE. *** Otherwise parallel lines do not cross. ELSEIF(ABS(DET).LT.EPSX*EPSY)THEN C print *,' Parallel, non-touching' CROSSD=.FALSE. ELSE *** Crossing, non-trivial lines: solve crossing equations. AUX=A(2,2) A(2,2)=A(1,1)/DET A(1,1)=AUX/DET A(1,2)=-A(1,2)/DET A(2,1)=-A(2,1)/DET * Compute crossing point. XC=A(1,1)*(X1*Y2-X2*Y1)+A(1,2)*(U1*V2-U2*V1) YC=A(2,1)*(X1*Y2-X2*Y1)+A(2,2)*(U1*V2-U2*V1) * See whether the crossing point is on both lines. IF( ONLIND(X1,Y1,X2,Y2,XC,YC).AND. - ONLIND(U1,V1,U2,V2,XC,YC))THEN C print *,' Intersecting lines at ',xc,yc CROSSD=.TRUE. ELSE C print *,' Crossing point not on both lines ',xc,yc CROSSD=.FALSE. ENDIF ENDIF END +DECK,CRSPNT. SUBROUTINE CRSPNT(X1S,Y1S,X2S,Y2S,U1S,V1S,U2S,V2S,XCS,YCS,CROSS) *----------------------------------------------------------------------- * CRSPNT - Determines whether the 2 straight lines (X1,Y1) to (X2,Y2) * and (U1,U2) to (V1,V2) cross at an intermediate point for * both lines. The variables have been introduced to make this * already elementary routine more understandable. * VARIABLES : A : Matrix storing direction vectors. * DET : Determinant of A. * EPS : Minimum value for DET to be non-zero. * (Last changed on 3/ 9/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PARAMETERS. DOUBLE PRECISION X1,X2,Y1,Y2,U1,U2,V1,V2,A(2,2),DET,EPSX,EPSY, - AUX,XC,YC REAL X1S,Y1S,X2S,Y2S,U1S,V1S,U2S,V2S,XCS,YCS LOGICAL ONLIND,CROSS EXTERNAL ONLIND *** Convert to double precision. X1=DBLE(X1S) Y1=DBLE(Y1S) X2=DBLE(X2S) Y2=DBLE(Y2S) U1=DBLE(U1S) V1=DBLE(V1S) U2=DBLE(U2S) V2=DBLE(V2S) *** Matrix to compute the crossing point. A(1,1)=Y2-Y1 A(2,1)=V2-V1 A(1,2)=X1-X2 A(2,2)=U1-U2 DET=A(1,1)*A(2,2)-A(1,2)*A(2,1) *** Initial values. XCS=0 YCS=0 *** Set tolerances. IF(LEPSG)THEN EPSX=EPSGX EPSY=EPSGY ELSE EPSX=1.0D-5*MAX(ABS(X1),ABS(X2),ABS(U1),ABS(U2)) EPSY=1.0D-5*MAX(ABS(Y1),ABS(Y2),ABS(V1),ABS(V2)) IF(EPSX.LE.0)EPSX=1.0D-5 IF(EPSY.LE.0)EPSY=1.0D-5 ENDIF * Verify the tolerances. IF(EPSX.LE.0.OR.EPSY.LE.0)THEN PRINT *,' !!!!!! CRSPNT WARNING : Tolerances not'// - ' > 0; returning False.' CROSS=.FALSE. RETURN ENDIF *** Check for a point of one line located on the other line. IF(ONLIND(X1,Y1,X2,Y2,U1,V1))THEN C print *,' Point on other line' XC=U1 YC=V1 CROSS=.TRUE. ELSEIF(ONLIND(X1,Y1,X2,Y2,U2,V2))THEN C print *,' Point on other line' XC=U2 YC=V2 CROSS=.TRUE. ELSEIF(ONLIND(U1,V1,U2,V2,X1,Y1))THEN C print *,' Point on other line' XC=X1 YC=Y1 CROSS=.TRUE. ELSEIF(ONLIND(U1,V1,U2,V2,X2,Y2))THEN C print *,' Point on other line' XC=X2 YC=Y2 CROSS=.TRUE. *** Otherwise parallel lines do not cross. ELSEIF(ABS(DET).LT.EPSX*EPSY)THEN C print *,' Parallel, non-touching' CROSS=.FALSE. ELSE *** Crossing, non-trivial lines: solve crossing equations. AUX=A(2,2) A(2,2)=A(1,1)/DET A(1,1)=AUX/DET A(1,2)=-A(1,2)/DET A(2,1)=-A(2,1)/DET * Compute crossing point. XC=A(1,1)*(X1*Y2-X2*Y1)+A(1,2)*(U1*V2-U2*V1) YC=A(2,1)*(X1*Y2-X2*Y1)+A(2,2)*(U1*V2-U2*V1) * See whether the crossing point is on both lines. IF( ONLIND(X1,Y1,X2,Y2,XC,YC).AND. - ONLIND(U1,V1,U2,V2,XC,YC))THEN C print *,' Intersecting lines at ',xc,yc CROSS=.TRUE. ELSE C print *,' Crossing point not on both lines ',xc,yc CROSS=.FALSE. ENDIF ENDIF *** Convert crossing to single precision. XCS=REAL(XC) YCS=REAL(YC) END +DECK,CRLF. SUBROUTINE CRLF(STRING) *----------------------------------------------------------------------- * CRLF - Replaces CR and LF characters by blanks. * (Last changed on 26/11/09.) *----------------------------------------------------------------------- implicit none CHARACTER*(*) STRING INTEGER I *** Loop over the string. DO 10 I=1,LEN(STRING) * Check for LF and CR. IF(ICHAR(STRING(I:I)).EQ.10.OR. - ICHAR(STRING(I:I)).EQ.13)STRING(I:I)=' ' 10 CONTINUE END +DECK,CRSPND. SUBROUTINE CRSPND(X1,Y1,X2,Y2,U1,V1,U2,V2,XC,YC,CROSS) *----------------------------------------------------------------------- * CRSPND - Determines whether the 2 straight lines (X1,Y1) to (X2,Y2) * and (U1,U2) to (V1,V2) cross at an intermediate point for * both lines. The variables have been introduced to make this * already elementary routine more understandable. * VARIABLES : A : Matrix storing direction vectors. * DET : Determinant of A. * EPS : Minimum value for DET to be non-zero. * (Last changed on 3/ 9/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PARAMETERS. DOUBLE PRECISION X1,X2,Y1,Y2,U1,U2,V1,V2,A(2,2),DET,EPSX,EPSY, - AUX,XC,YC LOGICAL ONLIND,CROSS EXTERNAL ONLIND *** Matrix to compute the crossing point. A(1,1)=Y2-Y1 A(2,1)=V2-V1 A(1,2)=X1-X2 A(2,2)=U1-U2 DET=A(1,1)*A(2,2)-A(1,2)*A(2,1) *** Initial values. XC=0 YC=0 *** Set tolerances. IF(LEPSG)THEN EPSX=EPSGX EPSY=EPSGY ELSE EPSX=1.0D-10*MAX(ABS(X1),ABS(X2),ABS(U1),ABS(U2)) EPSY=1.0D-10*MAX(ABS(Y1),ABS(Y2),ABS(V1),ABS(V2)) IF(EPSX.LE.0)EPSX=1.0D-10 IF(EPSY.LE.0)EPSY=1.0D-10 ENDIF * Verify the tolerances. IF(EPSX.LE.0.OR.EPSY.LE.0)THEN PRINT *,' !!!!!! CRSPND WARNING : Tolerances not'// - ' > 0; returning False.' CROSS=.FALSE. RETURN ENDIF *** Check for a point of one line located on the other line. IF(ONLIND(X1,Y1,X2,Y2,U1,V1))THEN C print *,' Point on other line' XC=U1 YC=V1 CROSS=.TRUE. ELSEIF(ONLIND(X1,Y1,X2,Y2,U2,V2))THEN C print *,' Point on other line' XC=U2 YC=V2 CROSS=.TRUE. ELSEIF(ONLIND(U1,V1,U2,V2,X1,Y1))THEN C print *,' Point on other line' XC=X1 YC=Y1 CROSS=.TRUE. ELSEIF(ONLIND(U1,V1,U2,V2,X2,Y2))THEN C print *,' Point on other line' XC=X2 YC=Y2 CROSS=.TRUE. *** Otherwise parallel lines do not cross. ELSEIF(ABS(DET).LT.EPSX*EPSY)THEN C print *,' Parallel, non-touching' CROSS=.FALSE. ELSE *** Crossing, non-trivial lines: solve crossing equations. AUX=A(2,2) A(2,2)=A(1,1)/DET A(1,1)=AUX/DET A(1,2)=-A(1,2)/DET A(2,1)=-A(2,1)/DET * Compute crossing point. XC=A(1,1)*(X1*Y2-X2*Y1)+A(1,2)*(U1*V2-U2*V1) YC=A(2,1)*(X1*Y2-X2*Y1)+A(2,2)*(U1*V2-U2*V1) * See whether the crossing point is on both lines. IF( ONLIND(X1,Y1,X2,Y2,XC,YC).AND. - ONLIND(U1,V1,U2,V2,XC,YC))THEN C print *,' Intersecting lines at ',xc,yc CROSS=.TRUE. ELSE C print *,' Crossing point not on both lines ',xc,yc CROSS=.FALSE. ENDIF ENDIF END +DECK,DENLAN. REAL FUNCTION DENLAN(X) *----------------------------------------------------------------------- * DENLAN - Stolen from G110 in GENLIB. * (Last changed on 7/11/07.) *----------------------------------------------------------------------- implicit none C REAL P1(0:4),P2(0:4),P3(0:4),P4(0:4),P5(0:4),P6(0:4), - Q1(0:4),Q2(0:4),Q3(0:4),Q4(0:4),Q5(0:4),Q6(0:4), - X,U,V INTEGER I,J *** No longer needed (RV 7/11/2007) C DIMENSION A1(1:3),A2(1:2) REAL A2(1:2) *** End of modification. C DATA (P1(I),I=0,4),(Q1(J),J=0,4) 1/ 0.42598 94875E+0,-0.12497 62550E+0, 0.39842 43700E-1, 2 -0.62982 87635E-2, 0.15111 62253E-2, 3 1.0 ,-0.33882 60629E+0, 0.95943 93323E-1, 4 -0.16080 42283E-1, 0.37789 42063E-2/ C DATA (P2(I),I=0,4),(Q2(J),J=0,4) 1/ 0.17885 41609E+0, 0.11739 57403E+0, 0.14888 50518E-1, 2 -0.13949 89411E-2, 0.12836 17211E-3, 3 1.0 , 0.74287 95082E+0, 0.31539 32961E+0, 4 0.66942 19548E-1, 0.87906 09714E-2/ C DATA (P3(I),I=0,4),(Q3(J),J=0,4) 1/ 0.17885 44503E+0, 0.93591 61662E-1, 0.63253 87654E-2, 2 0.66116 67319E-4,-0.20310 49101E-5, 3 1.0 , 0.60978 09921E+0, 0.25606 16665E+0, 4 0.47467 22384E-1, 0.69573 01675E-2/ C DATA (P4(I),I=0,4),(Q4(J),J=0,4) 1/ 0.98740 54407E+0, 0.11867 23273E+3, 0.84927 94360E+3, 2 -0.74377 92444E+3, 0.42702 62186E+3, 3 1.0 , 0.10686 15961E+3, 0.33764 96214E+3, 4 0.20167 12389E+4, 0.15970 63511E+4/ C DATA (P5(I),I=0,4),(Q5(J),J=0,4) 1/ 0.10036 75074E+1, 0.16757 02434E+3, 0.47897 11289E+4, 2 0.21217 86767E+5,-0.22324 94910E+5, 3 1.0 , 0.15694 24537E+3, 0.37453 10488E+4, 4 0.98346 98876E+4, 0.66924 28357E+5/ C DATA (P6(I),I=0,4),(Q6(J),J=0,4) 1/ 0.10008 27619E+1, 0.66491 43136E+3, 0.62972 92665E+5, 2 0.47555 46998E+6,-0.57436 09109E+7, 3 1.0 , 0.65141 01098E+3, 0.56974 73333E+5, 4 0.16591 74725E+6,-0.28157 59939E+7/ C *** A1 no longer needed (RV 7/11/2007). C DATA (A1(I),I=1,3) C 1/ 0.41666 66667E-1,-0.19965 27778E-1, 0.27095 38966E-1/ *** End of modification. DATA (A2(I),I=1,2) 1/-0.18455 68670E+1,-0.42846 40743E+1/ C V=X *** Modification (RV 7/3/97) IF(V.LT.-5.0)THEN DENLAN=0 ELSEIF(V.GT.1E12)THEN DENLAN=0 C IF(V .LT. -5.5) THEN C U=EXP(V+1.0) C DENLAN=0.3989422803*(EXP(-1.0/U)/SQRT(U))* C 1 (1.0+(A1(1)+(A1(2)+A1(3)*U)*U)*U) *** End of modification. ELSE IF(V .LT. -1.0) THEN U=EXP(-V-1.0) DENLAN=EXP(-U)*SQRT(U)* 1 (P1(0)+(P1(1)+(P1(2)+(P1(3)+P1(4)*V)*V)*V)*V)/ 2 (Q1(0)+(Q1(1)+(Q1(2)+(Q1(3)+Q1(4)*V)*V)*V)*V) ELSE IF(V .LT. 1.0) THEN DENLAN=(P2(0)+(P2(1)+(P2(2)+(P2(3)+P2(4)*V)*V)*V)*V)/ 1 (Q2(0)+(Q2(1)+(Q2(2)+(Q2(3)+Q2(4)*V)*V)*V)*V) ELSE IF(V .LT. 5.0) THEN DENLAN=(P3(0)+(P3(1)+(P3(2)+(P3(3)+P3(4)*V)*V)*V)*V)/ 1 (Q3(0)+(Q3(1)+(Q3(2)+(Q3(3)+Q3(4)*V)*V)*V)*V) ELSE IF(V .LT. 12.0) THEN U=1.0/V DENLAN=U**2*(P4(0)+(P4(1)+(P4(2)+(P4(3)+P4(4)*U)*U)*U)*U)/ 1 (Q4(0)+(Q4(1)+(Q4(2)+(Q4(3)+Q4(4)*U)*U)*U)*U) ELSE IF(V .LT. 50.0) THEN U=1.0/V DENLAN=U**2*(P5(0)+(P5(1)+(P5(2)+(P5(3)+P5(4)*U)*U)*U)*U)/ 1 (Q5(0)+(Q5(1)+(Q5(2)+(Q5(3)+Q5(4)*U)*U)*U)*U) ELSE IF(V .LT. 300.0) THEN U=1.0/V DENLAN=U**2*(P6(0)+(P6(1)+(P6(2)+(P6(3)+P6(4)*U)*U)*U)*U)/ 1 (Q6(0)+(Q6(1)+(Q6(2)+(Q6(3)+Q6(4)*U)*U)*U)*U) ELSE U=1.0/(V-V*LOG(V)/(V+1.0)) DENLAN=U**2*(1.0+(A2(1)+A2(2)*U)*U) END IF END +DECK,DIVDF2E,IF=ESSL. DOUBLE PRECISION FUNCTION DIVDF2(F,A,N,X,M) *----------------------------------------------------------------------- * DIVDF2 - Double precision interpolation routine, calling sequence * as for DIVDIF (E105) but using ESSL. * (Last changed on 27/ 3/96.) *----------------------------------------------------------------------- IMPLICIT DOUBLE PRECISION(A-H,O-Z) +SEQ,DIMENSIONS. DOUBLE PRECISION F(*),A(*),T(1),S(1),AUX(MXLIST+1),X T(1)=X CALL DTPINT(A,F,N,M+1,T,S,1,AUX,MXLIST+1) DIVDF2=S(1) END +DECK,DIVDF2C,IF=-ESSL. DOUBLE PRECISION FUNCTION DIVDF2(F,A,NN,X,MM) *----------------------------------------------------------------------- * DIVDF2 - Double precision version of DIVDIF (CERN program library * E105) which performs tabular interpolation using * symmetrically placed argument points. Added a check on * X values located on the limits. * (Last changed on 20/ 8/02.) *----------------------------------------------------------------------- IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION A(*),F(*),T(20),D(20) LOGICAL EXTRA DATA MMAX/10/ *** Check the arguments. IF( (NN.LT.2) .OR. (MM.LT.1) ) THEN PRINT *,' ###### DIVDF2 ERROR : Invalid dimensions'// - ' received for the arguments.' GO TO 20 ENDIF *** Deal with the case that X is located at A(1) or A(N). IF(ABS(X-A(1)).LE.1E-6*(ABS(A(1))+ABS(A(NN))))THEN C print *,' x at lower limit ',x,a(1),a(nn) DIVDF2=F(1) RETURN ELSEIF(ABS(X-A(NN)).LE.1E-6*(ABS(A(1))+ABS(A(NN))))THEN C print *,' x at upper limit ',x,a(1),a(nn) DIVDF2=F(NN) RETURN ENDIF C if(x.lt.a(1).or.x.gt.a(nn))print *,'x out of range: ',x *** Find subscript IX of X in array A. N=NN M=MIN0(MM,MMAX,N-1) MPLUS=M+1 IX=0 IY=N+1 IF(A(1).GT.A(N)) GO TO 4 *** Search increasing arguments. 1 MID=(IX+IY)/2 IF(X.GE.A(MID)) GO TO 2 IY=MID GO TO 3 *** If true. 2 IX=MID 3 IF(IY-IX.GT.1) GO TO 1 GO TO 7 *** Search decreasing arguments. 4 MID=(IX+IY)/2 IF(X.LE.A(MID)) GO TO 5 IY=MID GO TO 6 C (IF TRUE.) 5 IX=MID 6 IF(IY-IX.GT.1) GO TO 4 C C Copy reordered interpolation points into (T(I),D(I)), setting C *EXTRA* to TRUE if M+2 points to be used. C 7 NPTS=M+2-MOD(M,2) IP=0 L=0 GO TO 9 8 L=-L IF(L.GE.0) L=L+1 9 ISUB=IX+L IF((1.LE.ISUB).AND.(ISUB.LE.N)) GO TO 10 *** skip point. NPTS=MPLUS GO TO 11 *** Insert point. 10 IP=IP+1 T(IP)=A(ISUB) D(IP)=F(ISUB) 11 IF(IP.LT.NPTS) GO TO 8 EXTRA=NPTS.NE.MPLUS C C Replace d by the leading diagonal of a divided-difference table, sup- C plemented by an extra line if *EXTRA* is true. C DO 14 L=1,M IF(.NOT.EXTRA) GO TO 12 ISUB=MPLUS-L D(M+2)=(D(M+2)-D(M))/(T(M+2)-T(ISUB)) 12 I=MPLUS DO 13 J=L,M ISUB=I-L D(I)=(D(I)-D(I-1))/(T(I)-T(ISUB)) I=I-1 13 CONTINUE 14 CONTINUE C C Evaluate the Newton interpolation formula at X, averaging two values C of last difference if *EXTRA* is TRUE. C SUM=D(MPLUS) IF(EXTRA) SUM=0.5*(SUM+D(M+2)) J=M DO 15 L=1,M SUM=D(J)+(X-T(J))*SUM J=J-1 15 CONTINUE DIVDF2=SUM RETURN *** Error processing. 20 CONTINUE DIVDF2=0 END +DECK,BOOK. SUBROUTINE BOOK(ACTION,REFER,MYNAME,IFAIL) *----------------------------------------------------------------------- * BOOK - Book keeping of various items. * (Last changed on 12/10/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. INTEGER MXBOOK PARAMETER(MXBOOK=50) CHARACTER*(*) ACTION,REFER,MYNAME CHARACTER*10 NAME(MXBOOK),USER(MXBOOK) INTEGER STATE(MXBOOK),IFAIL,INPCMX,NBOOK,IREF,I EXTERNAL INPCMX +SELF,IF=SAVE. SAVE NAME,STATE,NBOOK,USER +SELF. DATA NBOOK/0/ *** Allocate a new class. IF(INPCMX(ACTION,'INIT#IALISE').NE.0)THEN * Check there is space left. IF(NBOOK.GE.MXBOOK)THEN PRINT *,' ###### BOOK ERROR : No room to for'// - ' the new object ',REFER,'.' IFAIL=1 RETURN ENDIF * Add the item to the list. NBOOK=NBOOK+1 NAME(NBOOK)=REFER STATE(NBOOK)=0 USER(NBOOK)=' ' * Debugging output. IF(LDEBUG)PRINT *,' ++++++ BOOK DEBUG : New object ', - REFER,' declared as item ',NBOOK,'.' * Successful completion. IFAIL=0 *** Book an object. ELSEIF(INPCMX(ACTION,'BOOK').NE.0)THEN * Locate the object. IREF=0 DO 10 I=1,NBOOK IF(INPCMX(REFER,NAME(I)).NE.0)IREF=I 10 CONTINUE * Object not known. IF(IREF.EQ.0)THEN PRINT *,' !!!!!! BOOK WARNING : The object ', - REFER,' is not known ; not booked.' IFAIL=1 RETURN ENDIF * First check the object has not yet been booked. IF(STATE(IREF).EQ.1.AND.USER(IREF).EQ.MYNAME)THEN PRINT *,' ------ BOOK MESSAGE : Object ', - REFER,' is already booked by same user;'// - ' not booked again.' IFAIL=0 RETURN ELSEIF(STATE(IREF).EQ.1)THEN PRINT *,' !!!!!! BOOK WARNING : Object ', - REFER,' is already booked by user '// - USER(IREF)//'; not booked again.' IFAIL=1 RETURN ENDIF * Book the object. STATE(IREF)=1 USER(IREF)=MYNAME * Debugging output. IF(LDEBUG)PRINT *,' ++++++ BOOK DEBUG : Object ', - REFER,' booked by ',MYNAME,'.' * Successful completion. IFAIL=0 *** Release an object. ELSEIF(INPCMX(ACTION,'REL#EASE').NE.0)THEN * Locate the object. IREF=0 DO 20 I=1,NBOOK IF(INPCMX(REFER,NAME(I)).NE.0)IREF=I 20 CONTINUE * Object not known. IF(IREF.EQ.0)THEN PRINT *,' !!!!!! BOOK WARNING : The object ', - REFER,' is not known ; not released.' IFAIL=1 RETURN ENDIF * Don't release an object booked by someone else. IF(STATE(IREF).EQ.1.AND.USER(IREF).NE.MYNAME)THEN PRINT *,' !!!!!! BOOK WARNING : The object ', - REFER,' was booked by ',USER(IREF) PRINT *,' Permission'// - ' to release denied ; not released.' IFAIL=1 RETURN ENDIF * Debugging output. IF(LDEBUG)PRINT *,' ++++++ BOOK DEBUG : Object ', - REFER,' released, previous state ',STATE(IREF), - ', previous user ',USER(IREF) * Release the object. C IF(INPCMX(ACTION,'CL#EAR').NE.0)THEN STATE(IREF)=0 USER(IREF)=' ' C ELSE C STATE(IREF)=2 C ENDIF * Successful completion. IFAIL=0 *** Inquiry. ELSEIF(INPCMX(ACTION,'INQ#UIRE').NE.0)THEN * Locate the object. IREF=0 DO 30 I=1,NBOOK IF(INPCMX(REFER,NAME(I)).NE.0)IREF=I 30 CONTINUE * Object not known. IF(IREF.EQ.0)THEN PRINT *,' !!!!!! BOOK WARNING : The object ', - REFER,' is not known ; no information.' IFAIL=1 RETURN ENDIF * Return the user name. IF(STATE(IREF).EQ.0)THEN MYNAME=' ' ELSE MYNAME=USER(IREF) ENDIF * Successful completion. IFAIL=0 *** List of states. ELSEIF(INPCMX(ACTION,'L#IST').NE.0)THEN * Header, depending on the number of objects. IF(NBOOK.EQ.0)THEN WRITE(LUNOUT,'(/'' No objects defined sofar.''/)') IFAIL=0 RETURN ELSE WRITE(LUNOUT,'(/'' CURRENTLY KNOWN OBJECTS:''// - '' Name '',5X,'' Status'')') ENDIF * List of objects. DO 40 I=1,NBOOK IF(STATE(I).EQ.0)THEN WRITE(LUNOUT,'(2X,A10,5X,'' Declared, not in use'')') - NAME(I) ELSEIF(STATE(I).EQ.1)THEN WRITE(LUNOUT,'(2X,A10,5X,'' Booked by '',A10)') - NAME(I),USER(I) ELSEIF(STATE(I).EQ.2)THEN WRITE(LUNOUT,'(2X,A10,5X,'' Free, last used by '', - A10)') NAME(I),USER(I) ELSE WRITE(LUNOUT,'(2X,A10,5X,'' Declared, state code '', - I5,'', user '',A10)') STATE(I),NAME(I),USER(I) ENDIF 40 CONTINUE WRITE(LUNOUT,'('' '')') * Always successful. IFAIL=0 *** Unknown action. ELSE PRINT *,' !!!!!! BOOK WARNING : Unknown request ',ACTION, - ' received; nothing done.' IFAIL=1 ENDIF END +DECK,BTEXT,IF=CDC. SUBROUTINE BTEXT(TEXT) *----------------------------------------------------------------------- * N I K H E F C Y B E R O N L Y * BTEXT - ROUTINE DIE EEN TEKSTJE OP HET B-SCHERM VAN DE CYBER ZET *----------------------------------------------------------------------- COMMON/BDISP/ITEXT(8) CHARACTER*80 TEXT CHARACTER*80 INFILE +SELF,IF=SAVE. SAVE NUMMER +SELF. DATA NUMMER/0/ *** ENIGE FORMATS DEFINIEREN 1010 FORMAT(8A10) 1020 FORMAT('===== DRIFTKAMER ',A14,' =====', - '===== STAP ',I3,' =====') *** CHARACTER VERSIE TEKST MAKEN EN OMZETTEN IN INTEGER NUMMER=NUMMER+1 WRITE(INFILE,1020) TEXT(1:14),NUMMER READ(INFILE,1010) ITEXT *** TEKST OP SCHERM ZETTEN MET COMPASS ROUTINE BDISP CALL BDISP END IDENT BDISP LIST -L,-R USE /BDISP/ ADRESS BSS 8 USE * ENTRY BDISP BDISP BSS 1 MESSAGE ADRESS,B,RECALL JP BDISP END +DECK,CRTUBE. SUBROUTINE CRTUBE(X0,Y0,Z0,X1,Y1,Z1, - XX0,YY0,ZZ0,XX1,YY1,ZZ1,R,IFAIL) *----------------------------------------------------------------------- * CRTUBE - Computes the crossing points of a tube with a line segment. * (Last changed on 25/ 3/96.) *----------------------------------------------------------------------- DOUBLE PRECISION C0,C1,C2,DET2,P1,P2 REAL X0,Y0,Z0,X1,Y1,Z1,XX0,YY0,ZZ0,XX1,YY1,ZZ1,R INTEGER IFAIL *** Initial values. XX0=X0 XX1=X1 YY0=Y0 YY1=Y1 ZZ0=Z0 ZZ1=Z1 IFAIL=1 *** Polynomial coefficients. C2=(X1-X0)**2+(Y1-Y0)**2 C1=2*X0*(X1-X0)+2*Y0*(Y1-Y0) C0=X0**2+Y0**2-R**2 *** Determinant. DET2=C1**2-4*C0*C2 *** Solutions. IF(DET2.LT.0)THEN PRINT *,' !!!!!! CRTUBE WARNING : The line segment does'// - ' not cross the tube.' RETURN ELSEIF(DET2.EQ.0)THEN C P1=-C1/(2*C2) C P2=-C1/(2*C2) PRINT *,' !!!!!! CRTUBE WARNING : The line segment'// - ' touches the tube or has length 0.' RETURN ELSE P1=(-C1-SQRT(DET2))/(2*C2) P2=(-C1+SQRT(DET2))/(2*C2) ENDIF IF((P1.LT.0.AND.P2.LT.0).OR.(P1.GT.1.AND.P2.GT.1))THEN PRINT *,' !!!!!! CRTUBE WARNING : The line segment is'// - ' located outside the tube.' RETURN ENDIF *** Slightly shorten the line segment. IF(P1.LT.0)THEN P1=0 ELSEIF(P1.GT.1)THEN P1=1 ELSEIF(P1.GT.0.5)THEN P1=0.999*P1 ELSE P1=1.001*P1 ENDIF IF(P2.LT.0)THEN P2=0 ELSEIF(P2.GT.1)THEN P2=1 ELSEIF(P2.GT.0.5)THEN P2=0.999*P2 ELSE P2=1.001*P2 ENDIF *** And establish the new end points. XX0=X0+P1*(X1-X0) YY0=Y0+P1*(Y1-Y0) ZZ0=Z0+P1*(Z1-Z0) XX1=X0+P2*(X1-X0) YY1=Y0+P2*(Y1-Y0) ZZ1=Z0+P2*(Z1-Z0) *** Things worked, reset IFAIL to 0. IFAIL=0 END +DECK,ROUCAL. SUBROUTINE ROUCAL(INSTR,IFAIL) *----------------------------------------------------------------------- * ROUCAL - Interface to some routines. * (Last changed on 27/ 6/07.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,MATDATA. +SEQ,ALGDATA. +SEQ,GLOBALS. INTEGER ISIZ(MXMDIM),NARG,IPROC,INSTR,IFAIL,MATSLT,IFAIL1,IFAIL2, - ISLOT1,ISLOT2,ISLOT3,ISLOT4,IREF3,IREF4,NITMAX, - NDIM,IMOD,LENGTH,J,NC,IENTRY,NNRES,NCOPT REAL CUMRNF(200),FRNDFU,EPSX,EPSF,FVAVIL,RNDVAV,RNDVVL CHARACTER*(MXCHAR) STRING,OPTION CHARACTER*10 VARLIS(MXVAR) LOGICAL USE(MXVAR),FUNSET EXTERNAL MATSLT,FRNDFU,FVAVIL,RNDVAV,RNDVVL COMMON /RNDFCM/ IENTRY,FUNSET,CUMRNF *** Assume the CALL will fail. IFAIL=1 CALL LOGSAV(.FALSE.,'OK',IFAIL1) *** Some easy reference variables. NARG=INS(INSTR,3) IPROC=INS(INSTR,1) *** Cartesian, Polar, Internal to one of the others. IF(IPROC.LE.-701.AND.IPROC.GE.-706)THEN * Warn if there are arguments. IF(NARG.NE.4.OR. - (MODARG(1).NE.2.AND.MODARG(1).NE.5).OR. - (MODARG(2).NE.2.AND.MODARG(2).NE.5).OR. - MODARG(1).NE.MODARG(2).OR. - ARGREF(3,1).GE.2.OR.ARGREF(4,1).GE.2)THEN PRINT *,' !!!!!! ROUCAL WARNING : The mapping'// - ' procedure got wrong arguments; no mapping.' RETURN ENDIF * Clear up any storage associated with the output arguments. CALL ALGREU(NINT(ARG(3)),MODARG(3),ARGREF(3,1)) CALL ALGREU(NINT(ARG(4)),MODARG(4),ARGREF(4,1)) ** If the arguments are simple numbers ... IF(MODARG(1).EQ.2)THEN IF(IPROC.EQ.-701)THEN CALL CFMCTP(ARG(1),ARG(2),ARG(3),ARG(4),1) ELSEIF(IPROC.EQ.-702)THEN CALL CFMCTR(ARG(1),ARG(2),ARG(3),ARG(4),1) ELSEIF(IPROC.EQ.-703)THEN CALL CFMPTC(ARG(1),ARG(2),ARG(3),ARG(4),1) ELSEIF(IPROC.EQ.-704)THEN CALL CFMPTR(ARG(1),ARG(2),ARG(3),ARG(4),1,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! ROUCAL WARNING : Invalid'// - ' polar coordinates; no conversion.' RETURN ENDIF ELSEIF(IPROC.EQ.-705)THEN CALL CFMRTC(ARG(1),ARG(2),ARG(3),ARG(4),1) ELSEIF(IPROC.EQ.-706)THEN CALL CFMRTP(ARG(1),ARG(2),ARG(3),ARG(4),1) ENDIF * And make sure the output is registered as a number. MODARG(3)=2 MODARG(4)=2 ** If the arguments are matrices. ELSE * Locate the input matrices. ISLOT1=MATSLT(NINT(ARG(1))) ISLOT2=MATSLT(NINT(ARG(2))) IF(ISLOT1.LE.0.OR.ISLOT2.LE.0)THEN PRINT *,' !!!!!! ROUCAL WARNING : Unable to'// - ' locate input matrices; no conversion.' RETURN ELSEIF(MLEN(ISLOT1).NE.MLEN(ISLOT2).OR. - MLEN(ISLOT1).LT.1)THEN PRINT *,' !!!!!! ROUCAL WARNING : Matrices have'// - ' different or zero size; no conversion.' RETURN ENDIF * Store the length. LENGTH=MLEN(ISLOT1) * Create output matrices of the size of the input matrices. DO 10 J=1,MDIM(ISLOT1) ISIZ(J)=MSIZ(ISLOT1,J) 10 CONTINUE NDIM=MDIM(ISLOT1) IMOD=MMOD(ISLOT1) CALL MATADM('ALLOCATE',IREF3,NDIM,ISIZ,IMOD,IFAIL1) CALL MATADM('ALLOCATE',IREF4,NDIM,ISIZ,IMOD,IFAIL2) IF(IFAIL1.NE.0.OR.IFAIL2.NE.0)THEN PRINT *,' !!!!!! ROUCAL WARNING : Unable to'// - ' allocate output matrices; no conversion.' RETURN ENDIF * Now locate all matrices again (they can have been relocated). ISLOT1=MATSLT(NINT(ARG(1))) ISLOT2=MATSLT(NINT(ARG(2))) ISLOT3=MATSLT(IREF3) ISLOT4=MATSLT(IREF4) IF(ISLOT1.LE.0.OR.ISLOT2.LE.0.OR. - ISLOT3.LE.0.OR.ISLOT4.LE.0)THEN PRINT *,' !!!!!! ROUCAL WARNING : Unable to'// - ' locate a matrix; no conversion.' RETURN ENDIF * And carry out the conversion. IF(IPROC.EQ.-701)THEN CALL CFMCTP(MVEC(MORG(ISLOT1)+1), - MVEC(MORG(ISLOT2)+1),MVEC(MORG(ISLOT3)+1), - MVEC(MORG(ISLOT4)+1),LENGTH) ELSEIF(IPROC.EQ.-702)THEN CALL CFMCTR(MVEC(MORG(ISLOT1)+1), - MVEC(MORG(ISLOT2)+1),MVEC(MORG(ISLOT3)+1), - MVEC(MORG(ISLOT4)+1),LENGTH) ELSEIF(IPROC.EQ.-703)THEN CALL CFMPTC(MVEC(MORG(ISLOT1)+1), - MVEC(MORG(ISLOT2)+1),MVEC(MORG(ISLOT3)+1), - MVEC(MORG(ISLOT4)+1),LENGTH) ELSEIF(IPROC.EQ.-704)THEN CALL CFMPTR(MVEC(MORG(ISLOT1)+1), - MVEC(MORG(ISLOT2)+1),MVEC(MORG(ISLOT3)+1), - MVEC(MORG(ISLOT4)+1),LENGTH,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! ROUCAL WARNING : Invalid'// - ' polar coordinates; no conversion.' RETURN ENDIF ELSEIF(IPROC.EQ.-705)THEN CALL CFMRTC(MVEC(MORG(ISLOT1)+1), - MVEC(MORG(ISLOT2)+1),MVEC(MORG(ISLOT3)+1), - MVEC(MORG(ISLOT4)+1),LENGTH) ELSEIF(IPROC.EQ.-706)THEN CALL CFMRTP(MVEC(MORG(ISLOT1)+1), - MVEC(MORG(ISLOT2)+1),MVEC(MORG(ISLOT3)+1), - MVEC(MORG(ISLOT4)+1),LENGTH) ENDIF * Update the output arrays. ARG(3)=IREF3 ARG(4)=IREF4 MODARG(3)=5 MODARG(4)=5 ENDIF *** Random numbers according to a function: preparation. ELSEIF(IPROC.EQ.-710)THEN * Check the arguments. IF(NARG.NE.3.OR.MODARG(1).NE.1.OR.MODARG(2).NE.2.OR. - MODARG(3).NE.2)THEN PRINT *,' !!!!!! ROUCAL WARNING :'// - ' PREPARE_RND_FUNCTION received an incorrect'// - ' argument list; not executed.' FUNSET=.FALSE. RETURN ENDIF * Fetch the function. CALL STRBUF('READ',NINT(ARG(1)),STRING,NC,IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! ROUCAL WARNING : Unable to retrieve'// - ' the PREPARE_RND_FUNCTION function; call not'// - ' executed.' FUNSET=.FALSE. RETURN ENDIF CALL CLTOU(STRING(1:NC)) * Translate the function. VARLIS(1)='X' CALL ALGPRE(STRING(1:NC),NC,VARLIS,1,NNRES,USE,IENTRY,IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! ROUCAL WARNING : Unable to'// - ' translate '//STRING(1:NC)//' ; no random'// - ' numbers.' FUNSET=.FALSE. RETURN ELSEIF(NNRES.NE.1)THEN PRINT *,' !!!!!! ROUCAL WARNING : '//STRING(1:NC)// - ' does not return 1 result; no random numbers.' CALL ALGCLR(IENTRY) FUNSET=.FALSE. RETURN ENDIF * Prepare the function with FUGLXF. CALL FUGLXP(FRNDFU,CUMRNF,ARG(2),ARG(3),IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! ROUCAL WARNING : Preparing '// - STRING(1:NC)//' for random number generation'// - ' failed; no random numbers.' CALL ALGCLR(IENTRY) FUNSET=.FALSE. RETURN ENDIF * If we get this far, preparation was successful. FUNSET=.TRUE. *** Extremum search. ELSEIF(IPROC.EQ.-711)THEN ** Syntax for a function argument. IF(MODARG(1).EQ.1)THEN * Check argument list. IF(NARG.LT.4.OR.NARG.GT.8.OR. - (ARGREF(2,2).LT.1.OR.ARGREF(2,2).GT.NGLB).OR. - MODARG(3).NE.2.OR.MODARG(4).NE.2.OR. - (NARG.GE.5.AND.MODARG(5).NE.1).OR. - (NARG.GE.6.AND.MODARG(6).NE.2).OR. - (NARG.GE.7.AND.MODARG(7).NE.2).OR. - (NARG.GE.8.AND.MODARG(8).NE.2))THEN PRINT *,' !!!!!! ROUCAL WARNING : Incorrect'// - ' argument list for EXTREMUM; not called.' RETURN ENDIF * Retrieve the parameters, first the function. CALL STRBUF('READ',NINT(ARG(1)),STRING,NC,IFAIL) IF(IFAIL.NE.0.OR.NC.LT.1)THEN PRINT *,' !!!!!! ROUCAL WARNING : Unable to'// - ' retrieve the function for EXTREMUM;'// - ' not called.' RETURN ENDIF CALL CLTOU(STRING(1:NC)) * Convergence. IF(NARG.GE.6)THEN EPSX=ARG(6) ELSE EPSX=1.0E-4 ENDIF IF(NARG.GE.7)THEN EPSF=ARG(7) ELSE EPSF=1.0E-4 ENDIF IF(NARG.GE.6)THEN NITMAX=NINT(ARG(8)) ELSE NITMAX=20 ENDIF * Options. IF(NARG.GE.5)THEN CALL STRBUF('READ',NINT(ARG(5)),OPTION,NCOPT, - IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! ROUCAL WARNING : Unable'// - ' to retrieve the options for'// - ' EXTREMUM; not called.' RETURN ENDIF IF(NCOPT.LT.1)THEN OPTION=' ' NCOPT=1 ENDIF CALL CLTOU(OPTION(1:NCOPT)) ELSE OPTION=' ' NCOPT=1 ENDIF * Call the procedure. CALL FUNEXT(STRING(1:NC),NC,ARGREF(2,2),ARG(3),ARG(4), - OPTION(1:NCOPT),EPSX,EPSF,NITMAX,IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! ROUCAL WARNING : Extremum'// - ' search failed; global not updated.' RETURN ENDIF * Return the result. ARG(2)=GLBVAL(ARGREF(2,2)) MODARG(2)=2 ** Matrix arguments. ELSEIF(MODARG(1).EQ.5.AND.MODARG(2).EQ.5)THEN * Check argument list. IF(NARG.LT.3.OR.NARG.GT.7.OR. - (ARGREF(3,2).LT.1.OR.ARGREF(3,2).GT.NGLB).OR. - (NARG.GE.4.AND.MODARG(4).NE.1).OR. - (NARG.GE.5.AND.MODARG(5).NE.2).OR. - (NARG.GE.6.AND.MODARG(6).NE.2).OR. - (NARG.GE.7.AND.MODARG(7).NE.2))THEN PRINT *,' !!!!!! ROUCAL WARNING : Incorrect'// - ' argument list for EXTREMUM; not called.' RETURN ENDIF * Convergence. IF(NARG.GE.5)THEN EPSX=ARG(5) ELSE EPSX=1.0E-4 ENDIF IF(NARG.GE.6)THEN EPSF=ARG(6) ELSE EPSF=1.0E-4 ENDIF IF(NARG.GE.7)THEN NITMAX=NINT(ARG(7)) ELSE NITMAX=20 ENDIF * Options. IF(NARG.GE.4)THEN CALL STRBUF('READ',NINT(ARG(4)),OPTION,NCOPT, - IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! ROUCAL WARNING : Unable'// - ' to retrieve the options for'// - ' EXTREMUM; not called.' RETURN ENDIF IF(NCOPT.LT.1)THEN OPTION=' ' NCOPT=1 ENDIF CALL CLTOU(OPTION(1:NCOPT)) ELSE OPTION=' ' NCOPT=1 ENDIF * Call the procedure. CALL MATEXT(NINT(ARG(1)),NINT(ARG(2)),ARG(3), - OPTION(1:NCOPT),EPSX,EPSF,NITMAX,IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! ROUCAL WARNING : Extremum'// - ' search failed; global not updated.' RETURN ENDIF MODARG(3)=2 ELSE PRINT *,' !!!!!! ROUCAL WARNING : Unknown argument'// - ' type for EXTREMUM; not called.' RETURN ENDIF *** Random number initialisation. ELSEIF(IPROC.EQ.-712)THEN * Check number of arguments. IF(NARG.NE.1)THEN PRINT *,' !!!!!! ROUCAL WARNING : Incorrect number'// - ' of arguments for INITIALISE_GENERATORS.' RETURN ENDIF * Call the procedure. CALL RNDINI(NINT(ARG(1))) *** Vavilov function ELSEIF(IPROC.EQ.-713)THEN * Check number of arguments. IF(NARG.NE.4.OR. - MODARG(1).NE.2.OR.MODARG(2).NE.2.OR. - (MODARG(3).NE.2.AND.MODARG(3).NE.5).OR. - ARGREF(4,1).GE.2)THEN PRINT *,' !!!!!! ROUCAL WARNING : Incorrect number'// - ' of arguments for VAVILOV; no value returned' RETURN ENDIF * Reclaim argument space. CALL ALGREU(NINT(ARG(4)),MODARG(4),ARGREF(4,1)) * Number as argument. IF(MODARG(3).EQ.2)THEN ARG(4)=FVAVIL(ARG(1),ARG(2),ARG(3)) MODARG(4)=2 * Matrix argument ELSE * Locate the input matrices. ISLOT3=MATSLT(NINT(ARG(3))) IF(ISLOT3.LE.0)THEN PRINT *,' !!!!!! ROUCAL WARNING : Unable to'// - ' locate input matrix; no Vavilov value.' RETURN ENDIF * Store the length. LENGTH=MLEN(ISLOT3) * Create output matrices of the size of the input matrices. DO 20 J=1,MDIM(ISLOT3) ISIZ(J)=MSIZ(ISLOT3,J) 20 CONTINUE NDIM=MDIM(ISLOT3) IMOD=MMOD(ISLOT3) CALL MATADM('ALLOCATE',IREF4,NDIM,ISIZ,IMOD,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! ROUCAL WARNING : Unable to'// - ' allocate output matrix; no Vavilov.' RETURN ENDIF * Now locate all matrices again (they can have been relocated). ISLOT3=MATSLT(NINT(ARG(3))) ISLOT4=MATSLT(IREF4) IF(ISLOT3.LE.0.OR.ISLOT4.LE.0)THEN PRINT *,' !!!!!! ROUCAL WARNING : Unable to'// - ' locate a matrix; no Vavilov values.' RETURN ENDIF * Evaluate. DO 30 J=1,LENGTH MVEC(MORG(ISLOT4)+J)= - FVAVIL(ARG(1),ARG(2),MVEC(MORG(ISLOT3)+J)) 30 CONTINUE ARG(4)=REAL(IREF4) MODARG(4)=5 ENDIF *** Vavilov random number (fast). ELSEIF(IPROC.EQ.-714)THEN * Check number of arguments. IF(NARG.NE.3.OR. - MODARG(1).NE.2.OR.MODARG(2).NE.2.OR. - ARGREF(3,1).GE.2)THEN PRINT *,' !!!!!! ROUCAL WARNING : Incorrect number'// - ' of arguments for RND_VAVILOV_FAST;'// - ' no value returned' RETURN ENDIF * Reclaim argument space. CALL ALGREU(NINT(ARG(3)),MODARG(3),ARGREF(3,1)) * Obtain a value ARG(3)=RNDVAV(ARG(1),ARG(2)) MODARG(3)=2 *** Vavilov random number (precise). ELSEIF(IPROC.EQ.-715)THEN * Check number of arguments. IF(NARG.NE.3.OR. - MODARG(1).NE.2.OR.MODARG(2).NE.2.OR. - ARGREF(3,1).GE.2)THEN PRINT *,' !!!!!! ROUCAL WARNING : Incorrect number'// - ' of arguments for RND_VAVILOV; no value returned' RETURN ENDIF * Reclaim argument space. CALL ALGREU(NINT(ARG(3)),MODARG(3),ARGREF(3,1)) * Obtain a value ARG(3)=RNDVVL(ARG(1),ARG(2)) MODARG(3)=2 *** Ionisation energy ELSEIF(IPROC.EQ.-716)THEN * Check number of arguments. IF(NARG.NE.3.OR. - MODARG(1).NE.2.OR.MODARG(2).NE.2.OR. - ARGREF(3,1).GE.2)THEN PRINT *,' !!!!!! ROUCAL WARNING : Incorrect number'// - ' of arguments for RND_IONISATION_ENERGY;'// - ' no value returned' RETURN ENDIF * Reclaim argument space. CALL ALGREU(NINT(ARG(3)),MODARG(3),ARGREF(3,1)) * Obtain a value CALL RNDHWF(ARG(1),ARG(2),ARG(3)) MODARG(3)=2 *** Unknown routine. ELSE PRINT *,' !!!!!! ROUCAL WARNING : Unknown procedure code'// - ' received; nothing done.' IFAIL=1 RETURN ENDIF *** Seems to have worked. CALL LOGSAV(.TRUE.,'OK',IFAIL1) IFAIL=0 END +DECK,FRNDFU. REAL FUNCTION FRNDFU(X) *----------------------------------------------------------------------- * FRNDFU - Called from FUGLXP when preparing for generating random * numbers according to a function PREPARE_RND_FUNCTION. * (Last chaned on 29/ 8/99.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. REAL X,VAR(MXVAR),RES(1),CUMRNF(200) INTEGER IENTRY,MODVAR(MXVAR),MODRES(1),IFAIL,NREXP,NVAR LOGICAL FUNSET COMMON /RNDFCM/ IENTRY,FUNSET,CUMRNF *** Assign the coordinate. VAR(1)=X MODVAR(1)=2 NVAR=1 *** Compute the function. NREXP=1 CALL AL2EXE(IENTRY,VAR,MODVAR,NVAR,RES,MODRES,NREXP,IFAIL) *** Return the result. IF(MODRES(1).NE.2)THEN PRINT *,' !!!!!! FRNDFU WARNING : Function evaluates to'// - ' a datatype other than Number; set to -1.' FRNDFU=-1 ELSE FRNDFU=RES(1) ENDIF END +DECK,CFMCTR. SUBROUTINE CFMCTR(X,Y,RHO,PHI,N) *----------------------------------------------------------------------- * CFMCTR - Routine transforming (x,y) to (rho,phi) via the conformal * map (x,y)=exp(rho,phi). This routine may in principle be * replaced by any conformal mapping routine. * (Last changed on 14/ 2/97.) *----------------------------------------------------------------------- implicit none REAL X(*),Y(*),RHO(*),PHI(*),RHOI,PHII INTEGER I,N COMPLEX Z *** Loop over the points. DO 10 I=1,N IF(X(I).EQ.0.AND.Y(I).EQ.0)THEN RHOI=-25.0 PHII=0.0 ELSE Z=LOG(CMPLX(X(I),Y(I))) RHOI=REAL(Z) PHII=AIMAG(Z) ENDIF RHO(I)=RHOI PHI(I)=PHII 10 CONTINUE END +DECK,CF2CTR. SUBROUTINE CF2CTR(X,Y,RHO,PHI,N) *----------------------------------------------------------------------- * CF2CTR - Routine transforming (x,y) to (rho,phi) via the conformal * map (x,y)=exp(rho,phi). This routine may in principle be * replaced by any conformal mapping routine. * (Last changed on 3/10/98.) *----------------------------------------------------------------------- implicit none DOUBLE PRECISION X(*),Y(*),RHO(*),PHI(*),RHOI,PHII INTEGER I,N *** Loop over the points. DO 10 I=1,N IF(X(I).EQ.0.AND.Y(I).EQ.0)THEN RHOI=-25.0 PHII=0.0 ELSE RHOI=0.5*LOG(X(I)**2+Y(I)**2) PHII=ATAN2(Y(I),X(I)) ENDIF RHO(I)=RHOI PHI(I)=PHII 10 CONTINUE END +DECK,CFMCTP. SUBROUTINE CFMCTP(X,Y,R,THETA,N) *----------------------------------------------------------------------- * CFMCTP - Routine transforming cartesian to polar coordinates. * (Last changed on 14/ 2/97.) *----------------------------------------------------------------------- implicit none +SEQ,CONSTANTS. REAL R(*),THETA(*),X(*),Y(*),RI,THETAI INTEGER N,I *** Loop over the points. DO 10 I=1,N IF(X(I).EQ.0.AND.Y(I).EQ.0)THEN RI=0 THETAI=0 ELSE RI=SQRT(X(I)**2+Y(I)**2) THETAI=180*ATAN2(Y(I),X(I))/PI ENDIF R(I)=RI THETA(I)=THETAI 10 CONTINUE END +DECK,CF2CTP. SUBROUTINE CF2CTP(X,Y,R,THETA,N) *----------------------------------------------------------------------- * CFM2TP - Routine transforming cartesian to polar coordinates. * (Last changed on 14/ 2/97.) *----------------------------------------------------------------------- implicit none +SEQ,CONSTANTS. INTEGER N,I DOUBLE PRECISION R(*),THETA(*),X(*),Y(*),RI,THETAI *** Loop over the points. DO 10 I=1,N IF(X(I).EQ.0.AND.Y(I).EQ.0)THEN RI=0 THETAI=0 ELSE RI=SQRT(X(I)**2+Y(I)**2) THETAI=180*ATAN2(Y(I),X(I))/PI ENDIF R(I)=RI THETA(I)=THETAI 10 CONTINUE END +DECK,CFMPTC. SUBROUTINE CFMPTC(R,THETA,X,Y,N) *----------------------------------------------------------------------- * CFMPTC - Routine transforming polar to cartesian coordinates. * (Last changed on 14/ 2/97.) *----------------------------------------------------------------------- implicit none +SEQ,CONSTANTS. REAL R(*),THETA(*),X(*),Y(*),XI,YI INTEGER N,I *** Loop over the points. DO 10 I=1,N XI=R(I)*COS(PI*THETA(I)/180.0) YI=R(I)*SIN(PI*THETA(I)/180.0) X(I)=XI Y(I)=YI 10 CONTINUE END +DECK,CFMPTR. SUBROUTINE CFMPTR(R,THETA,RHO,PHI,N,IFAIL) *----------------------------------------------------------------------- * CFMPTR - Routine transforming (r,theta) to (rho,phi) via the map * (r,theta)=(exp(rho),180*phi/pi). It makes entering cells * in polar coordinates somewhat easier. * (Last changed on 14/ 2/97.) *----------------------------------------------------------------------- implicit none +SEQ,CONSTANTS. REAL R(*),THETA(*),RHO(*),PHI(*),RHOI,PHII INTEGER N,IFAIL,I *** Preset error flag. IFAIL=0 *** Loop over the points. DO 10 I=1,N IF(R(I).EQ.0)THEN RHOI=-25.0 ELSEIF(R(I).GT.0.0)THEN RHOI=LOG(R(I)) ELSE IFAIL=1 RHO(I)=1 RETURN ENDIF PHII=PI*THETA(I)/180.0 RHO(I)=RHOI PHI(I)=PHII 10 CONTINUE END +DECK,CFMRTC. SUBROUTINE CFMRTC(RHO,PHI,X,Y,N) *----------------------------------------------------------------------- * CFMRTC - Routine transforming (rho,phi) to (x,y) via the conformal * map (x,y)=exp(rho,phi). This routine may in principle be * replaced by any conformal mapping routine. * (Last changed on 14/ 2/97.) *----------------------------------------------------------------------- implicit none REAL X(*),Y(*),RHO(*),PHI(*),XI,YI INTEGER N,I COMPLEX Z *** Loop over the points. DO 10 I=1,N Z=EXP(CMPLX(RHO(I),PHI(I))) XI=REAL(Z) YI=AIMAG(Z) X(I)=XI Y(I)=YI 10 CONTINUE END +DECK,CFMRTP. SUBROUTINE CFMRTP(RHO,PHI,R,THETA,N) *----------------------------------------------------------------------- * CFMRTP - Routine transforming (r,theta) to (rho,phi) via the map * (r,theta)=(exp(rho),180*phi/pi). * (Last changed on 14/ 2/97.) *----------------------------------------------------------------------- implicit none +SEQ,CONSTANTS. REAL R(*),THETA(*),RHO(*),PHI(*),RI,THETAI INTEGER N,I *** Loop over the points. DO 10 I=1,N RI=EXP(RHO(I)) THETAI=180.0*PHI(I)/PI R(I)=RI THETA(I)=THETAI 10 CONTINUE END +DECK,CF2RTC. SUBROUTINE CF2RTC(RHO,PHI,X,Y,N) *----------------------------------------------------------------------- * CF2RTC - Routine transforming (rho,phi) to (x,y) via the conformal * map (x,y)=exp(rho,phi). This routine may in principle be * replaced by any conformal mapping routine. * (Last changed on 14/ 2/97.) *----------------------------------------------------------------------- implicit none DOUBLE PRECISION X(*),Y(*),RHO(*),PHI(*),XI,YI INTEGER I,N *** Loop over the points. DO 10 I=1,N XI=EXP(RHO(I))*COS(PHI(I)) YI=EXP(RHO(I))*SIN(PHI(I)) X(I)=XI Y(I)=YI 10 CONTINUE END +DECK,CF2RTP. SUBROUTINE CF2RTP(RHO,PHI,R,THETA,N) *----------------------------------------------------------------------- * CF2RTP - Routine transforming (r,theta) to (rho,phi) via the map * (r,theta)=(exp(rho),180*phi/pi). *----------------------------------------------------------------------- implicit none +SEQ,CONSTANTS. DOUBLE PRECISION R(*),THETA(*),RHO(*),PHI(*),RI,THETAI INTEGER I,N DO 10 I=1,N RI=EXP(RHO(I)) THETAI=180.0*PHI(I)/PI R(I)=RI THETA(I)=THETAI 10 CONTINUE END +DECK,CLIP. SUBROUTINE CLIP(X0,Y0,X1,Y1,XLL,YLL,XUR,YUR,IFAIL) *----------------------------------------------------------------------- * CLIP - Routine clipping the line (X0,Y0) to (X1,Y1) to the size of * the box formed by (XLL,YLL) (XUR,YUR). * VARIABLES : (X0,Y0) : Begin point of line. * (X1,Y1) : End point of line. * (XLL,YLL) : Lower left hand corner of the box. * (XUR,YUR) : Upper right hand corner of the box. *----------------------------------------------------------------------- *** Return on IFAIL=0 if no changes have to be made. IFAIL=0 IF(XLL.LE.X0.AND.X0.LE.XUR.AND.XLL.LE.X1.AND.X1.LE.XUR.AND. - YLL.LE.Y0.AND.Y0.LE.YUR.AND.YLL.LE.Y1.AND.Y1.LE.YUR)RETURN *** The next few returns are on IFAIL=1. IFAIL=1 *** Return with IFAIL=1 if X0 and X1 are out of range. IF((X0.LT.XLL.AND.X1.LT.XLL).OR.(X0.GT.XUR.AND.X1.GT.XUR))RETURN IF(X0.NE.X1)THEN * Adjust X0. IF(X0.LT.XLL)THEN Y0=Y0+((Y1-Y0)/(X1-X0))*(XLL-X0) X0=XLL ENDIF IF(X0.GT.XUR)THEN Y0=Y0+((Y1-Y0)/(X1-X0))*(XUR-X0) X0=XUR ENDIF * Adjust X1. IF(X1.LT.XLL)THEN Y1=Y1+((Y1-Y0)/(X1-X0))*(XLL-X1) X1=XLL ENDIF IF(X1.GT.XUR)THEN Y1=Y1+((Y1-Y0)/(X1-X0))*(XUR-X1) X1=XUR ENDIF ENDIF *** Return with an IFAIL=1 if Y0 and Y1 are out of range. IF((Y0.LT.YLL.AND.Y1.LT.YLL).OR.(Y0.GT.YUR.AND.Y1.GT.YUR))RETURN IF(Y0.NE.Y1)THEN * Adjust Y0. IF(Y0.LT.YLL)THEN X0=X0+((X1-X0)/(Y1-Y0))*(YLL-Y0) Y0=YLL ENDIF IF(Y0.GT.YUR)THEN X0=X0+((X1-X0)/(Y1-Y0))*(YUR-Y0) Y0=YUR ENDIF * Adjust y1. IF(Y1.LT.YLL)THEN X1=X1+((X1-X0)/(Y1-Y0))*(YLL-Y1) Y1=YLL ENDIF IF(Y1.GT.YUR)THEN X1=X1+((X1-X0)/(Y1-Y0))*(YUR-Y1) Y1=YUR ENDIF ENDIF *** If begin and end point coincide, return with IFAIL=1. IF(X0.EQ.X1.AND.Y0.EQ.Y1)RETURN *** All is OK, therefore IFAIL=0. IFAIL=0 END +DECK,CLIP2D. SUBROUTINE CLIP2D(X0,Y0,X1,Y1,XLL,YLL,XUR,YUR,IFAIL) *----------------------------------------------------------------------- * CLIP2D - Routine clipping the line (X0,Y0) (X1,Y1) to the size of * the box formed by (XLL,YLL) (XUR,YUR). * VARIABLES : (X0,Y0) : Begin point of line. * (X1,Y1) : End point of line. * (XLL,ULL) : Lower left hand corner of the box. * (XUR,YUR) : Upper right hand corner of the box. * (Last changed on 5/ 2/97.) *----------------------------------------------------------------------- implicit none DOUBLE PRECISION X0,Y0,X1,Y1,XLL,YLL,XUR,YUR INTEGER IFAIL *** Return on IFAIL=0 if no changes have to be made. IFAIL=0 IF(XLL.LE.X0.AND.X0.LE.XUR.AND.XLL.LE.X1.AND.X1.LE.XUR.AND. - YLL.LE.Y0.AND.Y0.LE.YUR.AND.YLL.LE.Y1.AND.Y1.LE.YUR)RETURN *** The next few returns are on IFAIL=1. IFAIL=1 *** Return with IFAIL=1 if X0 and X1 are out of range. IF((X0.LT.XLL.AND.X1.LT.XLL).OR.(X0.GT.XUR.AND.X1.GT.XUR))RETURN IF(X0.NE.X1)THEN * Adjust X0. IF(X0.LT.XLL)THEN Y0=Y0+((Y1-Y0)/(X1-X0))*(XLL-X0) X0=XLL ENDIF IF(X0.GT.XUR)THEN Y0=Y0+((Y1-Y0)/(X1-X0))*(XUR-X0) X0=XUR ENDIF * Adjust X1. IF(X1.LT.XLL)THEN Y1=Y1+((Y1-Y0)/(X1-X0))*(XLL-X1) X1=XLL ENDIF IF(X1.GT.XUR)THEN Y1=Y1+((Y1-Y0)/(X1-X0))*(XUR-X1) X1=XUR ENDIF ENDIF *** Return with an IFAIL=1 if Y0 and Y1 are out of range. IF((Y0.LT.YLL.AND.Y1.LT.YLL).OR.(Y0.GT.YUR.AND.Y1.GT.YUR))RETURN IF(Y0.NE.Y1)THEN * Adjust y0. IF(Y0.LT.YLL)THEN X0=X0+((X1-X0)/(Y1-Y0))*(YLL-Y0) Y0=YLL ENDIF IF(Y0.GT.YUR)THEN X0=X0+((X1-X0)/(Y1-Y0))*(YUR-Y0) Y0=YUR ENDIF * Adjust y1. IF(Y1.LT.YLL)THEN X1=X1+((X1-X0)/(Y1-Y0))*(YLL-Y1) Y1=YLL ENDIF IF(Y1.GT.YUR)THEN X1=X1+((X1-X0)/(Y1-Y0))*(YUR-Y1) Y1=YUR ENDIF ENDIF *** If begin and end point coincide, return with IFAIL=1. IF(X0.EQ.X1.AND.Y0.EQ.Y1)RETURN *** All is OK, therefore IFAIL=0. IFAIL=0 END +DECK,CLIP3D. SUBROUTINE CLIP3D(X0,Y0,Z0,X1,Y1,Z1, - XLL,YLL,ZLL,XUR,YUR,ZUR,IFAIL) *----------------------------------------------------------------------- * CLIP3D - Routine clipping the line (X0,Y0,Z0) to (X1,Y1,Z1) to the * size of the box formed by (XLL,YLL,ZLL) (XUR,YUR,ZUR). * VARIABLES : (X0,Y0,Z0) : Begin point of line. * (X1,Y1,Z1) : End point of line. * (X/Y/ZLL) : Lower left hand corner of the box. * (X/Y/ZUR) : Upper right hand corner of the box. * (Last changed on 6/12/97.) *----------------------------------------------------------------------- implicit none DOUBLE PRECISION X0,Y0,Z0,X1,Y1,Z1,XLL,YLL,ZLL,XUR,YUR,ZUR INTEGER IFAIL *** Return on IFAIL=0 if no changes have to be made. IFAIL=0 IF(XLL.LE.X0.AND.X0.LE.XUR.AND.XLL.LE.X1.AND.X1.LE.XUR.AND. - YLL.LE.Y0.AND.Y0.LE.YUR.AND.YLL.LE.Y1.AND.Y1.LE.YUR.AND. - ZLL.LE.Z0.AND.Z0.LE.ZUR.AND.ZLL.LE.Z1.AND.Z1.LE.ZUR)RETURN *** The next few returns are on IFAIL=1. IFAIL=1 *** Return with IFAIL=1 if X0 and X1 are out of range. IF((X0.LT.XLL.AND.X1.LT.XLL).OR.(X0.GT.XUR.AND.X1.GT.XUR))RETURN IF(X0.NE.X1)THEN * Adjust X0. IF(X0.LT.XLL)THEN Y0=Y0+((Y1-Y0)/(X1-X0))*(XLL-X0) Z0=Z0+((Z1-Z0)/(X1-X0))*(XLL-X0) X0=XLL ENDIF IF(X0.GT.XUR)THEN Y0=Y0+((Y1-Y0)/(X1-X0))*(XUR-X0) Z0=Z0+((Z1-Z0)/(X1-X0))*(XUR-X0) X0=XUR ENDIF * Adjust X1. IF(X1.LT.XLL)THEN Y1=Y1+((Y1-Y0)/(X1-X0))*(XLL-X1) Z1=Z1+((Z1-Z0)/(X1-X0))*(XLL-X1) X1=XLL ENDIF IF(X1.GT.XUR)THEN Y1=Y1+((Y1-Y0)/(X1-X0))*(XUR-X1) Z1=Z1+((Z1-Z0)/(X1-X0))*(XUR-X1) X1=XUR ENDIF ENDIF *** Return with an IFAIL=1 if Y0 and Y1 are out of range. IF((Y0.LT.YLL.AND.Y1.LT.YLL).OR.(Y0.GT.YUR.AND.Y1.GT.YUR))RETURN IF(Y0.NE.Y1)THEN * Adjust Y0. IF(Y0.LT.YLL)THEN X0=X0+((X1-X0)/(Y1-Y0))*(YLL-Y0) Z0=Z0+((Z1-Z0)/(Y1-Y0))*(YLL-Y0) Y0=YLL ENDIF IF(Y0.GT.YUR)THEN X0=X0+((X1-X0)/(Y1-Y0))*(YUR-Y0) Z0=Z0+((Z1-Z0)/(Y1-Y0))*(YUR-Y0) Y0=YUR ENDIF * Adjust Y1. IF(Y1.LT.YLL)THEN X1=X1+((X1-X0)/(Y1-Y0))*(YLL-Y1) Z1=Z1+((Z1-Z0)/(Y1-Y0))*(YLL-Y1) Y1=YLL ENDIF IF(Y1.GT.YUR)THEN X1=X1+((X1-X0)/(Y1-Y0))*(YUR-Y1) Z1=Z1+((Z1-Z0)/(Y1-Y0))*(YUR-Y1) Y1=YUR ENDIF ENDIF *** Return with an IFAIL=1 if Z0 and Z1 are out of range. IF((Z0.LT.ZLL.AND.Z1.LT.ZLL).OR.(Z0.GT.ZUR.AND.Z1.GT.ZUR))RETURN IF(Z0.NE.Z1)THEN * Adjust Z0. IF(Z0.LT.ZLL)THEN X0=X0+((X1-X0)/(Z1-Z0))*(ZLL-Z0) Y0=Y0+((Y1-Y0)/(Z1-Z0))*(ZLL-Z0) Z0=ZLL ENDIF IF(Z0.GT.ZUR)THEN X0=X0+((X1-X0)/(Z1-Z0))*(ZUR-Z0) Y0=Y0+((Y1-Y0)/(Z1-Z0))*(ZUR-Z0) Z0=ZUR ENDIF * Adjust Z1. IF(Z1.LT.ZLL)THEN X1=X1+((X1-X0)/(Z1-Z0))*(ZLL-Z1) Y1=Y1+((Y1-Y0)/(Z1-Z0))*(ZLL-Z1) Z1=ZLL ENDIF IF(Z1.GT.ZUR)THEN X1=X1+((X1-X0)/(Z1-Z0))*(ZUR-Z1) Y1=Y1+((Y1-Y0)/(Z1-Z0))*(ZUR-Z1) Z1=ZUR ENDIF ENDIF *** If begin and end point coincide, return with IFAIL=1. IF(X0.EQ.X1.AND.Y0.EQ.Y1.AND.Z0.EQ.Z1)RETURN *** All is OK, therefore IFAIL=0. IFAIL=0 END +DECK,CLIP3. SUBROUTINE CLIP3(X0,Y0,Z0,X1,Y1,Z1,XLL,YLL,ZLL,XUR,YUR,ZUR,IFAIL) *----------------------------------------------------------------------- * CLIP3 - Routine clipping the line (X0,Y0,Z0) to (X1,Y1,Z1) to the * size of the box formed by (XLL,YLL,ZLL) (XUR,YUR,ZUR). * VARIABLES : (X0,Y0,Z0) : Begin point of line. * (X1,Y1,Z1) : End point of line. * (X/Y/ZLL) : Lower left hand corner of the box. * (X/Y/ZUR) : Upper right hand corner of the box. * (Last changed on 26/ 8/98.) *----------------------------------------------------------------------- implicit none REAL X0,Y0,Z0,X1,Y1,Z1,XLL,YLL,ZLL,XUR,YUR,ZUR INTEGER IFAIL *** Return on IFAIL=0 if no changes have to be made. IFAIL=0 IF(XLL.LE.X0.AND.X0.LE.XUR.AND.XLL.LE.X1.AND.X1.LE.XUR.AND. - YLL.LE.Y0.AND.Y0.LE.YUR.AND.YLL.LE.Y1.AND.Y1.LE.YUR.AND. - ZLL.LE.Z0.AND.Z0.LE.ZUR.AND.ZLL.LE.Z1.AND.Z1.LE.ZUR)RETURN *** The next few returns are on IFAIL=1. IFAIL=1 *** Return with IFAIL=1 if X0 and X1 are out of range. IF((X0.LT.XLL.AND.X1.LT.XLL).OR.(X0.GT.XUR.AND.X1.GT.XUR))RETURN IF(X0.NE.X1)THEN * Adjust X0. IF(X0.LT.XLL)THEN Y0=Y0+((Y1-Y0)/(X1-X0))*(XLL-X0) Z0=Z0+((Z1-Z0)/(X1-X0))*(XLL-X0) X0=XLL ENDIF IF(X0.GT.XUR)THEN Y0=Y0+((Y1-Y0)/(X1-X0))*(XUR-X0) Z0=Z0+((Z1-Z0)/(X1-X0))*(XUR-X0) X0=XUR ENDIF * Adjust X1. IF(X1.LT.XLL)THEN Y1=Y1+((Y1-Y0)/(X1-X0))*(XLL-X1) Z1=Z1+((Z1-Z0)/(X1-X0))*(XLL-X1) X1=XLL ENDIF IF(X1.GT.XUR)THEN Y1=Y1+((Y1-Y0)/(X1-X0))*(XUR-X1) Z1=Z1+((Z1-Z0)/(X1-X0))*(XUR-X1) X1=XUR ENDIF ENDIF *** Return with an IFAIL=1 if Y0 and Y1 are out of range. IF((Y0.LT.YLL.AND.Y1.LT.YLL).OR.(Y0.GT.YUR.AND.Y1.GT.YUR))RETURN IF(Y0.NE.Y1)THEN * Adjust Y0. IF(Y0.LT.YLL)THEN X0=X0+((X1-X0)/(Y1-Y0))*(YLL-Y0) Z0=Z0+((Z1-Z0)/(Y1-Y0))*(YLL-Y0) Y0=YLL ENDIF IF(Y0.GT.YUR)THEN X0=X0+((X1-X0)/(Y1-Y0))*(YUR-Y0) Z0=Z0+((Z1-Z0)/(Y1-Y0))*(YUR-Y0) Y0=YUR ENDIF * Adjust Y1. IF(Y1.LT.YLL)THEN X1=X1+((X1-X0)/(Y1-Y0))*(YLL-Y1) Z1=Z1+((Z1-Z0)/(Y1-Y0))*(YLL-Y1) Y1=YLL ENDIF IF(Y1.GT.YUR)THEN X1=X1+((X1-X0)/(Y1-Y0))*(YUR-Y1) Z1=Z1+((Z1-Z0)/(Y1-Y0))*(YUR-Y1) Y1=YUR ENDIF ENDIF *** Return with an IFAIL=1 if Z0 and Z1 are out of range. IF((Z0.LT.ZLL.AND.Z1.LT.ZLL).OR.(Z0.GT.ZUR.AND.Z1.GT.ZUR))RETURN IF(Z0.NE.Z1)THEN * Adjust Z0. IF(Z0.LT.ZLL)THEN X0=X0+((X1-X0)/(Z1-Z0))*(ZLL-Z0) Y0=Y0+((Y1-Y0)/(Z1-Z0))*(ZLL-Z0) Z0=ZLL ENDIF IF(Z0.GT.ZUR)THEN X0=X0+((X1-X0)/(Z1-Z0))*(ZUR-Z0) Y0=Y0+((Y1-Y0)/(Z1-Z0))*(ZUR-Z0) Z0=ZUR ENDIF * Adjust Z1. IF(Z1.LT.ZLL)THEN X1=X1+((X1-X0)/(Z1-Z0))*(ZLL-Z1) Y1=Y1+((Y1-Y0)/(Z1-Z0))*(ZLL-Z1) Z1=ZLL ENDIF IF(Z1.GT.ZUR)THEN X1=X1+((X1-X0)/(Z1-Z0))*(ZUR-Z1) Y1=Y1+((Y1-Y0)/(Z1-Z0))*(ZUR-Z1) Z1=ZUR ENDIF ENDIF *** If begin and end point coincide, return with IFAIL=1. IF(X0.EQ.X1.AND.Y0.EQ.Y1.AND.Z0.EQ.Z1)RETURN *** All is OK, therefore IFAIL=0. IFAIL=0 END +DECK,DATTIMO,IF=-VAX,IF=-BOINC. SUBROUTINE DATTIM(DAT,TIM) *----------------------------------------------------------------------- * DATTIM - Interface to DATIMH for non-Vax computers. * (Last changed on 30/ 8/98.) *----------------------------------------------------------------------- implicit none CHARACTER*8 DAT,TIM CALL DATIMH(DAT,TIM) END +DECK,DATTIMB,IF=BOINC. SUBROUTINE DATTIM(DAT,TIM) *----------------------------------------------------------------------- * DATTIM - Interface to DATIMH for BOINC use (uniform timing) * (Last changed on 27/ 1/06.) *----------------------------------------------------------------------- implicit none CHARACTER*8 DAT,TIM DAT=' / / ' TIM=' : : ' END +DECK,DATTIMV,IF=VAX. SUBROUTINE DATTIM(DAT,TIM) *----------------------------------------------------------------------- * DATTIM - Simulates DATIMH (Z007) on a VAX, the standard DATE * routine on a Vax returns 9 characters. * (Last changed on 30/ 8/98.) *----------------------------------------------------------------------- implicit none CHARACTER*8 DAT,TIM CHARACTER*9 VAXDAT *** Call the date and time functions. CALL TIME(TIM) CALL DATE(VAXDAT) *** Convert the named month to a sequence number. DAT(1:3)=VAXDAT(1:2)//'/' DAT(4:5)='??' IF(VAXDAT(4:6).EQ.'JAN')DAT(4:5)='01' IF(VAXDAT(4:6).EQ.'FEB')DAT(4:5)='02' IF(VAXDAT(4:6).EQ.'MAR')DAT(4:5)='03' IF(VAXDAT(4:6).EQ.'APR')DAT(4:5)='04' IF(VAXDAT(4:6).EQ.'MAY')DAT(4:5)='05' IF(VAXDAT(4:6).EQ.'JUN')DAT(4:5)='06' IF(VAXDAT(4:6).EQ.'JUL')DAT(4:5)='07' IF(VAXDAT(4:6).EQ.'AUG')DAT(4:5)='08' IF(VAXDAT(4:6).EQ.'SEP')DAT(4:5)='09' IF(VAXDAT(4:6).EQ.'OCT')DAT(4:5)='10' IF(VAXDAT(4:6).EQ.'NOV')DAT(4:5)='11' IF(VAXDAT(4:6).EQ.'DEC')DAT(4:5)='12' DAT(6:8)='/'//VAXDAT(8:9) END +DECK,EPSSET. SUBROUTINE EPSSET(OPT,EPSX,EPSY,EPSZ) *----------------------------------------------------------------------- * EPSSET - Sets the tolerances for point comparisons. * (Last changed on 30/ 8/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PARAMETERS. +SEQ,PRINTPLOT. CHARACTER*(*) OPT DOUBLE PRECISION EPSX,EPSY,EPSZ *** Tracing. IF(LIDENT)PRINT *,' /// ROUTINE EPSSET ///' *** Set new tolerances. IF(OPT.EQ.'SET')THEN IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ EPSSET DEBUG :'', - '' Setting tolerances: '',3E10.3)') EPSX,EPSY,EPSZ EPSGX=EPSX EPSGY=EPSY EPSGZ=EPSZ LEPSG=.TRUE. *** Reset the tolerances. ELSEIF(OPT.EQ.'RESET')THEN IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ EPSSET DEBUG :'', - '' Resetting the tolerances.'')') LEPSG=.FALSE. *** Other options are not known. ELSE PRINT *,' !!!!!! EPSSET WARNING : Received the unknown'// - ' option "',OPT,'" ; ignored.' ENDIF END +DECK,EXPFIT. SUBROUTINE EXPFIT(X,Y,EY,N,LPRINT,AA,EA,NA,IFAIL) *----------------------------------------------------------------------- * EXPFIT - Fits an exponential of a polynomial. * (Last changed on 12/ 2/98.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. INTEGER NNA,IWORK(MXFPAR) COMMON /PFDAT/ NNA REAL X(*),Y(*),EY(*) DOUBLE PRECISION XX(MXLIST),YY(MXLIST),EEY(MXLIST), - AA(*),EA(*),CHI2,D(MXFPAR,MXFPAR+2),AUX,YSUM INTEGER N,NA,IFAIL,NDATA LOGICAL LPRINT EXTERNAL EXPFUN *** Preset the error flag. IFAIL=1 *** Debugging and identification output. IF(LIDENT)PRINT *,' /// ROUTINE EXPFIT ///' *** Check dimensions. IF(NA.GT.MXFPAR.OR.N.GT.MXLIST)THEN PRINT *,' !!!!!! EXPFIT WARNING : Dimensions of the'// - ' problem exceed compilation parameters; no fit.' RETURN ENDIF *** Copy the vectors. YSUM=0 NDATA=0 DO 100 I=1,N XX(I)=DBLE(X(I)) YY(I)=DBLE(Y(I)) IF(YY(I).GT.0)NDATA=NDATA+1 YSUM=YSUM+ABS(YY(I)) EEY(I)=DBLE(EY(I)) 100 CONTINUE *** See whether there are enough valid points. IF(NDATA.LT.NA)THEN PRINT *,' !!!!!! EXPFIT WARNING : The problem is under-'// - 'determined (after eliminating y<=0 points); no fit.' RETURN ENDIF *** Estimate fitting results, first fill matrix. DO 10 I=0,2*(NA-1) IF(I.EQ.0)THEN AUX=NDATA ELSE AUX=0 DO 20 J=1,N IF(YY(J).GT.0)AUX=AUX+XX(J)**I 20 CONTINUE ENDIF DO 30 J=1,NA K=I+2-J IF(K.LT.1.OR.K.GT.NA)GOTO 30 D(J,K)=AUX 30 CONTINUE 10 CONTINUE * Left hand side. DO 40 I=0,NA-1 AUX=0 DO 50 J=1,N IF(YY(J).LE.0)GOTO 50 IF(I.EQ.0)THEN AUX=AUX+LOG(YY(J)) ELSE AUX=AUX+LOG(YY(J))*XX(J)**I ENDIF 50 CONTINUE D(I+1,MXFPAR+1)=AUX 40 CONTINUE * Now solve the equation. CALL DEQN(NA,D,MXFPAR,IWORK,IFAIL1,1,D(1,MXFPAR+1)) * Check error condition. IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! EXPFIT WARNING : Failure to obtain'// - ' a first estimate of the solution; not solved.' RETURN ENDIF * Copy the solution. DO 60 I=1,NA AA(I)=D(I,MXFPAR+1) 60 CONTINUE * Debugging output. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ EXPFIT DEBUG : Guess'', - '' before fit: a_i='',3E15.8,(/26X,5E15.8:))') - (AA(I),I=1,NA) *** Now carry out the fit. NNA=NA CALL LSQFIT(EXPFUN,AA,EA,NA,XX,YY,EEY,N,200,0.01*YSUM/N, - CHI2,1.0D-3,LPRINT,IFAIL) END +DECK,EXPFUN. SUBROUTINE EXPFUN(X,A,F) *----------------------------------------------------------------------- * EXPFUN - Auxiliary function for fitting an exponential polynomial. * (Last changed on 9/ 5/96.) *----------------------------------------------------------------------- DOUBLE PRECISION A(*),X,F INTEGER NNA COMMON /PFDAT/ NNA *** Sum the polynomial. F=0 DO 10 I=NNA,1,-1 F=F*X+A(I) 10 CONTINUE *** Take an exponential. IF(F.LT.-50)THEN F=0 ELSE F=EXP(MIN(30.0D0,F)) ENDIF END +DECK,PYAFIT. SUBROUTINE PYAFIT(X,Y,EY,N,LPRINT,LSQRT,LSCALE,LAUTO,AA,EA,IFAIL) *----------------------------------------------------------------------- * PYAFIT - Fits a Polya distribution to a polynomial or histogram. * (Last changed on 3/ 6/08.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. REAL X(*),Y(*),EY(*),XPL(200),YPL(200) DOUBLE PRECISION XXX,YYY,XX(MXLIST),YY(MXLIST),EEY(MXLIST), - SFACT,SSIG,AA(*),EA(*),CHI2,D(2,4),YTOT,YSUM,YINT, - XFIRST,XLAST,TOL INTEGER N,IFAIL,IFAIL1,NDATA,IWORK(2),I,NFIRST,NLAST,NSTART LOGICAL LPRINT,LSCALE,LAUTO,XSET,LSQRT EXTERNAL PYAFUN *** Preset the error flag. IFAIL=1 *** Debugging and identification output. IF(LIDENT)PRINT *,' /// ROUTINE PYAFIT ///' *** Check dimensions. IF(N.GT.MXLIST)THEN PRINT *,' !!!!!! PYAFIT WARNING : Dimensions of the'// - ' problem exceed compilation parameters; no fit.' RETURN ENDIF *** Copy the vectors, prepare matrix etc - first initialise. XSET=.FALSE. NFIRST=0 NLAST=0 DO 20 I=1,N * Vector copy. XX(I)=DBLE(X(I)) YY(I)=DBLE(Y(I)) EEY(I)=DBLE(EY(I)) * Find smallest and largest x. IF(Y(I).GT.0)THEN IF(XSET)THEN IF(XX(I).LT.XFIRST)XFIRST=XX(I) IF(XX(I).GT.XLAST)XLAST=XX(I) ELSE XFIRST=XX(I) XLAST=XX(I) XSET=.TRUE. ENDIF * Keep track of starting point IF(NFIRST.EQ.0)NFIRST=I * Keep track of end point NLAST=I ENDIF 20 CONTINUE *** Exponential fit matrix: initialise D(1,1)=0 D(1,2)=0 D(1,3)=0 D(2,1)=0 D(2,2)=0 D(2,3)=0 YSUM=0 YINT=0 YTOT=0 SFACT=0 SSIG=0 NDATA=0 NSTART=NFIRST+(NLAST-NFIRST)/3 * Sum terms. DO 30 I=1,N IF(EY(I).GT.0.AND.Y(I).GT.0.AND.I.GE.NSTART)THEN NDATA=NDATA+1 D(1,1)=D(1,1)+ (Y(I)/EY(I))**2 D(1,2)=D(1,2)+X(I) *(Y(I)/EY(I))**2 D(2,1)=D(2,1)+X(I) *(Y(I)/EY(I))**2 D(2,2)=D(2,2)+X(I)**2 *(Y(I)/EY(I))**2 D(1,3)=D(1,3)+LOG(Y(I)) *(Y(I)/EY(I))**2 D(2,3)=D(2,3)+LOG(Y(I))*X(I)*(Y(I)/EY(I))**2 ENDIF * Normalisation for fixed scale fits. IF(I.GE.NSTART.AND..NOT.LSCALE)THEN SFACT=SFACT+EY(I)*Y(I)/EXP(-AA(3)-AA(4)*X(I)) SSIG=SSIG+EY(I) ENDIF * Integral. YTOT=YTOT+Y(I) IF(I.EQ.1)THEN YINT=0 ELSE YSUM=YSUM+0.5*(Y(I)+Y(I-1))*ABS(X(I)-X(I-1)) IF(I.GT.NSTART)YINT=YINT+0.5*(Y(I)+Y(I-1))* - ABS(X(I)-X(I-1)) ENDIF 30 CONTINUE *** See whether there are enough valid points. IF(NDATA.LT.4.OR. - (.NOT.LSCALE.AND.SSIG.LE.0).OR. - YSUM.LE.0.OR.YINT.LE.0.OR. - XLAST.LE.XFIRST)THEN PRINT *,' !!!!!! PYAFIT WARNING : The problem is under-'// - 'determined (after eliminating y<=0 points); no fit.' RETURN ENDIF * Now solve the equation. CALL DEQN(2,D,2,IWORK,IFAIL1,1,D(1,3)) * Check error condition. IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! PYAFIT WARNING : Failure to obtain'// - ' a first estimate of the solution; not solved.' RETURN ENDIF * Copy the solution. IF(LAUTO)THEN IF(D(2,3).EQ.0)THEN PRINT *,' !!!!!! PYAFIT WARNING : Estimated scale'// - ' is zero; no fit.' RETURN ENDIF AA(2)=0.5 IF(LSCALE)THEN AA(1)=EXP(D(1,3)+D(2,3)*XFIRST+ - 0.01*ABS(D(2,3)*(XLAST-XFIRST)))/ - ABS(D(2,3)) AA(3)=D(2,3)*XFIRST+ - 0.01*ABS(D(2,3)*(XLAST-XFIRST)) AA(4)=-D(2,3) ELSE AA(1)=SFACT/SSIG ENDIF ENDIF * Debugging output. IF(LDEBUG)THEN WRITE(LUNOUT,'('' ++++++ PYAFIT DEBUG : Guess'', - '' before fit: a_i=''/26X,4E15.8)') (AA(I),I=1,4) * Switch to logarithmic scale. CALL GRAOPT('LIN-X, LOG-Y') * Make the plot. CALL GRGRPH(X,Y,N,'x','y','Pre-fit situation') * Prepare the plot vector. DO 10 I=1,200 XPL(I)=X(1)+REAL(I-1)*(X(N)-X(1))/199.0 XXX=XPL(I) CALL PYAFUN(XXX,AA,YYY) YPL(I)=YYY 10 CONTINUE * Set the attributes. CALL GRATTS('FUNCTION-2','POLYLINE') * Slot the line itself. CALL GRLINE(200,XPL,YPL) * Close the plot. CALL GRNEXT * Switch to normal mode. CALL GRAOPT('LIN-X, LIN-Y') ENDIF *** Now carry out the fit. IF(LSQRT)THEN TOL=3 ELSE TOL=0.01*YTOT/N ENDIF IF(LSCALE)THEN CALL LSQFIT(PYAFUN,AA,EA,4,XX,YY,EEY,N,200,TOL, - CHI2,1.0D-3,LPRINT,IFAIL) ELSE CALL LSQFIT(PYAFUN,AA,EA,2,XX,YY,EEY,N,200,TOL, - CHI2,1.0D-3,LPRINT,IFAIL) EA(3)=0 EA(4)=0 ENDIF END +DECK,PYAFUN. SUBROUTINE PYAFUN(X,A,F) *----------------------------------------------------------------------- * PYAFUN - Auxiliary function for fitting a Polya distribution. * (Last changed on 19/ 8/96.) *----------------------------------------------------------------------- DOUBLE PRECISION A(*),X,F,DGAMMF EXTERNAL DGAMMF *** Compute Polya function. IF(A(3)+A(4)*X.LE.0)THEN F=0 ELSEIF(A(2).LE.-1)THEN F=0 ELSEIF(ABS((A(2)+1)*(A(3)+A(4)*X)).GT.30)THEN F=0 ELSE F=A(1)*A(4)*(A(2)+1)**(A(2)+1)/DGAMMF(A(2)+1)* - (A(3)+A(4)*X)**A(2)* - EXP(-(A(2)+1)*(A(3)+A(4)*X)) ENDIF END +DECK,FUGLXP. SUBROUTINE FUGLXP (FUNC,XFCUM,X2LOW,X2HIGH,IFAIL) *----------------------------------------------------------------------- * FUGLXP - Prepares the user function FUNC for FUGLUX. * Inspired by and mostly copied from FUNPRE and FUNRAN * except that * 1. FUNLUX uses RANLUX underneath, * 2. FUNLXP expands the first and last bins to cater for * functions with long tails on left and/or right, * 3. FUNLXP calls FUNPCT to do the actual finding of * percentiles. * 4. both FUNLXP and FUNPCT use RADAPT for Gaussian * integration. * Origin: V152, Fred James, Sept 1994 *----------------------------------------------------------------------- implicit none +SEQ,PRINTPLOT. EXTERNAL FUNC INTEGER IFAIL,IERR REAL XFCUM(200),X2LOW,X2HIGH,XLOW,XHIGH,XRANGE,X2,X3,RTEPS,TFTOT, - TFTOT1,TFTOT2,UNCERT,FUNC PARAMETER (RTEPS=0.0002) *** Find range where function is non-zero. CALL FUGLZ(FUNC,X2LOW,X2HIGH,XLOW,XHIGH) XRANGE = XHIGH-XLOW IF(XRANGE .LE. 0)THEN PRINT *,' ###### FUGLXP ERROR : Non-zero range of the'// - ' function has non-positive length; function not'// - ' prepared for random number generation.' IFAIL=1 RETURN ENDIF *** Integrate the function. CALL RADAPT(FUNC,XLOW,XHIGH,1,RTEPS,0.,TFTOT ,UNCERT) IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ FUGLXP DEBUG : Integral'', - '' from '',E12.5,'' to '',E12.5,'' is '',E12.5)') - XLOW,XHIGH,TFTOT *** Compute percentiles. CALL FUGPCT(FUNC,XLOW,XHIGH,XFCUM,1,99,TFTOT,IERR) IF (IERR .GT. 0) GOTO 900 X2 = XFCUM(3) CALL RADAPT(FUNC,XLOW,X2,1,RTEPS,0.,TFTOT1 ,UNCERT) CALL FUGPCT(FUNC,XLOW,X2 ,XFCUM,101,49,TFTOT1,IERR) IF (IERR .GT. 0) GOTO 900 X3 = XFCUM(98) CALL RADAPT(FUNC,X3,XHIGH,1,RTEPS,0.,TFTOT2 ,UNCERT) CALL FUGPCT(FUNC,X3,XHIGH,XFCUM,151,49,TFTOT2,IERR) IF (IERR .GT. 0) GOTO 900 *** Seems to have worked. IFAIL=0 IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ FUGLXP DEBUG : Function'', - '' successfully prepared.'')') RETURN *** Error processing. 900 CONTINUE IFAIL=1 PRINT *,' ###### FUGLXP ERROR : Error while computing the'// - ' percentiles ; can not generate random numbers.' END +DECK,FUGPCT. SUBROUTINE FUGPCT(FUNC,XLOW,XHIGH,XFCUM,NLO,NBINS,TFTOT,IERR) *----------------------------------------------------------------------- * FUGPCT - Array XFCUM is filled from NLO to NLO+NBINS, which makes * the number of values NBINS+1, or the number of bins NBINS *----------------------------------------------------------------------- implicit none EXTERNAL FUNC REAL XFCUM(*),XLOW,XHIGH,TFTOT,RTEPS,PRECIS,TPCTIL,TZ,TZMAX,X,F, - X1,X2,F1,TINCR,XINCR,FUNC,DXMAX,TCUM,XBEST,DTBEST,DTABS, - TPART,TPART2,DTPAR2,REFX,UNCERT,ABERR,FMIN,FMINZ INTEGER NLO,NBINS,NZ,MAXZ,IZ,IHOME,NITMAX,IBIN,IERR PARAMETER (RTEPS=0.005, NZ=10, MAXZ=20, NITMAX=6,PRECIS=1.E-6) *** Set error flag to 'success'. IERR = 0 *** Check for integral. IF (TFTOT .LE. 0.) GOTO 900 *** Coarse estimate of percentiles. TPCTIL = TFTOT/NBINS TZ = TPCTIL/NZ TZMAX = TZ * 2. XFCUM(NLO) = XLOW XFCUM(NLO+NBINS) = XHIGH X = XLOW F = FUNC(X) IF (F .LT. 0.) GOTO 900 *** Loop over percentile bins DO 600 IBIN = NLO, NLO+NBINS-2 TCUM = 0. X1 = X F1 = F DXMAX = (XHIGH -X) / NZ FMIN = TZ/DXMAX FMINZ = FMIN *** Loop over trapezoids within a supposed percentile DO 500 IZ= 1, MAXZ XINCR = TZ/MAX(F1,FMIN,FMINZ) 350 X = X1 + XINCR F = FUNC(X) IF (F .LT. 0.) GOTO 900 TINCR = (X-X1) * 0.5 * (F+F1) IF (TINCR .LT. TZMAX) GOTO 370 XINCR = XINCR * 0.5 GOTO 350 370 CONTINUE TCUM = TCUM + TINCR IF (TCUM .GE. TPCTIL*0.99) GOTO 520 FMINZ = TZ*F/ (TPCTIL-TCUM) F1 = F X1 = X 500 CONTINUE PRINT *,' !!!!!! FUGPCT WARNING : Insufficient trapezoid'// - ' accuracy over a percentile; inaccurate results.' IERR=1 RETURN *** Adjust, Gaussian integration with Newton corr, F is the derivative. 520 CONTINUE X1 = XFCUM(IBIN) XBEST = X DTBEST = TPCTIL TPART = TPCTIL *** Allow for maximum NITMAX more iterations on RADAPT DO 550 IHOME= 1, NITMAX 535 XINCR = (TPCTIL-TPART) / MAX(F,FMIN) X = XBEST + XINCR X2 = X IF (IHOME .GT. 1 .AND. X2 .EQ. XBEST) THEN PRINT *,' !!!!!! FUGPCT WARNING : Insufficient Gauss'// - ' precision at X=',X,'; inaccurate results.' GOTO 580 ENDIF REFX = ABS(X)+PRECIS CALL RADAPT(FUNC,X1,X2,1,RTEPS,0.,TPART2,UNCERT) DTPAR2 = TPART2-TPCTIL DTABS = ABS(DTPAR2) IF(ABS(XINCR)/REFX .LT. PRECIS) GOTO 545 IF(DTABS .LT. DTBEST) GOTO 545 XINCR = XINCR * 0.5 GOTO 535 545 DTBEST = DTABS XBEST = X TPART = TPART2 F = FUNC(X) IF(F .LT. 0.) GOTO 900 IF(DTABS .LT. RTEPS*TPCTIL) GOTO 580 550 CONTINUE PRINT *,' !!!!!! FUGPCT WARNING : No convergence in bin ',IBIN, - ' ; inaccurate results.' IERR=1 RETURN *** < none > 580 CONTINUE XINCR = (TPCTIL-TPART) / MAX(F,FMIN) X = XBEST + XINCR XFCUM(IBIN+1) = X F = FUNC(X) IF(F .LT. 0.) GOTO 900 600 CONTINUE *** End of loop over bins X1 = XFCUM(NLO+NBINS-1) X2 = XHIGH CALL RADAPT(FUNC,X1,X2,1,RTEPS,0.,TPART ,UNCERT) ABERR = ABS(TPART-TPCTIL)/TFTOT IF(ABERR .GT. RTEPS)PRINT *,' !!!!!! FUGPCT WARNING :'// - ' Relative error in cumulative distribution may be as big'// - ' as ',ABERR *** Normal return. RETURN *** Error processing. 900 CONTINUE PRINT *,' ###### FUGPCT WARNING : Function negative at x=',X, - ' f=',F IERR = 1 END +DECK,FUGLUX. SUBROUTINE FUGLUX(ARRAY,XRAN,LEN) *----------------------------------------------------------------------- * FUGLUX - Generation of LEN random numbers in any given distribution, * by 4-point interpolation in the inverse cumulative distr. * which was previously generated by FUGLXP * * The array ARRAY is assumed to have the following structure: * ARRAY(1-100) contains the 99 bins of the inverse cumulative * distribution of the entire function. * ARRAY(101-150) contains the 49-bin blowup of main bins * 1 and 2 (left tail of distribution) * ARRAY(151-200) contains the 49-bin blowup of main bins * 98 and 99 (right tail of distribution) * * Origin: V152, Fred James *----------------------------------------------------------------------- implicit none INTEGER LEN,IBUF,J,J1 REAL ARRAY(*),XRAN(LEN),GAP,GAPINV,TLEFT,BRIGHT,GAPS,GAPINS, - X,P,A,B *** Bin width for main sequence, and its inverse PARAMETER (GAP= 1./99., GAPINV=99.) *** Top of left tail, bottom of right tail (each tail replaces 2 bins) PARAMETER (TLEFT= 2./99.,BRIGHT=97./99.) *** Bin width for minor sequences (tails), and its inverse PARAMETER (GAPS=TLEFT/49., GAPINS=1./GAPS) *** Draw random numbers. CALL RANLUX(XRAN,LEN) *** Compute random numbers. DO 500 IBUF= 1, LEN X = XRAN(IBUF) J = INT( X *GAPINV) + 1 IF (J .LT. 3) THEN J1 = INT( X *GAPINS) J = J1 + 101 J = MAX(J,102) J = MIN(J,148) P = ( X -GAPS*(J1-1)) * GAPINS A = (P+1.0) * ARRAY(J+2) - (P-2.0)*ARRAY(J-1) B = (P-1.0) * ARRAY(J) - P * ARRAY(J+1) XRAN(IBUF) = A*P*(P-1.0)*0.16666667 + B*(P+1.0)*(P-2.0)*0.5 ELSE IF (J .GT. 97) THEN J1 = INT((X-BRIGHT)*GAPINS) J = J1 + 151 J = MAX(J,152) J = MIN(J,198) P = (X -BRIGHT -GAPS*(J1-1)) * GAPINS A = (P+1.0) * ARRAY(J+2) - (P-2.0)*ARRAY(J-1) B = (P-1.0) * ARRAY(J) - P * ARRAY(J+1) XRAN(IBUF) = A*P*(P-1.0)*0.16666667 + B*(P+1.0)*(P-2.0)*0.5 ELSE P = ( X -GAP*(J-1)) * GAPINV A = (P+1.0) * ARRAY(J+2) - (P-2.0)*ARRAY(J-1) B = (P-1.0) * ARRAY(J) - P * ARRAY(J+1) XRAN(IBUF) = A*P*(P-1.0)*0.16666667 + B*(P+1.0)*(P-2.0)*0.5 ENDIF 500 CONTINUE END +DECK,FUGLZ. SUBROUTINE FUGLZ(FUNC,X2LOW,X2HIGH,XLOW,XHIGH) *----------------------------------------------------------------------- * FUGLZ - Find range where func is non-zero. * Origin: V152, Fred James (1980, *----------------------------------------------------------------------- implicit none REAL FUNC,X2LOW,X2HIGH,XLOW,XHIGH,XMID,XH,XL,XNEW INTEGER LOGN,NSLICE,K,I EXTERNAL FUNC *** Set initial limits. XLOW = X2LOW XHIGH = X2HIGH *** Find out if function is zero at one end or both. XMID = XLOW IF (FUNC(XLOW) .GT. 0.) GOTO 120 XMID = XHIGH IF (FUNC(XHIGH) .GT. 0.) GOTO 50 *** Function is zero at both ends, look for place where it is non-zero. DO 30 LOGN= 1, 7 NSLICE = 2**LOGN DO 20 I= 1, NSLICE, 2 XMID = XLOW + I * (XHIGH-XLOW) / NSLICE IF (FUNC(XMID) .GT. 0.) GOTO 50 20 CONTINUE 30 CONTINUE *** Falling through loop means cannot find non-zero value PRINT *,' !!!!!! FUGLZ WARNING : Cannot find positive'// - ' function values in the range ',XLOW,XHIGH XLOW = 0. XHIGH = 0. GOTO 220 50 CONTINUE *** Delete 'leading' zero range. XH = XMID XL = XLOW DO 70 K= 1, 20 XNEW = 0.5*(XH+XL) IF (FUNC(XNEW) .EQ. 0.) GOTO 68 XH = XNEW GOTO 70 68 XL = XNEW 70 CONTINUE XLOW = XL PRINT *,' !!!!!! FUGLZ WARNING : Cannot find positive'// - ' function values in the range ',X2LOW,XLOW 120 CONTINUE IF (FUNC(XHIGH) .GT. 0.) GOTO 220 *** Delete 'trailing' range of zeroes. XL = XMID XH = XHIGH DO 170 K= 1, 20 XNEW = 0.5*(XH+XL) IF (FUNC(XNEW) .EQ. 0.) GOTO 168 XL = XNEW GOTO 170 168 XH = XNEW 170 CONTINUE XHIGH = XH PRINT *,' !!!!!! FUGLZ WARNING : Cannot find positive'// - ' function values in the range ',XHIGH,X2HIGH 220 CONTINUE END +DECK,FUNEXT. SUBROUTINE FUNEXT(FUN,NC,IGLB,XMIN,XMAX,OPTION,EEPSX,EEPSF, - NITMAX,IFAIL) *----------------------------------------------------------------------- * FUNEXT - Searches for extrema of a function. * VARIABLES : * (Last changed on 5/11/01.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,GLOBALS. +SEQ,PRINTPLOT. CHARACTER*(*) FUN,OPTION CHARACTER*20 AUX1,AUX2 INTEGER NC,IENTRY,MODSAV,NITMAX,IGLB,IFAIL,IFAIL1,I,NRNDM, - MODRES(1),NRES,NREXP,NC1,NC2 REAL XMIN,XMAX,VALSAV,RES(1),RNDUNI,XPL(MXLIST),YPL(MXLIST), - EEPSX,EEPSF DOUBLE PRECISION X1,X2,X3,F1,F2,F3,XPARA,FPARA,EPSX,EPSF,FTRY, - XTRY,FMIN,FMAX LOGICAL SET1,SET2,SET3,USE(MXVAR),LPRINT,LPLOT,SMIN,SMAX,SKIP EXTERNAL RNDUNI *** Identification. IF(LIDENT)PRINT *,' /// ROUTINE FUNEXT ///' *** Assume this will work. IFAIL=0 *** Decode options. LPLOT=.FALSE. IF(INDEX(OPTION,'NOPLOT').NE.0)THEN LPLOT=.FALSE. ELSEIF(INDEX(OPTION,'PLOT').NE.0)THEN LPLOT=.TRUE. ENDIF LPRINT=.FALSE. IF(INDEX(OPTION,'NOPRINT').NE.0)THEN LPRINT=.FALSE. ELSEIF(INDEX(OPTION,'PRINT').NE.0)THEN LPRINT=.TRUE. ENDIF SMIN=.TRUE. SMAX=.FALSE. IF(INDEX(OPTION,'MIN').NE.0)THEN SMIN=.TRUE. SMAX=.FALSE. ELSEIF(INDEX(OPTION,'MAX').NE.0)THEN SMIN=.FALSE. SMAX=.TRUE. ENDIF *** Accuracy settings. EPSX=DBLE(EEPSX) EPSF=DBLE(EEPSF) NRNDM=100 *** Debugging output. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ FUNEXT DEBUG : '', - ''Function to be searched: '',A/26X, - ''Range to be searched: '',2E15.8/26X, - ''Minimum / Maximum: '',2L15/26X, - ''Location / function convergence: '',2F15.8/26X, - ''Random cycles / max iterations: '',2I15)') - FUN(1:NC),XMIN,XMAX,SMIN,SMAX,EPSX,EPSF,NRNDM,NITMAX *** Check the parameters. IF(EPSX.LE.0.OR.EPSF.LE.0.OR.NITMAX.LT.1)THEN PRINT *,' !!!!!! FUNEXT WARNING : Received incorrect'// - ' convergence criteria; no search.' RETURN ENDIF *** Print output. IF(LPRINT)THEN IF(SMIN)THEN WRITE(LUNOUT,'('' Searching for the minimum of '',A)') - FUN(1:NC) ELSEIF(SMAX)THEN WRITE(LUNOUT,'('' Searching for the maximum of '',A)') - FUN(1:NC) ENDIF CALL OUTFMT(XMIN,2,AUX1,NC1,'LEFT') CALL OUTFMT(XMAX,2,AUX2,NC2,'LEFT') WRITE(LUNOUT,'('' Search range: '',A,'' < '',A,'' < '',A)') - AUX1(1:NC1),GLBVAR(IGLB),AUX2(1:NC2) CALL OUTFMT(REAL(EPSX),2,AUX1,NC1,'LEFT') WRITE(LUNOUT,'('' Convergence declared for relative'', - '' position changes less than '',A)') AUX1(1:NC1) CALL OUTFMT(REAL(EPSF),2,AUX1,NC1,'LEFT') WRITE(LUNOUT,'('' and for relative function value'', - '' variations less than '',A,''.'')') AUX1(1:NC1) CALL OUTFMT(REAL(NRNDM),2,AUX1,NC1,'LEFT') CALL OUTFMT(REAL(NITMAX),2,AUX2,NC2,'LEFT') WRITE(LUNOUT,'('' Doing '',A,'' random cycles and at'', - '' most '',A,'' parabolic searches.''/)') AUX1(1:NC1), - AUX2(1:NC2) ENDIF *** Check the global variable index. IF(IGLB.LE.0.OR.IGLB.GT.NGLB)THEN PRINT *,' !!!!!! FUNEXT WARNING : Global variable'// - ' reference is out of range; no extrema search.' IFAIL=1 RETURN ENDIF *** Save current value in case minimisation fails. MODSAV=GLBMOD(IGLB) VALSAV=GLBVAL(IGLB) *** Prepare the function. CALL ALGPRE(FUN(1:NC),NC,GLBVAR,NGLB,NRES,USE,IENTRY,IFAIL1) * Verify that the translation worked. IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! FUNEXT WARNING : The function ',FUN(1:NC), - ' can not be translated; no extrema search.' IFAIL=1 CALL ALGCLR(IENTRY) RETURN * Ensure there is only 1 result. ELSEIF(NRES.NE.1)THEN PRINT *,' !!!!!! FUNEXT WARNING : The function ',FUN(1:NC), - ' does not return 1 result; no extrema search.' IFAIL=1 CALL ALGCLR(IENTRY) RETURN * Ensure that the function depends on the parameter. ELSEIF(.NOT.USE(IGLB))THEN PRINT *,' !!!!!! FUNEXT WARNING : The function ',FUN(1:NC), - ' does not depend on global ',GLBVAR(IGLB), - '; no extrema search.' IFAIL=1 CALL ALGCLR(IENTRY) RETURN ENDIF *** Start a plot, if requested. IF(LPLOT)THEN DO 30 I=1,MXLIST XPL(I)=XMIN+REAL(I-1)*(XMAX-XMIN)/REAL(MXLIST-1) NREXP=1 GLBVAL(IGLB)=XPL(I) GLBMOD(IGLB)=2 CALL AL2EXE(IENTRY,GLBVAL,GLBMOD,NGLB,RES,MODRES,NREXP, - IFAIL1) IF(IFAIL1.NE.0.OR.MODRES(1).NE.2)THEN PRINT *,' !!!!!! FUNEXT WARNING : Error evaluating'// - ' the function ; no extremum search.' IFAIL=1 GOTO 3000 ENDIF YPL(I)=RES(1) 30 CONTINUE CALL GRGRPH(XPL,YPL,MXLIST,GLBVAR(IGLB),FUN(1:NC), - 'Function extrema search') ENDIF *** Random search for the 3 extreme points. SET1=.FALSE. SET2=.FALSE. SET3=.FALSE. X1=0 X2=0 X3=0 F1=0 F2=0 F3=0 DO 10 I=1,NRNDM * Evaluate function. XTRY=XMIN+RNDUNI(1.0)*(XMAX-XMIN) NREXP=1 GLBVAL(IGLB)=REAL(XTRY) GLBMOD(IGLB)=2 CALL AL2EXE(IENTRY,GLBVAL,GLBMOD,NGLB,RES,MODRES,NREXP,IFAIL1) IF(IFAIL1.NE.0.OR.MODRES(1).NE.2)THEN PRINT *,' !!!!!! FUNEXT WARNING : Error evaluating the'// - ' function ; no extremum search.' IFAIL=1 GOTO 3000 ENDIF FTRY=RES(1) * Keep track of the 3 smallest numbers. IF((SMIN.AND.FTRY.LT.F1).OR.(SMAX.AND.FTRY.GT.F1).OR. - .NOT.SET1)THEN F3=F2 X3=X2 IF(SET2)SET3=.TRUE. F2=F1 X2=X1 IF(SET1)SET2=.TRUE. F1=FTRY X1=XTRY SET1=.TRUE. ELSEIF((SMIN.AND.FTRY.LT.F2).OR.(SMAX.AND.FTRY.GT.F2).OR. - .NOT.SET2)THEN F3=F2 X3=X2 IF(SET2)SET3=.TRUE. F2=FTRY X2=XTRY SET2=.TRUE. ELSEIF((SMIN.AND.FTRY.LT.F3).OR.(SMAX.AND.FTRY.GT.F3).OR. - .NOT.SET3)THEN F3=FTRY X3=XTRY SET3=.TRUE. ENDIF * Keep track of function range. IF(LPLOT)THEN IF(I.EQ.1)THEN FMIN=FTRY FMAX=FTRY ELSE FMIN=MIN(FTRY,FMIN) FMAX=MAX(FTRY,FMAX) ENDIF ENDIF * Next random cycle. 10 CONTINUE * Print result of random search. IF(LPRINT)WRITE(LUNOUT,'('' Random search finds an extreme'', - '' value at x='',E15.8,'' f='',E15.8)') X1,F1 *** Compare with the boundary values. SKIP=.FALSE. NREXP=1 GLBVAL(IGLB)=XMIN GLBMOD(IGLB)=2 CALL AL2EXE(IENTRY,GLBVAL,GLBMOD,NGLB,RES,MODRES,NREXP, - IFAIL1) IF(IFAIL1.NE.0.OR.MODRES(1).NE.2)THEN PRINT *,' !!!!!! FUNEXT WARNING : Error evaluating'// - ' the function ; no extremum search.' IFAIL=1 GOTO 3000 ENDIF IF((SMIN.AND.RES(1).LT.F1).OR.(SMAX.AND.RES(1).GT.F1))THEN X1=XMIN F1=RES(1) SKIP=.TRUE. IF(LPRINT)WRITE(LUNOUT,'('' Function value at lower'', - '' range limit is better: f='',E15.8)') RES(1) ENDIF NREXP=1 GLBVAL(IGLB)=XMAX GLBMOD(IGLB)=2 CALL AL2EXE(IENTRY,GLBVAL,GLBMOD,NGLB,RES,MODRES,NREXP, - IFAIL1) IF(IFAIL1.NE.0.OR.MODRES(1).NE.2)THEN PRINT *,' !!!!!! FUNEXT WARNING : Error evaluating'// - ' the function ; no extremum search.' IFAIL=1 GOTO 3000 ENDIF IF((SMIN.AND.RES(1).LT.F1).OR.(SMAX.AND.RES(1).GT.F1))THEN X1=XMAX F1=RES(1) SKIP=.TRUE. IF(LPRINT)WRITE(LUNOUT,'('' Function value at upper'', - '' range limit is better: f='',E15.8)') RES(1) ENDIF IF(SKIP)THEN GLBVAL(IGLB)=X1 GLBMOD(IGLB)=2 IF(LPLOT)THEN CALL GRATTS('FUNCTION-2','POLYLINE') IF(SMIN)THEN CALL GRARRO(REAL(XPARA), - REAL(FPARA+0.1*(FMAX-FMIN)), - REAL(XPARA),REAL(FPARA)) ELSEIF(SMAX)THEN CALL GRARRO(REAL(XPARA), - REAL(FPARA-0.1*(FMAX-FMIN)), - REAL(XPARA),REAL(FPARA)) ENDIF ENDIF GOTO 3000 ENDIF *** Refine the estimate by parabolic extremum search. DO 20 I=1,NITMAX * Estimate parabolic extremum. XPARA=( (F1-F2)*X3**2+(F3-F1)*X2**2+(F2-F3)*X1**2)/ - (2*((F1-F2)*X3 +(F3-F1)*X2 +(F2-F3)*X1)) FPARA=-(4*((F1*X2**2-F2*X1**2)*X3-(F1*X2-F2*X1)*X3**2- - X2**2*F3*X1+X2*F3*X1**2)*((F1-F2)*X3-F1*X2+ - X2*F3+F2*X1-F3*X1)+((F1-F2)*X3**2-F1*X2**2+X2**2*F3+ - F2*X1**2-F3*X1**2)**2)/(4*((F1-F2)*X3-F1*X2+ - X2*F3+F2*X1-F3*X1)*(X3-X2)*(X3-X1)*(X2-X1)) * Debugging output. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ FUNEXT DEBUG :'', - '' Start of iteration '',I3// - 26X,''Point 1: x='',E15.8,'' f='',E15.8/ - 26X,''Point 2: x='',E15.8,'' f='',E15.8/ - 26X,''Point 3: x='',E15.8,'' f='',E15.8// - 26X,''Parabola: x='',E15.8,'' f='',E15.8)') - I,X1,F1,X2,F2,X3,F3,XPARA,FPARA * Check that the parabolic estimate is within range. IF((XMIN-XPARA)*(XPARA-XMAX).LT.0)THEN PRINT *,' !!!!!! FUNEXT WARNING : Estimated parabolic'// - ' extremum is located outside curve range.' IFAIL=1 GOTO 3000 ENDIF * Check that the new estimate doesn't coincide with an old point. IF(ABS(XPARA-X1).LT.EPSX*(EPSX+ABS(XPARA)).OR. - ABS(XPARA-X2).LT.EPSX*(EPSX+ABS(XPARA)).OR. - ABS(XPARA-X3).LT.EPSX*(EPSX+ABS(XPARA)))THEN IF(LPRINT)WRITE(LUNOUT,'(/'' Location convergence'', - '' criterion satisfied.''/)') GOTO 3000 ENDIF * Evaluate things over there. NREXP=1 GLBVAL(IGLB)=REAL(XPARA) GLBMOD(IGLB)=2 CALL AL2EXE(IENTRY,GLBVAL,GLBMOD,NGLB,RES,MODRES,NREXP,IFAIL1) IF(IFAIL1.NE.0.OR.MODRES(1).NE.2)THEN PRINT *,' !!!!!! FUNEXT WARNING : Error evaluating the'// - ' function ; no extremum search.' IFAIL=1 GOTO 3000 ENDIF FPARA=RES(1) * Normal printout. IF(LPRINT)WRITE(LUNOUT,'('' Iteration '',I3,'' x='',E15.8, - '': f = '',E15.8,''.'')') I,XPARA,FPARA IF(LPLOT)THEN CALL GRATTS('FUNCTION-2','POLYLINE') IF(SMIN)THEN CALL GRARRO(REAL(XPARA),REAL(FPARA+0.1*(FMAX-FMIN)), - REAL(XPARA),REAL(FPARA)) ELSEIF(SMAX)THEN CALL GRARRO(REAL(XPARA),REAL(FPARA-0.1*(FMAX-FMIN)), - REAL(XPARA),REAL(FPARA)) ENDIF ENDIF * Check convergence. IF(ABS(FPARA-F1).LT.EPSF*(ABS(FPARA)+ABS(F1)+EPSF))THEN IF(LPRINT)WRITE(LUNOUT,'(/'' Function value convergence'', - '' criterion satisfied.''/)') GOTO 3000 ENDIF * Store the value in the table. IF((SMIN.AND.FPARA.LT.F1).OR.(SMAX.AND.FPARA.GT.F1))THEN F3=F2 X3=X2 F2=F1 X2=X1 F1=FPARA X1=XPARA ELSEIF((SMIN.AND.FPARA.LT.F2).OR.(SMAX.AND.FPARA.GT.F2))THEN F3=F2 X3=X2 F2=FPARA X2=XPARA ELSEIF((SMIN.AND.FPARA.LT.F3).OR.(SMAX.AND.FPARA.GT.F3))THEN F3=FPARA X3=XPARA ELSE PRINT *,' !!!!!! FUNEXT WARNING : Parabolic extremum'// - ' is outside current search range; search stopped.' IFAIL=1 GOTO 3000 ENDIF 20 CONTINUE *** No convergence. PRINT *,' !!!!!! FUNEXT WARNING : No convergence after maximum'// - ' number of steps.' PRINT *,' Current extremum f=',F1 PRINT *,' Found for x=',X1 *** Clean up. 3000 CONTINUE * Display number of algebra errors. CALL ALGERR * Kill algebra entry points. CALL ALGCLR(IENTRY) * Close graphics, if active. IF(LPLOT)CALL GRNEXT * Restore original results in case of failure. IF(IFAIL.NE.0)THEN GLBVAL(IGLB)=VALSAV GLBMOD(IGLB)=MODSAV ENDIF END +DECK,FUNFIT. SUBROUTINE FUNFIT(FUN,X,Y,EY,N,LPRINT,IA,IE,NA,IFAIL) *----------------------------------------------------------------------- * FUNFIT - Fits an arbitrary function. * (Last changed on 5/11/01.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. +SEQ,GLOBALS. CHARACTER*(*) FUN REAL X(*),Y(*),EY(*) DOUBLE PRECISION XX(MXLIST),YY(MXLIST),EEY(MXLIST), - AA(MXVAR),EA(MXVAR),CHI2,YSUM INTEGER N,NA,NNA,IFAIL,IFAIL1,IA(*),IE(*),IENTRY,I,IIA,NRES,NDATA LOGICAL LPRINT,USE(MXVAR),OK COMMON /FFUDAT/ NNA,IENTRY,IIA(MXVAR) EXTERNAL FUNFUN *** Preset the error flag. IFAIL=1 OK=.TRUE. *** Debugging and identification output. IF(LIDENT)PRINT *,' /// ROUTINE FUNFIT ///' *** Copy the vectors. YSUM=0 NDATA=0 DO 30 I=1,N IF(EY(I).GT.0)THEN NDATA=NDATA+1 IF(NDATA.LE.MXLIST)THEN XX(NDATA)=DBLE(X(I)) YY(NDATA)=DBLE(Y(I)) YSUM=YSUM+ABS(YY(I)) EEY(NDATA)=DBLE(EY(I)) ENDIF ENDIF 30 CONTINUE *** Check remaining number of data points. IF(NDATA.LT.N)PRINT *,' ------ FUNFIT MESSAGE : Eliminated ', - N-NDATA,' data points for which error <= 0.' IF(NDATA.LT.NA)THEN PRINT *,' !!!!!! FUNFIT WARNING : The problem is not'// - ' sufficiently constrained; no fit.' OK=.FALSE. ENDIF *** Check dimensions. IF(NA.GT.MXFPAR.OR.NA.GT.MXVAR.OR.NDATA.GT.MXLIST)THEN PRINT *,' !!!!!! FUNFIT WARNING : Dimensions of the'// - ' problem exceed compilation parameters; no fit.' OK=.FALSE. ELSEIF(NA.LE.0)THEN PRINT *,' !!!!!! FUNFIT WARNING : No parameters to be'// - ' adjusted; no fit.' OK=.FALSE. ENDIF *** Convert the function. CALL ALGPRE(FUN,LEN(FUN),GLBVAR,NGLB,NRES,USE,IENTRY,IFAIL1) * Check error flag. IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! FUNFIT WARNING : Translating the'// - ' function ',FUN,' failed; no fit.' RETURN ENDIF * Check the type of the used globals and copy to a fit vector. DO 10 I=1,NGLB IF(I.NE.8.AND.USE(I).AND.GLBMOD(I).EQ.0)THEN PRINT *,' !!!!!! FUNFIT WARNING : The function uses the'// - ' uninitialised variable '//GLBVAR(I) OK=.FALSE. ELSEIF(I.NE.8.AND.USE(I).AND.GLBMOD(I).NE.2)THEN PRINT *,' !!!!!! FUNFIT WARNING : The function uses the'// - ' non-numeric global '//GLBVAR(I) OK=.FALSE. ENDIF 10 CONTINUE * Check that all variables are in fact used. NNA=NA DO 20 I=1,NA IF(IA(I).LE.0.OR.IA(I).GT.NGLB)THEN PRINT *,' !!!!!! FUNFIT WARNING : Incorrect reference'// - ' to a global received; program bug, please report.' OK=.FALSE. ELSEIF(.NOT.USE(IA(I)))THEN PRINT *,' !!!!!! FUNFIT WARNING : The function does not'// - ' depend on the variable '//GLBVAR(IA(I)) OK=.FALSE. ENDIF AA(I)=DBLE(GLBVAL(IA(I))) IIA(I)=IA(I) 20 CONTINUE * Ensure that the function depends on x. IF(NA.GT.1.AND..NOT.USE(8))THEN PRINT *,' !!!!!! FUNFIT WARNING : The function does not'// - ' depend on X but on more than 1 fit parameter.' OK=.FALSE. ELSEIF(.NOT.USE(8))THEN PRINT *,' ------ FUNFIT MESSAGE : The function does not'// - ' depend on X (acceptable for 1 free parameter).' ENDIF * Set the mode of global 8 (=X) to 2 and delete anything tied to it. CALL ALGREU(NINT(GLBVAL(8)),GLBMOD(8),0) GLBMOD(8)=2 * Check error status. IF(.NOT.OK)THEN PRINT *,' !!!!!! FUNFIT WARNING : No fit because of the'// - ' above warnings.' RETURN ENDIF *** Now carry out the fit. CALL LSQFIT(FUNFUN,AA,EA,NA,XX,YY,EEY,NDATA,200,0.01*YSUM/NDATA, - CHI2,1.0D-3,LPRINT,IFAIL1) * Print the number of errors. CALL ALGERR * Check error flag. IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! FUNFIT WARNING : Error fitting the'// - ' function; results not returned.' RETURN ENDIF *** Transfer the results back. DO 40 I=1,NA GLBVAL(IA(I))=REAL(AA(I)) GLBVAL(IE(I))=REAL(EA(I)) GLBMOD(IA(I))=2 GLBMOD(IE(I))=2 40 CONTINUE *** Things seem to have worked. IFAIL=0 END +DECK,FUNFUN. SUBROUTINE FUNFUN(X,A,F) *----------------------------------------------------------------------- * FUNFUN - Auxiliary function for fitting an arbitrary function. * (Last changed on 17/ 9/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,GLOBALS. DOUBLE PRECISION A(*),X,F REAL AA(MXVAR),RES(1) INTEGER NNA,IIA,IFAIL1,I,IENTRY,MODRES(1) COMMON /FFUDAT/ NNA,IENTRY,IIA(MXVAR) *** Copy fit parameters to single precision. DO 10 I=1,NGLB AA(I)=GLBVAL(I) 10 CONTINUE DO 20 I=1,NNA AA(IIA(I))=REAL(A(I)) 20 CONTINUE *** Copy ordinate to single precision. AA(8)=REAL(X) *** Evaluate the function. CALL AL2EXE(IENTRY,AA,GLBMOD,NGLB,RES,MODRES,1,IFAIL1) *** And return the result. IF(IFAIL1.EQ.0)THEN F=DBLE(RES(1)) ELSE F=0 ENDIF END +DECK,F010,IF=NAGNUM. SUBROUTINE DEQINV(N,A,IDIM,R,IFAIL,K,B) *----------------------------------------------------------------------- * DEQINV - Replacement for the DEQINV (F010) routine from the KERNLIB * at CERN using NAG routines. This routine will only work in * the Garfield environment. The input matrix is assumed to be * symmetric. If it's also positive definite, Choleski's method * is used; if a more approximate implementation of Crout's. *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. DOUBLE PRECISION A(IDIM,*),R(IDIM),B(IDIM) DOUBLE PRECISION C(MXWIRE+1,MXWIRE+1),EPS,X(MXWIRE+1) *** Check that the declared dimensions are sufficient. IF(N.GE.IDIM.OR.N.GE.MXWIRE+1)THEN PRINT *,' ###### DEQINV ERROR : Matrix dimension too', - ' large, recompile with a MXWIRE > ',N+1 IFAIL=1 RETURN ENDIF *** Set the precision EPS=X02AAF(DUMMY) *** Perform a Choleski inversion. IFAIL=1 CALL F01ACF(N,EPS,A,IDIM,C,MXWIRE+1,R,L,IFAIL) IF(IFAIL.EQ.1)THEN PRINT *,' !!!!!! DEQINV WARNING : The matrix is not'// - ' pos. def., perhaps due to rouding errors (F01ACF);' PRINT *,' An attempt will be made'// - ' to invert using Crout''s method.' GOTO 100 ELSEIF(IFAIL.EQ.2)THEN PRINT *,' !!!!!! DEQINV WARNING : The refinement fails to'// - ' converge, ie the matrix is ill-conditioned (F01ACF);' PRINT *,' An attempt will be made'// - ' to invert using Crout''s method.' GOTO 100 ELSEIF(IFAIL.NE.0.AND.IFAIL.NE.1.AND.IFAIL.NE.2)THEN PRINT *,' !!!!!! DEQINV WARNING : Unidentified NAG error'// - ' error condition from F01ACF: ',IFAIL,';' PRINT *,' An attempt will be made'// - ' to invert using Crout''s method.' GOTO 100 ENDIF IF(LDEBUG)PRINT *,' ++++++ DEQINV DEBUG : F01ACF iterations ', - L,' IFAIL=',IFAIL *** Set the correct inverse all over the matrix DO 20 I=2,N+1 DO 10 J=1,I-1 A(I-1,J)=A(I,J) A(J,I-1)=A(I,J) 10 CONTINUE 20 CONTINUE *** Skip the next part which is only used if Choleski fails. GOTO 200 *** Try Crout's method if Choleski fails. First restore matrix. 100 CONTINUE DO 110 I=1,N DO 120 J=I,N A(J,I)=A(I,J) 120 CONTINUE 110 CONTINUE *** Next call the Crout, approximate, routine. IFAIL=1 CALL F01AAF(A,IDIM,N,C,MXWIRE+1,R,IFAIL) IF(IFAIL.EQ.1)THEN PRINT *,' ###### DEQINV ERROR : The matrix is (almost)', - ' singular, perhaps due to rounding errors (F01AAF).' RETURN ELSEIF(IFAIL.NE.0.AND.IFAIL.NE.1)THEN PRINT *,' ###### DEQINV WARNING : Unidentified NAG error', - ' error condition from F01AAF: ',IFAIL RETURN ENDIF PRINT *,' !!!!!! DEQINV WARNING : Crout''s method succeeded'// - ' but the results are less accurate (F01AAF).' *** Copy the inverted matrix to A. DO 130 I=1,N DO 140 J=1,N A(I,J)=C(I,J) 140 CONTINUE 130 CONTINUE *** Solve the system of equations. 200 CONTINUE DO 210 I=1,N X(I)=0 DO 220 J=1,N X(I)=X(I)+A(I,J)*B(J) 220 CONTINUE 210 CONTINUE *** Copy X to B. DO 230 I=1,N B(I)=X(I) 230 CONTINUE END SUBROUTINE DEQN(N,A,IDIM,R,IFAIL,K,B) *----------------------------------------------------------------------- * DEQN - Replacement for the DEQN (F010) routine from the KERNLIB at * CERN using NAG routines. This routine will only work in the * Garfield environment. *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. PARAMETER(MXRGHT=3) DOUBLE PRECISION A(IDIM,*),R(IDIM),B(IDIM,*) DOUBLE PRECISION AA(MXWIRE+1,MXWIRE+1),EPS,D1,X(MXWIRE+1,MXRGHT), - BB(MXWIRE+1,MXRGHT) *** Check the dimensions. IF(K.GT.MXRGHT)THEN PRINT *,' ###### DEQN ERROR : Too many right hand', - ' sides; recompile with MXRGHT=',K IFAIL=1 RETURN ENDIF IF(N.GT.MXWIRE+1)THEN PRINT *,' ###### DEQN ERROR : Order of the matrix is', - ' too large; use the true DEQN routine.' IFAIL=1 ENDIF *** Set the precision EPS=X02AAF(DUMMY) *** Copy the input array AA DO 10 I=1,N DO 20 J=1,N AA(I,J)=A(I,J) 20 CONTINUE 10 CONTINUE *** Perform a Crout factorisation. IFAIL=1 CALL F03AFF(N,EPS,AA,MXWIRE+1,D1,ID,R,IFAIL) IF(IFAIL.EQ.1)THEN PRINT *,' ###### DEQN ERROR : The matrix is singular', - ' perhaps because of rounding errors (F03AFF).' RETURN ELSEIF(IFAIL.NE.0.AND.IFAIL.NE.1)THEN PRINT *,' ###### DEQN ERROR : Unidentified NAG error', - ' error condition from F03AFF: ',IFAIL RETURN ENDIF IF(LDEBUG)PRINT *,' ++++++ DEQN DEBUG : Determinant equals', - D1*2.0**ID,' F03AFF IFAIL=',IFAIL *** Solve the system of equations. IFAIL=1 CALL F04AHF(N,K,A,IDIM,AA,MXWIRE+1,R,B,IDIM,EPS, - X,MXWIRE+1,BB,MXWIRE+1,L,IFAIL) IF(IFAIL.EQ.1)THEN PRINT *,' ###### DEQN ERROR : The matrix is too', - ' ill-conditioned to produce a correctly rounded', - ' solution (F04AHF).' RETURN ELSEIF(IFAIL.NE.0.AND.IFAIL.NE.1)THEN PRINT *,' ###### DEQN ERROR : Unidentified NAG error', - ' error condition from F04AHF: ',IFAIL RETURN ENDIF IF(LDEBUG)THEN PRINT *,' ++++++ DEQN DEBUG : F04AHF IFAIL=',IFAIL, - ' iterations ',L,' list of residuals follows:' DO 30 I=1,N PRINT *,' I=',I,' Residuals= ',(BB(I,KK),KK=1,K) 30 CONTINUE PRINT *,' ++++++ DEQN DEBUG : End of list.' ENDIF *** Copy X to B. DO 50 KK=1,K DO 40 I=1,N B(I,KK)=X(I,KK) 40 CONTINUE 50 CONTINUE END SUBROUTINE REQN(N,AIN,IDIM,RIN,IFAIL,K,BIN) *----------------------------------------------------------------------- * REQN - Replaces the CERN library routine REQN (F010) by a NAG * equivalent. This routine will only work in the Garfield * environment. * PARAMETERS: MXREQN : Maximum input dimension *----------------------------------------------------------------------- +SEQ,PRINTPLOT. PARAMETER (MXREQN=3,MXRGHT=3) REAL AIN(IDIM,*),RIN(IDIM),BIN(IDIM,*) DOUBLE PRECISION A(MXREQN,MXREQN),R(MXREQN),B(MXREQN,MXRGHT), - AA(MXREQN,MXREQN),EPS,D1,X(MXREQN,MXRGHT),BB(MXREQN,MXRGHT) *** Check dimension of the matrix. IF(K.GT.MXRGHT)THEN PRINT *,' ###### REQN ERROR : Too many right hand', - ' sides; recompile with MXRGHT=',K IFAIL=1 RETURN ENDIF IF(N.GT.MXREQN)THEN PRINT *,' ###### REQN ERROR : Dimension of input', - ' exceeds MXREQN; change to at least ',N IFAIL=1 RETURN ENDIF *** Copy the (single precision) input to double precision variables. DO 5 KK=1,K DO 10 I=1,N B(I,KK)=DBLE(BIN(I,KK)) DO 20 J=1,N A(I,J)=DBLE(AIN(I,J)) AA(I,J)=A(I,J) 20 CONTINUE 10 CONTINUE 5 CONTINUE *** Set the precision to 1E-6, about the REAL*4 accuracy of an IBM. EPS=1.0D-6 *** Perform a Crout factorisation. IFAIL=1 CALL F03AFF(N,EPS,AA,MXREQN,D1,ID,R,IFAIL) IF(IFAIL.EQ.1)THEN PRINT *,' ###### REQN ERROR : The matrix is singular', - ' perhaps because of rounding errors (F03AFF).' RETURN ELSEIF(IFAIL.NE.0.AND.IFAIL.NE.1)THEN PRINT *,' ###### REQN ERROR : Unidentified NAG error', - ' error condition from F03AFF: ',IFAIL RETURN ENDIF IF(LDEBUG)PRINT *,' ++++++ REQN DEBUG : F03AFF Determinant', - ' equals ',D1,'*2**',ID,', IFAIL=',IFAIL *** Solve the system of equations. IFAIL=1 CALL F04AHF(N,K,A,MXREQN,AA,MXREQN,R,B,MXREQN,EPS, - X,MXREQN,BB,MXREQN,L,IFAIL) IF(IFAIL.EQ.1)THEN PRINT *,' ###### REQN ERROR : The matrix is too', - ' ill-conditioned to produce a correctly rounded', - ' solution (F04AHF).' RETURN ELSEIF(IFAIL.NE.0.AND.IFAIL.NE.1)THEN PRINT *,' ###### REQN ERROR : Unidentified NAG error', - ' error condition from F04AHF: ',IFAIL RETURN ENDIF IF(LDEBUG)THEN PRINT *,' ++++++ REQN DEBUG : F04AHF IFAIL=',IFAIL, - ' iterations ',L,' list of residuals follows:' DO 30 I=1,N PRINT *,' I=',I,' Residual= ',(BB(I,KK),KK=1,K) 30 CONTINUE PRINT *,' ++++++ REQN DEBUG : End of list.' ENDIF *** Copy X to B. DO 50 KK=1,K DO 40 I=1,N BIN(I,KK)=REAL(X(I,KK)) 40 CONTINUE 50 CONTINUE END +DECK,CRNERR. SUBROUTINE CRNERR *----------------------------------------------------------------------- * CRNERR - Error handling *----------------------------------------------------------------------- +SEQ,PRINTPLOT. EXTERNAL INPCMP CHARACTER*6 ER INTEGER LM,LR *** Default value. ER='??????' LM=100 LR=100 IER=0 ILM=0 ILR=0 *** Decode the argument string CALL INPNUM(NWORD) INEXT=2 DO 10 I=2,NWORD * Skip arguments etc. IF(I.LT.INEXT)GOTO 10 * Message string. IF(INPCMP(I,'M#ESSAGE').NE.0)THEN CALL INPSTR(I+1,I+1,ER,NCH) IF(INDEX('ABCDEFGHIJKLMNOPQRSTUVWXYZ ',ER(1:1)).EQ.0.OR. - INDEX('0123456789 ', ER(2:2)).EQ.0.OR. - INDEX('0123456789 ', ER(3:3)).EQ.0.OR. - INDEX('0123456789 ', ER(4:4)).EQ.0.OR. - INDEX('. ', ER(5:5)).EQ.0.OR. - INDEX('0123456789 ', ER(6:6)).EQ.0)THEN CALL INPMSG(I+1,'Not correctly formatted. ') ER='??????' IER=0 ELSE IER=1 ENDIF INEXT=I+2 * Number of times to print. ELSEIF(INPCMP(I,'PR#INT').NE.0)THEN IF(INPCMP(I+1,'A#LWAYS').NE.0)THEN LM=100 ELSEIF(INPCMP(I+1,'N#EVER').NE.0)THEN LM=0 ELSE CALL INPCHK(I+1,1,IFAIL1) CALL INPRDI(I+1,LM,100) ENDIF INEXT=I+2 ILM=1 * Number of occurences before ABEND. ELSEIF(INPCMP(I,'AB#END').NE.0)THEN IF(INPCMP(I+1,'N#EVER').NE.0)THEN LR=100 ELSE CALL INPCHK(I+1,1,IFAIL1) CALL INPRDI(I+1,LR,100) ENDIF INEXT=I+2 ILR=1 * Anything not valid. ELSE CALL INPMSG(I,'Keyword not recognised. ') ENDIF 10 CONTINUE *** Dump error messages. CALL INPERR *** Check at least the message id was specified. IF(IER.EQ.0)THEN PRINT *,' !!!!!! CRNERR WARNING : Error message id not'// - ' specified ; no call to KERSET.' RETURN ENDIF *** Register request with KERSET. CALL KERSET(ER,0,LM,LR) IF(LDEBUG)PRINT *,' ++++++ CRNERR DEBUG : KERSET called for'// - ' message '//ER//': printing ',LM,' times, ABEND after ', - LR,' occurences.' END +DECK,HISPRD. SUBROUTINE HISPRD(Y,N) *----------------------------------------------------------------------- * HISPRD - Initialize histogram to form cumulative distribution. * Author: F. James, modified for double precision. * (Last changed on 17/10/95.) *----------------------------------------------------------------------- IMPLICIT DOUBLE PRECISION (A-H,O-Z) DOUBLE PRECISION Y(*) INTEGER N *** Form cumulative distribution. YTOT = 0 DO 100 I= 1, N IF(Y(I).LT.0)THEN PRINT *,' !!!!!! HISPRD WARNING : Found a negative'// - ' probability in bin ',I,'; set to 0.' ELSE YTOT = YTOT + Y(I) Y(I) = YTOT ENDIF 100 CONTINUE IF(YTOT.LE.0)THEN PRINT *,' !!!!!! HISPRD WARNING : Histogram has a zero'// - ' integral ; not useable.' YTOT=1 ENDIF *** Normalise the distribution. YINV = 1/YTOT DO 110 I= 1, N Y(I) = Y(I) * YINV 110 CONTINUE Y(N) = 1.0 END +DECK,HISRAD. SUBROUTINE HISRAD(Y,N,XLO,XWID,XRAN) *----------------------------------------------------------------------- * HISRAD - Subroutine to generate random numbers according to an * empirical distribution supplied by the user in the form of * a histogram. * Author: F. James, modified for DOUBLE PRECISION usage. * (Last changed on 26/10/07.) *----------------------------------------------------------------------- IMPLICIT DOUBLE PRECISION (A-H,O-Z) PARAMETER(NVEC=100) DOUBLE PRECISION Y(*),RVEC(NVEC),XLO,XWID,XRAN,YR INTEGER L,IVEC,LOCATD EXTERNAL LOCATD +SELF,IF=SAVE. SAVE RVEC,IVEC +SELF. *** Initial value. DATA IVEC/0/ *** Make sure that the histogram has been prepared. IF(Y(N).NE.1)THEN PRINT *,' !!!!!! HISRAD WARNING : HISPRD has apparently'// - ' not been called; calling it now.' CALL HISPRD(Y,N) ENDIF *** Now generate random number between 0 and one. IF(IVEC.EQ.0.OR.IVEC.GE.NVEC)THEN CALL RM48(RVEC,NVEC) IVEC=1 ELSE IVEC=IVEC+1 ENDIF YR = RVEC(IVEC) * Verify random number. IF(YR.LE.0.OR.YR.GT.1)PRINT *,' !!!!!! HISRAD WARNING :'// - ' Received ',YR,' from RM48 - please ensure you have'// - ' an up to date version of CERNLIB.' * and transform it into the corresponding x-value L = LOCATD(Y,N,YR) * point falls in first bin. special case IF(L.EQ.0)THEN IF(Y(1).LE.0)THEN XRAN = XLO + XWID / 2 ELSE XRAN = XLO + XWID * (YR/Y(1)) ENDIF * guard against special case of falling on empty bin ELSEIF(L.GT.0)THEN XRAN = XLO + L * XWID * usually come here. ELSE L = ABS(L) IF(Y(L+1)-Y(L).LE.0)THEN XRAN = XLO + XWID * (L + 0.5) ELSE XRAN = XLO + XWID * (L +((YR-Y(L))/(Y(L+1)-Y(L)))) ENDIF ENDIF END +DECK,LOCATD. INTEGER FUNCTION LOCATD(ARRAY,LENGTH,OBJECT) *----------------------------------------------------------------------- * LOCATD - binary search thru ARRAY to find OBJECT. ARRAY is assumed * to be sorted prior to call. If a match is found, function * returns position of element. If no match is found, function * gives negative of nearest element smaller than object. * Author: F. James, double precision version. * (Last changed on 17/10/95.) *----------------------------------------------------------------------- IMPLICIT DOUBLE PRECISION (A-H,O-Z) DOUBLE PRECISION ARRAY(*) INTEGER LENGTH,NABOVE,NBELOW,MIDDLE NABOVE = LENGTH + 1 NBELOW = 0 10 IF (NABOVE-NBELOW .LE. 1) GO TO 200 MIDDLE = (NABOVE+NBELOW) / 2 IF (OBJECT - ARRAY(MIDDLE)) 100, 180, 140 100 NABOVE = MIDDLE GO TO 10 140 NBELOW = MIDDLE GO TO 10 180 LOCATD = MIDDLE GO TO 300 200 LOCATD = -NBELOW 300 RETURN END +DECK,STDSTRB,IF=BOINC. LOGICAL FUNCTION STDSTR(STREAM) *----------------------------------------------------------------------- * STDSTR - BOINC version which returns always False. * (Last changed on 28/ 1/06.) *----------------------------------------------------------------------- implicit none CHARACTER*(*) STREAM STDSTR=.FALSE. END +DECK,STDSTRO,IF=-BOINC. LOGICAL FUNCTION STDSTR(STREAM) *----------------------------------------------------------------------- * STDSTR - Checks whether the data stream STREAM is connected to * standard input or output. * (Last changed on 19/12/10.) *----------------------------------------------------------------------- implicit none +SEQ,PRINTPLOT. CHARACTER*(*) STREAM INTEGER LENARG,IARG,NARGS,INIT,INPCMX,DUMMY CHARACTER*128 ARGS LOGICAL LSTATE,INTRAC EXTERNAL INPCMX,INTRAC +SELF,IF=G77. integer iargc external iargc. +SELF,IF=SAVE. SAVE LSTATE,INIT +SELF. *** For input. IF(STREAM.EQ.'INPUT')THEN * On first call, determine the state. DATA INIT/0/ IF(INIT.EQ.0)THEN * Default is obtained from INTRAC. LSTATE=INTRAC(DUMMY) +SELF,IF=UNIX,CYGWIN. * Loop over the command line arguments. NARGS=iargc() DO 10 IARG=1,NARGS * Fetch the option. CALL ARGGET(IARG,ARGS,LENARG) * If -interactive, then force interactive mode. IF(INPCMX(args(1:LENARG),'-interact#ive').NE.0)THEN LSTATE=.TRUE. * If -batch, then force batch mode. ELSEIF(INPCMX(ARGS(1:LENARG),'-batch').NE.0)THEN LSTATE=.FALSE. ENDIF 10 CONTINUE +SELF. INIT=1 ENDIF * On subsequent calls, retrieve old state. STDSTR=LSTATE *** Output. ELSEIF(STREAM.EQ.'OUTPUT')THEN STDSTR=LUNOUT.EQ.6 *** Other streams not known. ELSE PRINT *,' !!!!!! STDSTR WARNING : Received an unknown'// - ' stream name "',STREAM,'"; returning "True".' STDSTR=.TRUE. ENDIF END +DECK,INTERN. SUBROUTINE INTERN(NPL,XPL,YPL,X,Y,INSIDE,EDGE) *----------------------------------------------------------------------- * INTERN - Determines whether the point (X,Y) is located inside of the * polygon (XPL,YPL). * (Last changed on 6/10/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. +SEQ,PARAMETERS. INTEGER NPL,NITER,I,J,NCROSS REAL XPL(NPL),YPL(NPL),X,Y,XINF,YINF,XMAX,YMAX,XMIN,YMIN,RNDUNI, - EPSX,EPSY LOGICAL CROSS,ONLINE,INSIDE,EDGE EXTERNAL CROSS,ONLINE,RNDUNI *** Initial settings. INSIDE=.FALSE. EDGE=.FALSE. *** Special treatment for few points. IF(NPL.LT.2)THEN RETURN ELSEIF(NPL.EQ.2)THEN EDGE=ONLINE(XPL(1),YPL(1),XPL(2),YPL(2),X,Y) RETURN ENDIF *** Determine the range of the data. XMIN=XPL(1) YMIN=YPL(1) XMAX=XPL(1) YMAX=YPL(1) DO 10 I=2,NPL XMIN=MIN(XMIN,XPL(I)) YMIN=MIN(YMIN,YPL(I)) XMAX=MAX(XMAX,XPL(I)) YMAX=MAX(YMAX,YPL(I)) 10 CONTINUE *** Set tolerances. IF(LEPSG)THEN EPSX=EPSGX EPSY=EPSGY ELSE EPSX=1.0E-5*MAX(ABS(XMIN),ABS(XMAX)) EPSY=1.0E-5*MAX(ABS(YMIN),ABS(YMAX)) IF(EPSX.LE.0)EPSX=1.0E-5 IF(EPSY.LE.0)EPSY=1.0E-5 ENDIF *** Ensure that we have a range. IF(ABS(XMAX-XMIN).LE.EPSX)THEN IF(Y.GE.YMIN-EPSY.AND.Y.LE.YMAX+EPSY.AND. - ABS(XMAX+XMIN-2*X).LE.EPSX)THEN EDGE=.TRUE. ELSE EDGE=.FALSE. ENDIF RETURN ELSEIF(ABS(YMAX-YMIN).LE.EPSY)THEN IF(X.GE.XMIN-EPSX.AND.X.LE.XMAX+EPSX.AND. - ABS(YMAX+YMIN-2*Y).LE.EPSY)THEN EDGE=.TRUE. ELSE EDGE=.FALSE. ENDIF RETURN ENDIF *** Choose a point at "infinity". XINF=XMIN-ABS(XMAX-XMIN) YINF=YMIN-ABS(YMAX-YMIN) *** Loop over the edges counting intersections. NITER=0 20 CONTINUE NCROSS=0 DO 30 J=1,NPL * Flag points located on one of the edges. IF(ONLINE(XPL(1+MOD(J-1,NPL)),YPL(1+MOD(J-1,NPL)), - XPL(1+MOD(J,NPL)),YPL(1+MOD(J,NPL)),X,Y))THEN EDGE=.TRUE. RETURN ENDIF * Count mid-line intersects. IF(CROSS(X,Y,XINF,YINF, - XPL(1+MOD(J-1,NPL)),YPL(1+MOD(J-1,NPL)), - XPL(1+MOD(J ,NPL)),YPL(1+MOD(J ,NPL))))NCROSS=NCROSS+1 * Ensure that the testing line doesn't cross a corner. IF(ONLINE(X,Y,XINF,YINF,XPL(J),YPL(J)))THEN XINF=XMIN-RNDUNI(1.0)*ABS(XMAX-XINF) YINF=YMIN+RNDUNI(-1.0)*ABS(YMAX-YINF) NITER=NITER+1 IF(NITER.LT.100)GOTO 20 PRINT *,' !!!!!! INTERN WARNING : Unable to verify'// - ' whether a point is internal; setting to "edge".' INSIDE=.FALSE. EDGE=.TRUE. * Produce a dump if requested. IF(LGSTOP)THEN OPEN(UNIT=12,FILE='intern.dat',STATUS='UNKNOWN') WRITE(12,*) EPSGX,EPSGY,EPSGZ,LEPSG WRITE(12,*) X,Y WRITE(12,*) NPL DO 40 I=1,NPL WRITE(12,*) I,XPL(I),YPL(I) 40 CONTINUE CLOSE(12) PRINT *,' ------ INTERN MESSAGE : Dump produced;'// - ' terminating program execution.' CALL QUIT ENDIF RETURN ENDIF 30 CONTINUE *** Set the INSIDE flag. IF(NCROSS.NE.2*(NCROSS/2))INSIDE=.TRUE. END +DECK,INTERD. SUBROUTINE INTERD(NPL,XPL,YPL,X,Y,INSIDE,EDGE) *----------------------------------------------------------------------- * INTERD - Determines whether the point (X,Y) is located inside of the * polygon (XPL,YPL). * (Last changed on 6/10/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. +SEQ,PARAMETERS. INTEGER NPL,NITER,I,J,NCROSS DOUBLE PRECISION XPL(NPL),YPL(NPL),X,Y,XINF,YINF, - XMAX,YMAX,XMIN,YMIN,EPSX,EPSY REAL RNDUNI LOGICAL CROSSD,ONLIND,INSIDE,EDGE EXTERNAL CROSSD,ONLIND,RNDUNI *** Initial settings. INSIDE=.FALSE. EDGE=.FALSE. *** Special treatment for few points. IF(NPL.LT.2)THEN RETURN ELSEIF(NPL.EQ.2)THEN EDGE=ONLIND(XPL(1),YPL(1),XPL(2),YPL(2),X,Y) RETURN ENDIF *** Determine the range of the data. XMIN=XPL(1) YMIN=YPL(1) XMAX=XPL(1) YMAX=YPL(1) DO 10 I=2,NPL XMIN=MIN(XMIN,XPL(I)) YMIN=MIN(YMIN,YPL(I)) XMAX=MAX(XMAX,XPL(I)) YMAX=MAX(YMAX,YPL(I)) 10 CONTINUE *** Set tolerances. IF(LEPSG)THEN EPSX=EPSGX EPSY=EPSGY ELSE EPSX=1.0D-8*MAX(ABS(XMIN),ABS(XMAX)) EPSY=1.0D-8*MAX(ABS(YMIN),ABS(YMAX)) IF(EPSX.LE.0)EPSX=1.0D-8 IF(EPSY.LE.0)EPSY=1.0D-8 ENDIF *** Ensure that we have a range. IF(ABS(XMAX-XMIN).LE.EPSX)THEN IF(Y.GE.YMIN-EPSY.AND.Y.LE.YMAX+EPSY.AND. - ABS(XMAX+XMIN-2*X).LE.EPSX)THEN EDGE=.TRUE. ELSE EDGE=.FALSE. ENDIF RETURN ELSEIF(ABS(YMAX-YMIN).LE.EPSY)THEN IF(X.GE.XMIN-EPSX.AND.X.LE.XMAX+EPSX.AND. - ABS(YMAX+YMIN-2*Y).LE.EPSY)THEN EDGE=.TRUE. ELSE EDGE=.FALSE. ENDIF RETURN ENDIF *** Choose a point at "infinity". XINF=XMIN-ABS(XMAX-XMIN) YINF=YMIN-ABS(YMAX-YMIN) *** Loop over the edges counting intersections. NITER=0 20 CONTINUE NCROSS=0 DO 30 J=1,NPL * Flag points located on one of the edges. IF(ONLIND(XPL(1+MOD(J-1,NPL)),YPL(1+MOD(J-1,NPL)), - XPL(1+MOD(J,NPL)),YPL(1+MOD(J,NPL)),X,Y))THEN EDGE=.TRUE. RETURN ENDIF * Count mid-line intersects. IF(CROSSD(X,Y,XINF,YINF, - XPL(1+MOD(J-1,NPL)),YPL(1+MOD(J-1,NPL)), - XPL(1+MOD(J ,NPL)),YPL(1+MOD(J ,NPL))))NCROSS=NCROSS+1 * Ensure that the testing line doesn't cross a corner. IF(ONLIND(X,Y,XINF,YINF,XPL(J),YPL(J)))THEN XINF=XMIN-RNDUNI(1.0)*ABS(XMAX-XINF) YINF=YMIN+RNDUNI(-1.0)*ABS(YMAX-YINF) NITER=NITER+1 IF(NITER.LT.100)GOTO 20 PRINT *,' !!!!!! INTERD WARNING : Unable to verify'// - ' whether a point is internal; setting to "edge".' INSIDE=.FALSE. EDGE=.TRUE. * Produce a dump if requested. IF(LGSTOP)THEN OPEN(UNIT=12,FILE='interd.dat',STATUS='UNKNOWN') WRITE(12,*) EPSGX,EPSGY,EPSGZ,LEPSG WRITE(12,*) X,Y WRITE(12,*) NPL DO 40 I=1,NPL WRITE(12,*) I,XPL(I),YPL(I) 40 CONTINUE CLOSE(12) PRINT *,' ------ INTERD MESSAGE : Dump produced;'// - ' terminating program execution.' CALL QUIT ENDIF RETURN ENDIF 30 CONTINUE *** Set the INSIDE flag. IF(NCROSS.NE.2*(NCROSS/2))INSIDE=.TRUE. END +DECK,INTERP. SUBROUTINE INTERP(X,Y,C,N,XIN,YIN,IFAIL) *----------------------------------------------------------------------- * INTERP - A routine using the interpolation results of SPLINE in * order to give a y value corresponding to XIN. * VARIABLES : See SPLINE * REFERENCE : See SPLINE * (Last changed on 25/ 4/94.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. REAL X(MXLIST),Y(MXLIST),C(MXLIST) J=1 *** Set IFAIL to 0 : OK IFAIL=0 YIN=0.0 *** Determine the interval in which XIN is located. 10 CONTINUE IF(X(J).LE.XIN.AND.XIN.LE.X(J+1))THEN BETA=(Y(J+1)-Y(J))/(X(J+1)-X(J))- - (2.0*C(J)+C(J+1))*(X(J+1)-X(J))/6.0 GAMMA=C(J)/2.0 DELTA=(C(J+1)-C(J))/(6.0*(X(J+1)-X(J))) YIN=Y(J)+BETA*(XIN-X(J))+GAMMA*(XIN-X(J))**2+ - DELTA*(XIN-X(J))**3 ELSE J=J+1 IF(J.EQ.N)THEN PRINT *,' ###### INTERP ERROR : The ordinate ',XIN, - ' is out of the range (',X(1),',',X(N),').' IFAIL=1 RETURN ENDIF GOTO 10 ENDIF END +DECK,INTER2. SUBROUTINE INTER2(X,Y,C,N,XIN,YIN,IFAIL) *----------------------------------------------------------------------- * INTERP - A routine using the interpolation results of SPLIN2 in * order to give a y value corresponding to XIN. * VARIABLES : See SPLINE2 * REFERENCE : See SPLINE2 *----------------------------------------------------------------------- IMPLICIT DOUBLE PRECISION (A-H,O-Z) +SEQ,DIMENSIONS. DIMENSION X(MXLIST),Y(MXLIST),C(MXLIST) J=1 *** Set IFAIL to 0 : OK IFAIL=0 *** Determine the interval in which XIN is located. 10 CONTINUE IF(X(J).LE.XIN.AND.XIN.LE.X(J+1))THEN BETA=(Y(J+1)-Y(J))/(X(J+1)-X(J))- - (2.0*C(J)+C(J+1))*(X(J+1)-X(J))/6.0 GAMMA=C(J)/2.0 DELTA=(C(J+1)-C(J))/(6.0*(X(J+1)-X(J))) YIN=Y(J)+BETA*(XIN-X(J))+GAMMA*(XIN-X(J))**2+ - DELTA*(XIN-X(J))**3 ELSE J=J+1 IF(J.EQ.N)THEN PRINT *,' ###### INTER2 ERROR : The ordinate ',XIN, - ' is out of the range (',X(1),',',X(N),').' IFAIL=1 RETURN ENDIF GOTO 10 ENDIF END +DECK,INTUBE. SUBROUTINE INTUBE(X,Y,A,N,ILOC) *----------------------------------------------------------------------- * INTUBE - Determines whether a point is located inside a polygon. * ILOC is set to +1 if outside, 0 if inside and -1 if the * arguments are not valid. * (Last changed on 18/ 3/01.) *----------------------------------------------------------------------- implicit none +SEQ,CONSTANTS. REAL X,Y,A,PHI INTEGER N,ILOC *** Special case: x=y=0 IF(X.EQ.0.AND.Y.EQ.0)THEN ILOC=0 *** Special case: round tube. ELSEIF(N.EQ.0)THEN IF(X**2+Y**2.GT.A**2)THEN ILOC=1 ELSE ILOC=0 ENDIF *** Illegal number of edges. ELSEIF(N.LT.0.OR.N.EQ.1.OR.N.EQ.2)THEN PRINT *,' ###### INTUBE ERROR : Invalid number of'// - ' edges received (N=',N,').' ILOC=-1 *** Truely polygonal tubes. ELSE * Reduce angle to the first sector. PHI=ATAN2(Y,X) IF(PHI.LT.0.0)PHI=PHI+2*PI PHI=PHI-REAL(2)*PI*INT(0.5*N*PHI/PI)/REAL(N) * Compare the length to the local radius. IF((X**2+Y**2)*COS(PI/REAL(N)-PHI)**2.GT. - A**2*COS(PI/REAL(N))**2)THEN ILOC=1 ELSE ILOC=0 ENDIF ENDIF END +DECK,INVINT. SUBROUTINE INVINT(CIN,NCHA,XMIN,XMAX,EPS,XEPS,IORDER,IFAIL) *----------------------------------------------------------------------- * INVINT - Inverse interpolation to find XEPS such that P(X 0; no fit done.' IFAIL=1 RETURN ENDIF * Compute initial residuals. CALL F(X(I),A,VAL) R(I)=(Y(I)-VAL)/EY(I) NFC=NFC+1 * Compute initial maximum difference. IF(I.EQ.1)DIFFC=ABS(R(I)) IF(I.GT.1.AND.DIFFC.LT.ABS(R(I)))DIFFC=ABS(R(I)) * And compute initial chi2. CHI2=CHI2+R(I)**2 10 CONTINUE * Set initial parameter error and correction vectors. DO 50 I=1,N S(I)=0 EA(I)=0 50 CONTINUE *** Print a table of the input if debug is on. IF(LDEBUG)THEN WRITE(LUNOUT,'('' ++++++ LSQFIT DEBUG : Start of debug'', - '' output'',//,26X,''Number of input data points= '', - I4,//,30X,''I X(I) Y(I)'', - '' Weight Y-F(X)'')') M DO 30 I=1,M WRITE(LUNOUT,'(26X,I5,4(1X,E15.8))') - I,X(I),Y(I),EY(I),R(I) 30 CONTINUE WRITE(LUNOUT,'(26X,''Number of parameters to optimise ='', - I2/26X,''Initial parameter values:''/ - 30X,''I A(I)'')') N DO 40 I=1,N WRITE(LUNOUT,'(26X,I5,1X,E15.8)') I,A(I) 40 CONTINUE WRITE(LUNOUT,'(26X,''Initial CHI2 '',E12.5, - '', initial DIFF '',E12.5,/,26X,''required DIFF is '', - E12.5/)') CHI2,DIFFC,DIFF ENDIF *** Print some summary information if LFITPR is on. IF(LFITPR)THEN WRITE(LUNOUT,'(/'' MINIMISATION SUMMARY''/)') WRITE(LUNOUT,'('' Initial situation:'',/,5X,''largest '', - ''difference between field and target function : '', - E15.8)') DIFFC WRITE(LUNOUT,'(5X,''sum of squares of these differences '', - '' (chi-squared) : '',E15.8/)') CHI2 WRITE(LUNOUT,'('' Stopping criteria:'',/,5X,''difference'', - '' between field and target function less than : '', - E15.8)') DIFF WRITE(LUNOUT,'(5X,''the relative chi-squared variation'', - '' becomes less than : '',E15.8)') EPS WRITE(LUNOUT,'(5X,''the number of iterations exceeds the'', - '' maximum : '',I3/)') KMAX ENDIF *** Start optimising loop. DO 20 ITER=1,KMAX ** Check the stopping criteria: (1) max norm, (2) change in CHI2. IF((DIFFC.LT.DIFF).OR. - (ITER.GT.1.AND.ABS(CHI2L-CHI2).LT.EPS*CHI2))THEN IFAIL=0 IF(LDEBUG.AND.DIFFC.LT.DIFF)THEN WRITE(LUNOUT,'(26X,''Maximum difference stopping'', - '' criterion satisfied.'',/)') ELSEIF(LDEBUG)THEN WRITE(LUNOUT,'(26X,''Relative change in CHI2 has'', - ''dropped below '',E10.3,''.''/)') EPS ENDIF IF(LFITPR.AND.DIFFC.LT.DIFF)THEN WRITE(LUNOUT,'(/,'' The maximum difference stopping'', - '' criterion is satisfied.'')') ELSEIF(LFITPR)THEN WRITE(LUNOUT,'(/,'' The relative change in chi-'', - ''squared has dropped below the threshold.'')') ENDIF GOTO 600 ENDIF ** Calculate the derivative matrix. DO 100 J=1,N EPSDIF=EPS*(1+ABS(A(J))) A(J)=A(J)+EPSDIF/2 DO 110 I=1,M CALL F(X(I),A,D(I,J)) NFC=NFC+1 110 CONTINUE A(J)=A(J)-EPSDIF DO 120 I=1,M CALL F(X(I),A,VAL) D(I,J)=(D(I,J)-VAL)/(EPSDIF*EY(I)) NFC=NFC+1 120 CONTINUE A(J)=A(J)+EPSDIF/2 100 CONTINUE ** Invert the matrix in Householder style. DO 200 J=1,N SIGMA=0.0 DO 210 I=J,M SIGMA=SIGMA+D(I,J)**2 210 CONTINUE IF(SIGMA.EQ.0.OR.SQRT(SIGMA).LT.1E-8*ABS(D(J,J)))THEN PRINT *,' !!!!!! LSQFIT WARNING : Householder matrix'// - ' (nearly) singular; no further optimisation.' PRINT *,' Ensure the function'// - ' depends on the parameters' PRINT *,' and try to supply'// - ' reasonable starting values.' GOTO 600 ENDIF IF(D(J,J).LT.0.0)THEN SIGMA=SQRT(SIGMA) ELSE SIGMA=-SQRT(SIGMA) ENDIF BETA=1/(SIGMA*D(J,J)-SIGMA**2) D(J,J)=D(J,J)-SIGMA SUM=0 DO 220 I=J,M SUM=SUM+D(I,J)*R(I) 220 CONTINUE SUM=SUM*BETA DO 230 I=J,M R(I)=R(I)+SUM*D(I,J) 230 CONTINUE DO 240 K=J+1,N SUM=0 DO 250 I=J,M SUM=SUM+D(I,J)*D(I,K) 250 CONTINUE SUM=SUM*BETA DO 260 I=J,M D(I,K)=D(I,K)+D(I,J)*SUM 260 CONTINUE 240 CONTINUE D(J,J)=SIGMA 200 CONTINUE ** Solve the system of equations. DO 300 I=N,1,-1 SUM=0 DO 310 J=N,I+1,-1 SUM=SUM+D(I,J)*S(J) 310 CONTINUE S(I)=(R(I)-SUM)/D(I,I) 300 CONTINUE ** Generate some debugging output. IF(LDEBUG)THEN WRITE(LUNOUT,'(26X,''Correction vector in minimisation'', - '' loop '',I3)') ITER DO 320 I=1,N WRITE(LUNOUT,'(26X,I5,1X,E15.8)') I,S(I) 320 CONTINUE ENDIF ** Add part of the correction vector to the estimate to improve CHI2. CHI2L=CHI2 DO 400 I=1,N A(I)=A(I)+S(I)*2 400 CONTINUE CHI2=2.0*CHI2L DO 410 I=0,10 IF(CHI2.GT.CHI2L)THEN IF(ABS(CHI2L-CHI2).LT.EPS*CHI2)THEN IF(LDEBUG)WRITE(LUNOUT,'(26X,''Too little'', - '' improvement, reduction loop halted.'')') GOTO 440 ENDIF CHI2=0.0 DO 420 J=1,N A(J)=A(J)-S(J)/2**I 420 CONTINUE DO 430 J=1,M CALL F(X(J),A,VAL) R(J)=(Y(J)-VAL)/EY(J) NFC=NFC+1 CHI2=CHI2+R(J)**2 430 CONTINUE IF(LDEBUG)WRITE(LUNOUT,'(26X,''Reduction loop '',I2, - '' produces a CHI2 of '',E15.8)') I,CHI2 ELSE GOTO 440 ENDIF 410 CONTINUE 440 CONTINUE IF(LDEBUG)WRITE(LUNOUT,'(26X,''shortening the correction'', - '' vector by a factor of '',I4)') 2**(I-1) * Calculate the max norm. DIFFC=ABS(R(1)) DO 450 I=2,M IF(DIFFC.LT.ABS(R(I)))DIFFC=ABS(R(I)) 450 CONTINUE ** Print some debugging output. IF(LDEBUG)THEN WRITE(LUNOUT,'(26X, - ''Values of the parameters after the step'')') DO 500 I=1,N WRITE(LUNOUT,'(26X,I5,1X,E15.8)') I,A(I) 500 CONTINUE WRITE(LUNOUT,'(26X,''for which CHI2='',E15.8, - '' and DIFF='',E15.8/)') CHI2,DIFFC ENDIF ** And some logging output. IF(LFITPR)WRITE(LUNOUT,'('' Iteration '',I3,'': largest '', - ''deviation = '',E15.8,'', Chi2='',E15.8)') ITER,DIFFC,CHI2 *** End of optimisation loop. 20 CONTINUE IF(LFITPR)THEN WRITE(LUNOUT,'(/'' The maximum number of iterations has'', - '' been reached.'')') ELSE PRINT *,' !!!!!! LSQFIT WARNING : Maximum number of'// - ' iterations reached, stopping criteria not satisfied.' ENDIF *** End of fit, perform error calculation. 600 CONTINUE * Calculate the derivative matrix for the final settings. DO 800 J=1,N EPSDIF=EPS*(1+ABS(A(J))) A(J)=A(J)+EPSDIF/2 DO 810 I=1,M CALL F(X(I),A,D(I,J)) NFC=NFC+1 810 CONTINUE A(J)=A(J)-EPSDIF DO 820 I=1,M CALL F(X(I),A,VAL) D(I,J)=(D(I,J)-VAL)/(EPSDIF*EY(I)) NFC=NFC+1 820 CONTINUE A(J)=A(J)+EPSDIF/2 800 CONTINUE * Calculate the error matrix. DO 830 I=1,N DO 840 J=1,N DA(I,J)=0 DO 850 K=1,M DA(I,J)=DA(I,J)+D(K,I)*D(K,J) 850 CONTINUE 840 CONTINUE 830 CONTINUE * Compute the scaling factor for the errors. IF(M.GT.N)THEN SCALE=CHI2/DBLE(M-N) ELSE SCALE=1 ENDIF * Invert it to get the covariance matrix. CALL DINV(N,DA,MXFPAR,IR,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! LSQINV WARNING : Singular covariance'// - ' matrix ; no error calculation.' DO 860 I=1,N EA(I)=0 860 CONTINUE ELSE DO 870 I=1,N DO 880 J=1,N DA(I,J)=SCALE*DA(I,J) 880 CONTINUE EA(I)=SQRT(MAX(0.0D0,DA(I,I))) 870 CONTINUE ENDIF * Save array size NDA=N *** Print results. IF(LDEBUG)THEN WRITE(LUNOUT,'(26X,''Comparison between input and fit'',/, - 30X,''I X(I) Y(I)'', - '' F(X)'')') DO 610 I=1,M CALL F(X(I),A,VAL) NFC=NFC+1 WRITE(LUNOUT,'(26X,I5,3(1X,E15.8))') I,X(I),Y(I),VAL 610 CONTINUE WRITE(LUNOUT,'(/26X,''Number of function calls '',I4,/ - '' ++++++ LSQFIT DEBUG : End of debug output.'')') - NFC ENDIF IF(LFITPR)THEN WRITE(LUNOUT,'(/'' Final values of the fit parameters:''/ - '' Parameter Value Error''/)') DO 640 I=1,N WRITE(LUNOUT,'(2X,I9,2X,E15.8,2X,E15.8)') I,A(I),EA(I) 640 CONTINUE WRITE(LUNOUT,'(/'' The errors have been scaled by a'', - '' factor of '',E15.8,''.'')') SQRT(SCALE) WRITE(LUNOUT,'(/'' Covariance matrix:''/)') DO 620 I=1,N WRITE(LUNOUT,'(1X,8(1X,E15.8):(/17X,7(1X,E15.8)))') - (DA(I,J),J=1,N) 620 CONTINUE WRITE(LUNOUT,'(/'' Correlation matrix:''/)') DO 630 I=1,N DO 650 J=1,N IF(DA(I,I).GT.0.AND.DA(J,J).GT.0)THEN AUXPR(J)=DA(I,J)/SQRT(DA(I,I)*DA(J,J)) ELSE AUXPR(J)=0 ENDIF 650 CONTINUE WRITE(LUNOUT,'(1X,8(1X,F15.8):(/17X,7(1X,F15.8)))') - (AUXPR(J),J=1,N) 630 CONTINUE WRITE(LUNOUT,'(/'' Minimisation finished.'')') ENDIF END +DECK,LSQCOV. SUBROUTINE LSQCOV(COV,N) *----------------------------------------------------------------------- * LSQCOV - Returns the covariance matrix of the last fit * (Last updated on 23/ 5/11.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,LSQFITPAR. INTEGER N,I,J DOUBLE PRECISION COV(N,N) *** Check dimensions IF(N.LT.NDA)THEN PRINT *,' !!!!!! LSQCOV WARNING : Dimensions of receiving'// - ' array too small; no value returned.' ELSE DO 10 I=1,NDA DO 20 J=1,NDA COV(I,J)=DA(I,J) 20 CONTINUE 10 CONTINUE ENDIF END +DECK,MSNFIT. SUBROUTINE MSNFIT(X,Y,EY,N,LPRINT,LFITK3,AA,EA,IFAIL) *----------------------------------------------------------------------- * MSNFIT - Fits a Mathieson distribution. * (Last changed on 14/10/06.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. REAL X(*),Y(*),EY(*) DOUBLE PRECISION XX(MXLIST),YY(MXLIST),EEY(MXLIST), - AA(6),EA(6),S0,S1,S2,CHI2 INTEGER N,IFAIL,I,NUSE LOGICAL LPRINT,LFITK3 EXTERNAL MSNFUN *** Estimate fitting results. S0=0 S1=0 S2=0 NUSE=0 DO 10 I=1,N IF(Y(I).GT.0)NUSE=NUSE+1 S0=S0+Y(I) S1=S1+Y(I)*X(I) S2=S2+Y(I)*X(I)**2 XX(I)=X(I) YY(I)=Y(I) EEY(I)=EY(I) 10 CONTINUE *** Avoid divide by zero. IF(S0.LE.0)THEN PRINT *,' !!!!!! MSNFIT WARNING : Integrated contents'// - ' is not larger than zero; no fit.' IFAIL=1 RETURN ELSEIF(NUSE.LE.3)THEN PRINT *,' !!!!!! MSNFIT WARNING : Fewer than 4 non-zero'// - ' data points; no fit.' IFAIL=1 RETURN ELSEIF(AA(3).LE.0.AND..NOT.LFITK3)THEN PRINT *,' !!!!!! MSNFIT WARNING : K3 is to be fixed, but'// - ' its value is not > 0; no fit.' IFAIL=1 RETURN ENDIF *** Make a reasonable initial guess. AA(1)=S1/S0 AA(2)=S0 AA(4)=X(2)-X(1) AA(5)=X(1)-AA(4)/2 *** from Sigma = SQRT(MAX(0.0D0,(S2-S1**2/S0)/S0)) IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MSNFIT DEBUG : Guess'', - '' before fit: ''/ - 26X,''Centre: '',E15.8,'' [cm]''/ - 26X,''Normalisation: '',E15.8/ - 26X,''K3: '',E15.8/ - 26X,''Strip width: '',E15.8,'' [cm]''/ - 26X,''x Offset: '',E15.8,'' [cm]''/ - 26X,''Anode-cathode: '',E15.8,'' [cm]'')') AA *** Call LSQFIT to do the real fit. IF(LFITK3)THEN CALL LSQFIT(MSNFUN,AA,EA,3,XX,YY,EEY,N,200,0.01*AA(2)/N, - CHI2,1.0D-3,LPRINT,IFAIL) ELSE CALL LSQFIT(MSNFUN,AA,EA,2,XX,YY,EEY,N,200,0.01*AA(2)/N, - CHI2,1.0D-3,LPRINT,IFAIL) EA(3)=0 ENDIF END +DECK,MSNFUN. SUBROUTINE MSNFUN(X,A,F) *----------------------------------------------------------------------- * MSNFUN - Auxiliary function for fitting a Mathieson distribution. * (Last changed on 17/ 4/97.) *----------------------------------------------------------------------- implicit none +SEQ,CONSTANTS. DOUBLE PRECISION A(6),X,F,K1,K2,K3,K4,D,XC,L1,L2,FACTOR,XMIN, - STRIP,S *** Check for illegal values of K3. IF(A(3).LT.0)THEN F=0 RETURN ENDIF *** Compute the various K's. XC=A(1) FACTOR=A(2) K3=A(3) K2=PI*(1-SQRT(K3)/2)/2 K1=K2*SQRT(K3)/(4*ATAN(SQRT(K3))) K4=K1/(K2*SQRT(K3)) D=A(4) XMIN=A(5) S=A(6) *** Determine integration range. STRIP=DINT((X-XMIN)/D) IF(STRIP.LT.0.5)STRIP=STRIP-1 L1=((XMIN-XC)+STRIP*D)/S L2=((XMIN-XC)+(STRIP+1)*D)/S *** Compute function. F=2*FACTOR*K4*(ATAN(SQRT(K3)*TANH(K2*L2))- - ATAN(SQRT(K3)*TANH(K2*L1))) END +DECK,NORFIT. SUBROUTINE NORFIT(X,Y,EY,N,LPRINT,AA,EA,IFAIL) *----------------------------------------------------------------------- * NORFIT - Fits a Gaussian. * (Last changed on 25/ 2/97.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. REAL X(*),Y(*),EY(*),FACT,AVER,SIGMA DOUBLE PRECISION XX(MXLIST),YY(MXLIST),EEY(MXLIST), - AA(3),EA(3),S0,S1,S2,CHI2 INTEGER N,IFAIL,I,NUSE LOGICAL LPRINT EXTERNAL NORFUN *** Estimate fitting results. S0=0 S1=0 S2=0 NUSE=0 DO 10 I=1,N IF(Y(I).GT.0)NUSE=NUSE+1 S0=S0+Y(I) S1=S1+Y(I)*X(I) S2=S2+Y(I)*X(I)**2 XX(I)=X(I) YY(I)=Y(I) EEY(I)=EY(I) 10 CONTINUE *** Avoid divide by zero. IF(S0.LE.0)THEN FACT=0 AVER=0 SIGMA=0 IFAIL=1 PRINT *,' !!!!!! NORFIT WARNING : Integrated contents'// - ' too small for fit; no fit.' RETURN ELSEIF(NUSE.LE.3)THEN FACT=0 AVER=0 SIGMA=0 IFAIL=1 PRINT *,' !!!!!! NORFIT WARNING : Too few non-zero data'// - ' points; no fit.' RETURN ENDIF *** Make a reasonable initial guess. AA(1)=(X(N)-X(1))*S0/REAL(N) AA(2)=S1/S0 AA(3)=SQRT(MAX(0.0D0,(S2-S1**2/S0)/S0)) IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ NORFIT DEBUG : Guess'', - '' before fit: f/m/s='',3E15.8)') AA *** Call LSQFIT to do the real fit. CALL LSQFIT(NORFUN,AA,EA,3,XX,YY,EEY,N,200,0.01*AA(1)/N, - CHI2,1.0D-3,LPRINT,IFAIL) END +DECK,NORFUN. SUBROUTINE NORFUN(X,A,F) *----------------------------------------------------------------------- * NORFUN - Auxiliary function for fitting a Gaussian. * (Last changed on 22/ 5/95.) *----------------------------------------------------------------------- implicit none +SEQ,CONSTANTS. DOUBLE PRECISION A(*),X,F *** Avoid floating over and underflow. IF(ABS(X-A(2)).GT.5*ABS(A(3)).OR.A(3).EQ.0)THEN F=0.0 *** Otherwise evaluate the exponential. ELSE F=A(1)*EXP(-0.5*((X-A(2))/A(3))**2)/(SQRT(2*PI)*A(3)) ENDIF END +DECK,NORRAN,IF=NAGNUM. SUBROUTINE NORRAN(XRAN) *----------------------------------------------------------------------- * NORRAN - Replaces the CERN library routine NORRAN (V101) with its * NAG equivalent G05DDF. * (Last changed on 8/ 9/98.) *----------------------------------------------------------------------- implicit none REAL XRAN,DUMMY DOUBLE PRECISION G05DDF EXTERNAL G05DDF *** Manipulate XRAN to avoid optimisation. DUMMY=XRAN+2.0 *** Call the NAG procedure. XRAN=REAL(G05DDF(0.0D0,1.0D0)) END +DECK,ONLINE. LOGICAL FUNCTION ONLINE(X1S,Y1S,X2S,Y2S,US,VS) *----------------------------------------------------------------------- * ONLINE - Determines whether a point (U,V) lies on the straight lines * (X1,Y1) to (X2,Y2). * (Last changed on 22/ 9/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PARAMETERS. DOUBLE PRECISION X1,X2,Y1,Y2,U,V,XC,YC,XL,EPSX,EPSY REAL X1S,Y1S,X2S,Y2S,US,VS *** Convert input (single precision) variables to double precision. X1=DBLE(X1S) X2=DBLE(X2S) Y1=DBLE(Y1S) Y2=DBLE(Y2S) U=DBLE(US) V=DBLE(VS) *** Set tolerances. IF(LEPSG)THEN EPSX=EPSGX EPSY=EPSGY C print *,' Using set tolerances: ',epsx,epsy ELSE EPSX=1.0D-5*MAX(ABS(X1),ABS(X2),ABS(U)) EPSY=1.0D-5*MAX(ABS(Y1),ABS(Y2),ABS(V)) IF(EPSX.LE.0)EPSX=1.0D-5 IF(EPSY.LE.0)EPSY=1.0D-5 C print *,' Setting tolerances: ',epsx,epsy ENDIF * Verify the tolerances. IF(EPSX.LE.0.OR.EPSY.LE.0)THEN PRINT *,' !!!!!! ONLINE WARNING : Tolerances not'// - ' > 0; returning False.' ONLINE=.FALSE. RETURN ENDIF *** Point to be examined coincides with start or end, IF((ABS(X1-U).LE.EPSX.AND.ABS(Y1-V).LE.EPSY).OR. - (ABS(X2-U).LE.EPSX.AND.ABS(Y2-V).LE.EPSY))THEN ONLINE=.TRUE. RETURN *** The line (X1,Y1) to (X2,Y2) is in fact a point. ELSEIF(ABS(X1-X2).LE.EPSX.AND.ABS(Y1-Y2).LE.EPSY)THEN ONLINE=.FALSE. RETURN *** (U,V) is nearer to (X1,Y1). ELSEIF(ABS(U-X1)+ABS(V-Y1).LT.ABS(U-X2)+ABS(V-Y2))THEN C print *,' Nearer to point 1' XL=((U-X1)*(X2-X1)+(V-Y1)*(Y2-Y1))/((X2-X1)**2+(Y2-Y1)**2) IF(XL.LT.0.0D0)THEN XC=X1 YC=Y1 ELSEIF(XL.GT.1.0D0)THEN XC=X2 YC=Y2 ELSE XC=X1+XL*(X2-X1) YC=Y1+XL*(Y2-Y1) ENDIF *** (U,V) is nearer to (X2,Y2). ELSE C print *,' Nearer to point 2' XL=((U-X2)*(X1-X2)+(V-Y2)*(Y1-Y2))/((X2-X1)**2+(Y2-Y1)**2) IF(XL.LT.0.0D0)THEN XC=X2 YC=Y2 ELSEIF(XL.GT.1.0D0)THEN XC=X1 YC=Y1 ELSE XC=X2+XL*(X1-X2) YC=Y2+XL*(Y1-Y2) ENDIF ENDIF C print *,' Nearest point: ',xc,yc *** See whether the point is on the line. IF(ABS(U-XC).LT.EPSX.AND.ABS(V-YC).LT.EPSY)THEN ONLINE=.TRUE. ELSE ONLINE=.FALSE. ENDIF END +DECK,ONLIND. LOGICAL FUNCTION ONLIND(X1,Y1,X2,Y2,U,V) *----------------------------------------------------------------------- * ONLIND - Determines whether a point (U,V) lies on the straight lines * (X1,Y1) to (X2,Y2). * (Last changed on 22/ 9/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PARAMETERS. DOUBLE PRECISION X1,X2,Y1,Y2,U,V,XC,YC,XL,EPSX,EPSY *** Set tolerances. IF(LEPSG)THEN EPSX=EPSGX EPSY=EPSGY C print *,' Using set tolerances: ',epsx,epsy ELSE EPSX=1.0D-10*MAX(ABS(X1),ABS(X2),ABS(U)) EPSY=1.0D-10*MAX(ABS(Y1),ABS(Y2),ABS(V)) IF(EPSX.LE.0)EPSX=1.0D-10 IF(EPSY.LE.0)EPSY=1.0D-10 C print *,' Setting tolerances: ',epsx,epsy ENDIF * Verify the tolerances. IF(EPSX.LE.0.OR.EPSY.LE.0)THEN PRINT *,' !!!!!! ONLIND WARNING : Tolerances not'// - ' > 0; returning False.' ONLIND=.FALSE. RETURN ENDIF *** Point to be examined coincides with start or end, IF((ABS(X1-U).LE.EPSX.AND.ABS(Y1-V).LE.EPSY).OR. - (ABS(X2-U).LE.EPSX.AND.ABS(Y2-V).LE.EPSY))THEN ONLIND=.TRUE. RETURN *** The line (X1,Y1) to (X2,Y2) is in fact a point. ELSEIF(ABS(X1-X2).LE.EPSX.AND.ABS(Y1-Y2).LE.EPSY)THEN ONLIND=.FALSE. RETURN *** (U,V) is nearer to (X1,Y1). ELSEIF(ABS(U-X1)+ABS(V-Y1).LT.ABS(U-X2)+ABS(V-Y2))THEN C print *,' Nearer to point 1' XL=((U-X1)*(X2-X1)+(V-Y1)*(Y2-Y1))/((X2-X1)**2+(Y2-Y1)**2) IF(XL.LT.0.0D0)THEN XC=X1 YC=Y1 ELSEIF(XL.GT.1.0D0)THEN XC=X2 YC=Y2 ELSE XC=X1+XL*(X2-X1) YC=Y1+XL*(Y2-Y1) ENDIF *** (U,V) is nearer to (X2,Y2). ELSE C print *,' Nearer to point 2' XL=((U-X2)*(X1-X2)+(V-Y2)*(Y1-Y2))/((X2-X1)**2+(Y2-Y1)**2) IF(XL.LT.0.0D0)THEN XC=X2 YC=Y2 ELSEIF(XL.GT.1.0D0)THEN XC=X1 YC=Y1 ELSE XC=X2+XL*(X1-X2) YC=Y2+XL*(Y1-Y2) ENDIF ENDIF C print *,' Nearest point: ',xc,yc *** See whether the point is on the line. IF(ABS(U-XC).LT.EPSX.AND.ABS(V-YC).LT.EPSY)THEN ONLIND=.TRUE. ELSE ONLIND=.FALSE. ENDIF END +DECK,OUTFMT. SUBROUTINE OUTFMT(VAL,IFMT,STRING,NC,ALIGN) *----------------------------------------------------------------------- * OUTFMT - Takes care of output formatting. * VARIABLES : VAL : The number to be formatted. * IFMT : Format code, 0=undefined, 1=string, * 2=number, 3=logical, 4=histogram. * STRING : Output string, use only first NC chars. * (Last changed on 9/ 4/00.) *----------------------------------------------------------------------- implicit none CHARACTER*(*) STRING,ALIGN INTEGER NC,IFMT,I,IFAIL REAL VAL *** Initialise the string. STRING=' ' *** Unitialised variables. IF(IFMT.EQ.0)THEN IF(LEN(STRING).LT.4)THEN STRING='?' ELSE STRING='Nill' ENDIF *** Take care of strings. ELSEIF(IFMT.EQ.1)THEN CALL STRBUF('READ',NINT(VAL),STRING,NC,IFAIL) RETURN *** Take care of numbers. ELSEIF(IFMT.EQ.2)THEN CALL OUTFM2(VAL,STRING) *** Take care of logicals. ELSEIF(IFMT.EQ.3)THEN IF(LEN(STRING).LT.5)THEN STRING='***' ELSEIF(NINT(VAL).EQ.0)THEN STRING='False' ELSEIF(NINT(VAL).EQ.1)THEN STRING='True' ELSE STRING='???' ENDIF *** Take care of histograms. ELSEIF(IFMT.EQ.4)THEN STRING='Histogram' *** Take care of matrices. ELSEIF(IFMT.EQ.5)THEN CALL OUTFM5(VAL,STRING) *** Only other format is real (2). ELSE PRINT *,' ###### OUTFMT ERROR : Invalid format code'// - ' received: ',IFMT,'; program bug, please report.' STRING='???' NC=3 RETURN ENDIF *** Count the length, removing blanks for left alignment. IF(ALIGN.EQ.'LEFT')THEN NC=0 DO 10 I=1,LEN(STRING) IF(STRING(I:I).NE.' ')THEN NC=NC+1 IF(STRING(I:I).EQ.'%')THEN STRING(NC:NC)=' ' ELSE STRING(NC:NC)=STRING(I:I) ENDIF ENDIF 10 CONTINUE IF(NC.LT.LEN(STRING)) - STRING(MIN(LEN(STRING),NC+1):LEN(STRING))=' ' * For right alignment. ELSEIF(ALIGN.EQ.'RIGHT')THEN NC=0 DO 80 I=LEN(STRING),1,-1 IF(STRING(I:I).NE.' ')THEN NC=NC+1 IF(STRING(I:I).EQ.'%')THEN STRING(LEN(STRING)-NC+1:LEN(STRING)-NC+1)=' ' ELSE STRING(LEN(STRING)-NC+1:LEN(STRING)-NC+1)= - STRING(I:I) ENDIF ENDIF 80 CONTINUE IF(NC.LT.LEN(STRING)) - STRING(1:MAX(1,LEN(STRING)-NC))=' ' * Invalid alignment code. ELSE STRING='???' NC=3 PRINT *,' ###### OUTFMT ERROR : Received invalid'// - ' alignment code: ',ALIGN,'.' ENDIF END +DECK,OUTFM2. SUBROUTINE OUTFM2(VAL,STRING) *----------------------------------------------------------------------- * OUTFM2 - Takes care of formatting a real. * VARIABLES : VAL : The number to be formatted. * STRING : Output string, use only first NC chars. * (Last changed on 26/ 5/97.) *----------------------------------------------------------------------- implicit none CHARACTER*(*) STRING CHARACTER*13 AUX CHARACTER*7 REST CHARACTER*8 FMT CHARACTER SIGN,FIRST INTEGER I,J,NOUT,IEXP REAL VAL *** Initialise the string. STRING=' ' *** Carry on for reals, first handle the special value 0. IF(VAL.EQ.0)THEN STRING='0' *** Integer numbers less than 1E7. ELSEIF(ABS(VAL).LT.1.0E7.AND. - ABS(VAL-ANINT(VAL)).LT.1.0E-5*ABS(VAL))THEN IF(LEN(STRING).LT.10)THEN STRING='***' ELSE WRITE(STRING,'(I10)') NINT(VAL) ENDIF *** Non-integer numbers without exponent, above 1. ELSEIF(ABS(VAL).LT.1.0E6.AND.ABS(VAL).GE.1.0)THEN IF(LEN(STRING).LT.8)THEN STRING='***' ELSE WRITE(FMT,'(''(F8.'',I1,'' )'')') - 5-INT(LOG10(ABS(VAL))) WRITE(STRING,FMT) VAL DO 40 I=8,1,-1 IF(STRING(I:I).EQ.'0')THEN STRING(I:I)=' ' ELSEIF(STRING(I:I).EQ.'.')THEN STRING(I:I)=' ' GOTO 50 ELSEIF(STRING(I:I).NE.' ')THEN GOTO 50 ENDIF 40 CONTINUE 50 CONTINUE ENDIF *** Non-integer format less than 1. ELSEIF(ABS(VAL).LT.1.AND.ABS(VAL).GT.1E-5)THEN IF(LEN(STRING).LT.13)THEN STRING='***' ELSE WRITE(FMT,'(''(F'',I2,''.'',I2,'')'')') - 8-INT(LOG10(ABS(VAL))),5-INT(LOG10(ABS(VAL))) WRITE(STRING,FMT) VAL DO 60 I=13,1,-1 IF(STRING(I:I).EQ.'0')THEN STRING(I:I)=' ' ELSEIF(STRING(I:I).EQ.'.')THEN STRING(I:I)=' ' GOTO 70 ELSEIF(STRING(I:I).NE.' ')THEN GOTO 70 ENDIF 60 CONTINUE 70 CONTINUE ENDIF *** Anything else. ELSE IF(LEN(STRING).LT.13)THEN STRING='***' ELSE WRITE(AUX,'(E13.6)') VAL IF(VAL.GE.0)THEN SIGN=' ' ELSE SIGN='-' ENDIF IF(INDEX('+-0123456789',AUX(11:11)).EQ.0.OR. - INDEX('0123456789',AUX(12:12)).EQ.0.OR. - INDEX('0123456789',AUX(13:13)).EQ.0)THEN STRING=AUX ELSE READ(AUX,'(3X,A1,A5,1X,I3)') FIRST,REST,IEXP DO 20 I=5,1,-1 IF(REST(I:I).NE.'0')GOTO 30 IF(REST(I:I).EQ.'0')REST(I:I)=' ' 20 CONTINUE 30 CONTINUE WRITE(STRING,'(A1,A1,''.'',A5,''E'',I3)') - SIGN,FIRST,REST,IEXP-1 IF(IEXP.EQ.1)STRING(9:)=' ' IF(REST.EQ.' ')STRING(3:3)=' ' ENDIF ENDIF ENDIF *** See whether the expression starts with a dot. DO 110 I=1,LEN(STRING) * If it does, try to shift all the rest and add a '0'. IF(STRING(I:I).EQ.'.')THEN DO 120 J=LEN(STRING)-1,I,-1 STRING(J+1:J+1)=STRING(J:J) STRING(J:J)=' ' 120 CONTINUE IF(STRING(I:I).EQ.' ')STRING(I:I)='0' GOTO 130 * If the string starts with something else, leave search. ELSEIF(INDEX(' +-',STRING(I:I)).EQ.0)THEN GOTO 130 ENDIF 110 CONTINUE 130 CONTINUE *** Remove blanks. NOUT=0 DO 100 I=1,LEN(STRING) IF(STRING(I:I).NE.' ')THEN IF(NOUT.GE.LEN(STRING))THEN STRING='***' RETURN ENDIF NOUT=NOUT+1 IF(NOUT.NE.I)THEN STRING(NOUT:NOUT)=STRING(I:I) STRING(I:I)=' ' ENDIF ENDIF 100 CONTINUE END +DECK,OUTFM5. SUBROUTINE OUTFM5(VAL,STRING) *----------------------------------------------------------------------- * OUTFM5 - Takes care of formatting a matrix. * VARIABLES : VAL : Reference to the matrix to be formatted. * STRING : Output string. * (Last changed on 9/ 4/96.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,MATDATA. CHARACTER*(*) STRING CHARACTER*20 AUX REAL VAL *** Initialise the string. STRING=' ' *** Matrix reference. IREF=NINT(VAL) *** Locate the matrix. DO 10 I=1,MXMAT IF(MREF(I).EQ.IREF)THEN ISLOT=I GOTO 20 ENDIF 10 CONTINUE * Issue warning if this doesn't exist. IF(LEN(STRING).GE.18)THEN STRING='<%unknown%matrix%>' ELSE STRING='?' ENDIF RETURN 20 CONTINUE *** If the matrix is not suitable for formatting, show dimensions. IF(MDIM(ISLOT).GT.1.AND.MLEN(ISLOT).GT.1)THEN * Format the number of dimensions. CALL OUTFM2(REAL(MDIM(ISLOT)),AUX) * Get the length. DO 30 I=LEN(AUX),1,-1 IF(AUX(I:I).NE.' ')THEN NC=I GOTO 70 ENDIF 30 CONTINUE NC=1 70 CONTINUE * Format the description. IF(LEN(STRING).GE.NC+7)THEN STRING=AUX(1:NC)//'-Matrix' ELSE STRING='***' ENDIF RETURN ENDIF *** If the string is too short, no way to format. IF(LEN(STRING).LT.5)THEN STRING='***' RETURN ENDIF *** Format the first bit of the matrix. STRING(1:1)='(' NCSTR=1 DO 40 I=1,MLEN(ISLOT) * Format an element. CALL OUTFM2(MVEC(MORG(ISLOT)+I),AUX) * Get the length. DO 50 J=LEN(AUX),1,-1 IF(AUX(J:J).NE.' ')THEN NC=J GOTO 60 ENDIF 50 CONTINUE NC=1 60 CONTINUE * Add it to the string. IF(LEN(STRING).GE.NCSTR+NC+2)THEN STRING(NCSTR+1:NCSTR+NC+2)=AUX(1:NC)//',%' NCSTR=NCSTR+NC+2 ELSEIF(LEN(STRING).GE.NCSTR+4)THEN STRING(NCSTR+1:NCSTR+4)='...)' NCSTR=NCSTR+4 RETURN ELSE STRING(LEN(STRING)-3:)='***)' NCSTR=LEN(STRING) RETURN ENDIF 40 CONTINUE IF(NCSTR.GE.2)STRING(NCSTR-1:NCSTR)=') ' END +DECK,POLFIT. SUBROUTINE POLFIT(X,Y,EY,N,LPRINT,AA,EA,NA,IFAIL) *----------------------------------------------------------------------- * POLFIT - Fits a Polynomial * (Last changed on 9/ 6/96.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. INTEGER NNA,IWORK(MXFPAR) COMMON /PFDAT/ NNA REAL X(*),Y(*),EY(*) DOUBLE PRECISION XX(MXLIST),YY(MXLIST),EEY(MXLIST), - AA(*),EA(*),CHI2,D(MXFPAR,MXFPAR+2),AUX,YSUM INTEGER N,NA,IFAIL LOGICAL LPRINT EXTERNAL POLFUN *** Preset the error flag. IFAIL=1 *** Debugging and identification output. IF(LIDENT)PRINT *,' /// ROUTINE POLFIT ///' *** Check dimensions. IF(NA.GT.MXFPAR.OR.N.GT.MXLIST)THEN PRINT *,' !!!!!! POLFIT WARNING : Dimensions of the'// - ' problem exceed compilation parameters; no fit.' RETURN ENDIF *** Copy the vectors. YSUM=0 DO 100 I=1,N XX(I)=DBLE(X(I)) YY(I)=DBLE(Y(I)) YSUM=YSUM+ABS(YY(I)) EEY(I)=DBLE(EY(I)) 100 CONTINUE *** Estimate fitting results, first fill matrix. DO 10 I=0,2*(NA-1) IF(I.EQ.0)THEN AUX=N ELSE AUX=0 DO 20 J=1,N AUX=AUX+XX(J)**I 20 CONTINUE ENDIF DO 30 J=1,NA K=I+2-J IF(K.LT.1.OR.K.GT.NA)GOTO 30 D(J,K)=AUX 30 CONTINUE 10 CONTINUE * Left hand side. DO 40 I=0,NA-1 AUX=0 DO 50 J=1,N IF(I.EQ.0)THEN AUX=AUX+YY(J) ELSE AUX=AUX+YY(J)*XX(J)**I ENDIF 50 CONTINUE D(I+1,MXFPAR+1)=AUX 40 CONTINUE * Now solve the equation. CALL DEQN(NA,D,MXFPAR,IWORK,IFAIL1,1,D(1,MXFPAR+1)) * Check error condition. IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! POLFIT WARNING : Failure to obtain'// - ' a first estimate of the solution; not solved.' RETURN ENDIF * Copy the solution. DO 60 I=1,NA AA(I)=D(I,MXFPAR+1) 60 CONTINUE * Debugging output. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ POLFIT DEBUG : Guess'', - '' before fit: a_i='',3E15.8,(/26X,5E15.8:))') - (AA(I),I=1,NA) *** Now carry out the fit. NNA=NA CALL LSQFIT(POLFUN,AA,EA,NA,XX,YY,EEY,N,200,0.01*YSUM/N, - CHI2,1.0D-3,LPRINT,IFAIL) END +DECK,POLFUN. SUBROUTINE POLFUN(X,A,F) *----------------------------------------------------------------------- * POLFUN - Auxiliary function for fitting a polynomial. * (Last changed on 9/ 5/96.) *----------------------------------------------------------------------- DOUBLE PRECISION A(*),X,F INTEGER NNA COMMON /PFDAT/ NNA *** Sum the polynomial. F=0 DO 10 I=NNA,1,-1 F=F*X+A(I) 10 CONTINUE END +DECK,PROINT. SUBROUTINE PROINT(NAME,NFIELD,LUN) *----------------------------------------------------------------------- * PROINT - Initialises progress printing. * PROFLD - Sets field names * PRORED - Changes the number of fields. * PROSTA - Prints current status. * PROEND - Ends progress printing. * (Last changed on 7/ 1/09). *----------------------------------------------------------------------- implicit none +SEQ,PRINTPLOT. INTEGER MXFLD PARAMETER(MXFLD=10) CHARACTER*130 OUT CHARACTER*(*) NAME CHARACTER*20 FLD(MXFLD),FAC INTEGER NFIELD,NCFLD(MXFLD),MFLD,NFLD,NCFAC,NCOUT,IXFLD(MXFLD), - LUN,LUNPRO,I,IFLD REAL X,XRNG(MXFLD),RANGE LOGICAL CHANGE +SELF,IF=SAVE. SAVE FLD,NCFLD,MFLD,NFLD,IXFLD,FAC,NCFAC,LUNPRO,XRNG +SELF. DATA NFLD/0/,MFLD/0/,LUNPRO/6/,NCFAC/7/ DATA FAC/'Unknown '/ *** Check setting of nfield. IF(NFIELD.LT.1.OR.NFIELD.GT.MXFLD)THEN PRINT *,' !!!!!! PROINT WARNING : Received an incorrect'// - ' number of fields ; program bug - please report.' RETURN ENDIF * Keep the routine name. FAC=NAME NCFAC=MIN(LEN(NAME),LEN(FAC)) * Initialise the field names. DO 10 I=1,NFIELD FLD(I)=' ' NCFLD(I)=0 IXFLD(I)=0 10 CONTINUE NFLD=NFIELD MFLD=0 * Keep the logical unit number. LUNPRO=LUN * Write out a blank line or a synchronisation record. IF(LPROPR)THEN IF(LSYNCH)THEN WRITE(6,'('' >>>>>> progress init '',I5,'' '',A)') - NFLD,FAC(1:NCFAC) ELSE WRITE(LUNPRO,'('' '')') ENDIF ENDIF * That's it for this entry. RETURN *** Update a field. ENTRY PROFLD(IFLD,NAME,RANGE) * Check validity of the field index. IF(IFLD.LT.1.OR.IFLD.GT.NFLD.OR.NFLD.LT.1)THEN PRINT *,' !!!!!! PROFLD WARNING : Received an incorrect'// - ' field index; program bug - please report.' RETURN ENDIF * Update the latest received field. MFLD=MAX(MFLD,IFLD) * Otherwise store this field name. FLD(IFLD)=NAME NCFLD(IFLD)=MIN(LEN(NAME),LEN(FLD(IFLD))) XRNG(IFLD)=RANGE * Reset the progress counter for this field to 0. IXFLD(IFLD)=0 * Synchronisation records. IF(LSYNCH)WRITE(6,'('' >>>>>> progress field '',I5,'' '', - E15.8,'' '',A)') IFLD,XRNG(IFLD),FLD(IFLD)(1:NCFLD(IFLD)) * That's it for this entry. RETURN *** Reduce or increase the number of fields. ENTRY PRORED(NFIELD) * Check validity of the field index. IF(NFIELD.LE.0)THEN PRINT *,' !!!!!! PRORED WARNING : Received an incorrect'// - ' new number of fields; program bug - please report.' ELSE IF(LSYNCH)WRITE(6,'('' >>>>>> progress count '',I5, - '' '',I4)') NFIELD,NFLD DO 15 I=NFLD+1,NFIELD FLD(I)=' ' NCFLD(I)=0 IXFLD(I)=0 15 CONTINUE NFLD=NFIELD MFLD=MIN(MFLD,NFIELD) ENDIF * All for this entry. RETURN *** Print current status. ENTRY PROSTA(IFLD,X) * Assume no change. CHANGE=.FALSE. * Check validity of the field index. IF(IFLD.LT.1.OR.IFLD.GT.NFLD.OR.NFLD.LT.1)THEN PRINT *,' !!!!!! PROSTA WARNING : Received an incorrect'// - ' field index; program bug - please report.' RETURN ENDIF * Update the counter for the field and check for changes. IF(XRNG(IFLD).GT.0)THEN IF(IXFLD(IFLD).NE. - MAX(0,MIN(10,INT(10*X/XRNG(IFLD)+0.0001)))) - CHANGE=.TRUE. IXFLD(IFLD)=MAX(0,MIN(10,INT(10*X/XRNG(IFLD)+0.0001))) IF(LSYNCH)WRITE(6,'('' >>>>>> progress set '',I5, - '' '',E15.8)') IFLD,X/XRNG(IFLD) ELSE CHANGE=.TRUE. IXFLD(IFLD)=-1 IF(LSYNCH)WRITE(6,'('' >>>>>> progress set '',I5, - '' working'')') IFLD ENDIF * Reset all lower counters. DO 20 I=IFLD+1,NFLD IF(XRNG(I).GT.0)THEN IXFLD(I)=0 IF(LSYNCH)WRITE(6,'('' >>>>>> progress set '',I5, - '' 0'')') IFLD ELSE IXFLD(I)=-1 IF(LSYNCH)WRITE(6,'('' >>>>>> progress set '',I5, - '' working'')') IFLD ENDIF 20 CONTINUE * In case of synchronisation output, this is all. IF(LSYNCH)RETURN * Also return if there is no change. IF(.NOT.CHANGE)RETURN * Print the current status. OUT=FAC(1:NCFAC)//': ' NCOUT=NCFAC+2 DO 30 I=1,MFLD IF(NCOUT+14.GT.LEN(OUT))THEN IF(NCOUT+2.LE.LEN(OUT))THEN OUT(NCOUT-1:NCOUT+2)=' ...' NCOUT=NCOUT+3 ENDIF GOTO 40 ENDIF IF(NCFLD(I).GT.0)THEN OUT(NCOUT+1:NCOUT+NCFLD(I))=FLD(I)(1:NCFLD(I))//' ' NCOUT=NCOUT+NCFLD(I)+1 ENDIF IF(IXFLD(I).EQ.-1)THEN IF(NCOUT.GT.1)NCOUT=NCOUT-1 OUT(NCOUT+1:NCOUT+13)=', ' NCOUT=NCOUT+2 ELSEIF(IXFLD(I).EQ.0)THEN OUT(NCOUT+1:NCOUT+14)='[ Starting ], ' NCOUT=NCOUT+14 ELSEIF(IXFLD(I).EQ.20)THEN OUT(NCOUT+1:NCOUT+14)='[ Finished ], ' NCOUT=NCOUT+14 ELSE OUT(NCOUT+1:NCOUT+14)='[..........], ' IF(IXFLD(I).GE.2) - OUT(NCOUT+2:NCOUT+IXFLD(I))='--------------------' OUT(NCOUT+IXFLD(I)+1:NCOUT+IXFLD(I)+1)='>' NCOUT=NCOUT+14 ENDIF 30 CONTINUE IF(NCOUT.GT.2)THEN OUT(NCOUT-1:NCOUT)='. ' NCOUT=NCOUT-1 ENDIF 40 CONTINUE +SELF,IF=IBMRT. IF(LPROPR)WRITE(LUNPRO,'(A1,'' '',A)',ADVANCE='NO') - CHAR(13),OUT(1:MAX(78,NCOUT)) +SELF,IF=SUN,HPUX,LINUX,MACOSX,BOINC,DECS. IF(LPROPR)WRITE(LUNPRO,'(A1,'' '',A,$)') - CHAR(13),OUT(1:MAX(78,NCOUT)) +SELF,IF=-IBMRT,IF=-SUN,IF=-HPUX,IF=-LINUX,IF=-MACOSX,IF=-BOINC,IF=-DECS. IF(LPROPR)WRITE(LUNPRO,'(''+ '',A)') OUT(1:MAX(78,NCOUT)) +SELF. * That's all for this entry. RETURN *** Say that we're done. ENTRY PROEND IF(LSYNCH)THEN WRITE(6,'('' >>>>>> progress end'')') ELSE OUT=' ' OUT(1:NCFAC)=FAC(1:NCFAC) OUT(NCFAC+1:NCFAC+12)=': Completed.' +SELF,IF=IBMRT,SUN,HPUX,LINUX,MACOSX,BOINC,DECS. IF(LPROPR)WRITE(LUNPRO,'(A1,'' '',A)') - CHAR(13),OUT(1:MAX(78,NCFAC+12)) +SELF,IF=-IBMRT,IF=-SUN,IF=-HPUX,IF=-LINUX,IF=-MACOSX,IF=-BOINC,IF=-DECS. IF(LPROPR)WRITE(LUNPRO,'(''+ '',A)') OUT(1:MAX(78,NCFAC+12)) +SELF. ENDIF *** Reset the fields flag. NFLD=0 END +DECK,RNDCOV. SUBROUTINE RNDCOV(COV,VEC,IFAIL) *----------------------------------------------------------------------- * RNDCOV - Random 3D Gaussian numbers according to the covariance * matrix COV. Uses the Cholesky decomposition of COV into * CHOL CHOL' = COV and then multiplies a normal Gaussian * vector with the Cholesky root CHOL. * Covariance has to be positive semi-definite. * Uses pivot search for the diagonal of L. * Variables: COV : Covariance matrix * VEC : N-Vector of random numbers. * IFAIL : Set to 1 if COV not pos. def. * (Last changed on 28/ 1/02.) *----------------------------------------------------------------------- implicit none INTEGER N PARAMETER(N=3) REAL COV(N,N),CHOL(N,N),VEC(N),VNOR(N),SUM,SUMAUX,RNDNOR,EPS C real check(n,n) INTEGER I,J,K,IFAIL,P(N),IP,IAUX EXTERNAL RNDNOR *** Initialise Lower diagonal matrix, output vector and tolerance. EPS=0 DO 10 I=1,N DO 20 J=1,N CHOL(I,J)=0 IF(ABS(COV(I,J)).GT.EPS)EPS=ABS(COV(I,J)) 20 CONTINUE VEC(I)=0 10 CONTINUE EPS=1E-5*EPS *** Initialise the pivot vector. DO 100 I=1,N P(I)=I 100 CONTINUE *** Cholesky decomposition. DO 30 I=1,N * Find the p element. IP=I SUM=COV(P(I),P(I)) DO 130 K=1,I-1 SUM=SUM-CHOL(P(I),P(K))**2 130 CONTINUE DO 110 J=I+1,N SUMAUX=COV(P(J),P(J)) DO 140 K=1,I-1 SUMAUX=SUMAUX-CHOL(P(J),P(K))**2 140 CONTINUE IF(SUMAUX.GT.SUM)THEN SUM=SUMAUX IP=J ENDIF 110 CONTINUE * Reorder the p vector. IAUX=P(IP) DO 120 J=IP,I+1,-1 P(J)=P(J-1) 120 CONTINUE P(I)=IAUX * Verify that the matrix is positive-definite. IF(SUM.LE.-EPS)THEN PRINT *,' !!!!!! RNDCOV WARNING : Covariance matrix is'// - ' not positive definite; no random numbers.' IFAIL=1 RETURN * If semi-positive definite, set the remainder to 0. ELSEIF(ABS(SUM).LE.EPS)THEN C print *,' Semi positive definite matrix, sum=',sum GOTO 50 ENDIF * Assign diagonal elements. CHOL(P(I),P(I))=SQRT(SUM) * Compute off-diagonal elements. DO 40 J=I+1,N SUM=COV(P(J),P(I)) DO 60 K=1,I-1 SUM=SUM-CHOL(P(J),P(K))*CHOL(P(I),P(K)) 60 CONTINUE CHOL(P(J),P(I))=SUM/CHOL(P(I),P(I)) 40 CONTINUE 30 CONTINUE *** Multiply L with a normal Gaussian vector. 50 CONTINUE DO 70 I=1,N VNOR(I)=RNDNOR(0.0,1.0) 70 CONTINUE DO 80 I=1,N VEC(I)=0 DO 90 J=1,N VEC(I)=VEC(I)+CHOL(I,J)*VNOR(J) 90 CONTINUE 80 CONTINUE *** Seems to have worked. IFAIL=0 * Check the product. C print *,' Pivot vector: ',p C print *,' L' C do i=1,N C print '(10f12.5)',(chol(i,j),j=1,N) C enddo C do i=1,N C do j=1,N C check(p(i),p(j))=0 C do k=1,N C if(i.ge.k.and.j.ge.k) C - check(p(i),p(j))=check(p(i),p(j))+ C - chol(p(i),p(k))*chol(p(j),p(k)) C enddo C enddo C enddo C print *,' Check: ' C do i=1,N C print '(10f12.5)',(check(i,j),j=1,N) C enddo C print *,' Origin:' C do i=1,N C print '(10f12.5)',(cov(i,j),j=1,N) C enddo END +DECK,RNDEXP. REAL FUNCTION RNDEXP(A) *----------------------------------------------------------------------- * RNDEXP - Function returning a randomly distributed number from an * exponential distribution with parameter A. * VARIABLES : X : A homogeneously distributed number. * A : Expectation value of the distribution. * (Last changed on 17/10/95.) *----------------------------------------------------------------------- PARAMETER(NVEC=100) REAL RVEC(NVEC) INTEGER IVEC +SELF,IF=SAVE. SAVE RVEC,IVEC +SELF. DATA IVEC/0/ *** Return here if we got by accident an end-point (should not happen). 10 CONTINUE * Get a random number. IF(IVEC.EQ.0.OR.IVEC.GE.NVEC)THEN CALL RANLUX(RVEC,NVEC) IVEC=1 ELSE IVEC=IVEC+1 ENDIF X=RVEC(IVEC) * Check the value we got. IF(X.LE.0.0.OR.X.GT.1.0)GOTO 10 * And assign. RNDEXP=-A*LOG(X) END +DECK,RNDNBN,IF=NAGNUM. SUBROUTINE RNDNBN(PP,N,IRAN,NRAN) *----------------------------------------------------------------------- * RNDNBN - Random numbers according to a negative binomial. * Version for use with the NAG Fortran mark 16 libraries. * (Last changed on 12/ 6/97.) *----------------------------------------------------------------------- implicit none INTEGER N,NR,IFAIL,G05EYF,INIT,IRAN(*),NRAN,I PARAMETER(NR=2000) DOUBLE PRECISION P,R(NR) REAL PP EXTERNAL G05EYF +SELF,IF=SAVE. SAVE INIT +SELF. *** Initialise the generator. DATA INIT/0/ IF(INIT.EQ.0)THEN CALL G05CBF(0) INIT=1 ENDIF *** Check value of P and copy to double precision. IF(PP.LT.0.OR.PP.GT.1)THEN DO 50 I=1,NRAN IRAN(I)=-1 50 CONTINUE RETURN ELSE P=MIN(1.0D0,MAX(0.0D0,DBLE(PP))) ENDIF *** Check value of N. IF(N.LT.0)THEN DO 40 I=1,NRAN IRAN(I)=-1 40 CONTINUE RETURN ENDIF *** Create reference vector. IFAIL=+1 CALL G05EEF(N,P,R,NR,IFAIL) * If array too short, we almost certainly need size 0. IF(IFAIL.EQ.3.OR.IFAIL.EQ.2)THEN C print *,' IFAIL=',ifail,' p=',p,' n=',n DO 20 I=1,NRAN IRAN(I)=0 20 CONTINUE RETURN * Other errors are genuine - return -1. ELSEIF(IFAIL.NE.0)THEN PRINT *,' !!!!!! RNDNBN WARNING : Received error status'// - ' IFAIL=',IFAIL,' from G05EEF' PRINT *,' For a probability p=',P, - ' and n=',N,'.' DO 30 I=1,NRAN IRAN(I)=-1 30 CONTINUE RETURN ENDIF *** And return a random number. DO 10 I=1,NRAN IRAN(I)=G05EYF(R,NR) 10 CONTINUE END +DECK,RNDLAP. REAL FUNCTION RNDLAP(SIGMA) *----------------------------------------------------------------------- * RNDLAP - Function generating random numbers according to a Laplace * distribution with width SIGMA. * VARIABLES : MU : average of the random numbers. * SIGMA : standard deviation of the random numbers. * (Last changed on 9/11/07.) *----------------------------------------------------------------------- implicit none INTEGER IVEC,NVEC PARAMETER(NVEC=1000) REAL SIGMA,RVEC(NVEC) +SELF,IF=SAVE. SAVE RVEC,IVEC +SELF. *** Generate new random numbers as needed. DATA IVEC/0/ IF(IVEC.EQ.0.OR.IVEC+1.GT.NVEC)THEN CALL RANLUX(RVEC,NVEC) IVEC=1 ENDIF *** Generate a number. IF(1-2*ABS(RVEC(IVEC)-0.5).GT.0)THEN RNDLAP=SIGMA*LOG(1-2*ABS(RVEC(IVEC)-0.5)) ELSE RNDLAP=SIGMA*LOG(1.0E-20) print *,' rvec(',ivec,') = ',rvec(ivec),' rnd = ',rndlap ENDIF IF(RVEC(IVEC).LT.0.5)RNDLAP=-RNDLAP *** Next random number. IVEC=IVEC+1 END +DECK,RNDNOR. REAL FUNCTION RNDNOR(AVER,SIGMA) *----------------------------------------------------------------------- * RNDNOR - Function generating random numbers according to a normal * distribution with expected value MU and standard deviation * SIGMA. * VARIABLES : MU : average of the random numbers. * SIGMA : standard deviation of the random numbers. * (Last changed on 15/ 9/99.) *----------------------------------------------------------------------- implicit none INTEGER IVEC,MXVEC PARAMETER(MXVEC=1000) REAL AVER,SIGMA,RVEC(MXVEC) +SELF,IF=SAVE. SAVE RVEC,IVEC +SELF. DATA IVEC/0/ IF(IVEC.EQ.0.OR.IVEC+1.GT.MXVEC)THEN CALL RNORML(RVEC,MXVEC) IVEC=1 ENDIF RNDNOR=AVER+SIGMA*RVEC(IVEC) IVEC=IVEC+1 END +DECK,RNDPOL. REAL FUNCTION RNDPOL(THETA) *----------------------------------------------------------------------- * RNDPOL - Generates random numbers according to a Polya distribution * with parameter THETA. Since this is simply a scaled Gamma * distribution with parameter 1+THETA, RNGAMA (V135) is used. * (Last changed on 6/ 7/95.) *----------------------------------------------------------------------- implicit none REAL RNGAMA,THETA EXTERNAL RNGAMA *** Verify the parameter. IF(THETA.GT.-1)THEN RNDPOL=RNGAMA(1+THETA)/(1+THETA) ELSE RNDPOL=0 ENDIF END +DECK,RNDFUN. REAL FUNCTION RNDFUN(ARG) *----------------------------------------------------------------------- * RNDFUN - Generates random numbers according to a function, uses the * V152 routines. * (Last changed on 30/ 8/99.) *----------------------------------------------------------------------- implicit none INTEGER IENTRY REAL ARG,CUMRNF(200),XRAN(1) LOGICAL FUNSET COMMON /RNDFCM/ IENTRY,FUNSET,CUMRNF *** Verify that the function has been prepared. IF(.NOT.FUNSET)THEN PRINT *,' !!!!!! RNDFUN WARNING : Before using'// - ' RND_FUNCTION, you must call PREPARE_RND_FUNCTION;'// - ' no random number' RNDFUN=0 RETURN ENDIF *** Generate a random number. CALL FUGLUX(CUMRNF,XRAN,1) RNDFUN=XRAN(1) END +DECK,RNDHIS. SUBROUTINE RNDHIS(IREF,X) *----------------------------------------------------------------------- * RNDHIS - Generates random numbers according to a histogram. * (Last changed on 4/10/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,HISTDATA. INTEGER IREF,IFAIL,I,NITMAX PARAMETER(NITMAX=10) REAL X,XRAN(1) *** Initial settings. X=0 *** Check reference number and scale setting. IF(IREF.LE.0.OR.IREF.GT.MXHIST)THEN PRINT *,' !!!!!! RNDHIS WARNING : Histogram reference'// - ' not valid; no random number.' RETURN ELSEIF(.NOT.SET(IREF))THEN PRINT *,' !!!!!! RNDHIS WARNING : The scale of this'// - ' auto-range histogram is not yet set; no random'// - ' number.' RETURN ENDIF *** Try NITMAX times to get a random number. DO 10 I=1,NITMAX * Get a random number. CALL RANLUX(XRAN,1) * Reverse interpolation. CALL HISINV(IREF,XRAN(1),X,2,IFAIL) * Leave when OK. IF(IFAIL.EQ.0)THEN CALL LOGSAV(.TRUE.,'OK',IFAIL) RETURN ENDIF 10 CONTINUE *** If this still fails after 10 tries, then abandon. IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! RNDHIS WARNING : Inverse interpolation'// - ' error; no random number.' X=0 CALL LOGSAV(.FALSE.,'OK',IFAIL) RETURN ENDIF END +DECK,RNDUNI. REAL FUNCTION RNDUNI(SCALE) *----------------------------------------------------------------------- * RNDUNI - Function generating random numbers according to a uniform * distribution over the range <0,SCALE>, end-points are * excluded. * VARIABLES : SCALE : upper limit of range of the distribution. * (Last changed on 6/10/00.) *----------------------------------------------------------------------- implicit none INTEGER IVEC,MXVEC PARAMETER(MXVEC=1000) REAL SCALE,RVEC(MXVEC) +SELF,IF=SAVE. SAVE RVEC,IVEC +SELF. DATA IVEC/0/ IF(IVEC.EQ.0.OR.IVEC+1.GT.MXVEC)THEN CALL RANLUX(RVEC,MXVEC) IVEC=1 ENDIF RNDUNI=SCALE*RVEC(IVEC) IVEC=IVEC+1 END +DECK,FVAVIL. REAL FUNCTION FVAVIL(RKAPPA,BETA2,X) *----------------------------------------------------------------------- * FVAVIL - Function generating a Vavilov probability. * VARIABLES : RKAPPA : xi/emax * BETA2 : velocity2 * X : argument * (Last changed on 21/ 3/07.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,ALGDATA. REAL RKAPPA,BETA2,X,RKOLD,BETOLD,VVIDEN,XL,XU +SELF,IF=SAVE. SAVE RKOLD,BETOLD +SELF. EXTERNAL VAVDEN *** Initial parameter values (not acceptable) DATA RKOLD/-1/, BETOLD/-1/ *** Check values for applicable range IF(RKAPPA.LT.0.01.OR.RKAPPA.GT.10.OR. - BETA2.LT.0.OR.BETA2.GT.1)THEN NAERR(15)=NAERR(15)+1 FVAVIL=0 RETURN ENDIF *** See whether the initialisation needs to be called. IF(ABS(RKAPPA-RKOLD).GT.1E-5.OR.ABS(BETA2-BETOLD).GT.1E-5)THEN CALL VVISET(RKAPPA,BETA2,0,XL,XU) RKOLD=RKAPPA BETOLD=BETA2 ENDIF *** Return a value FVAVIL=VVIDEN(X) END +DECK,RNDVAV. REAL FUNCTION RNDVAV(RKAPPA,BETA2) *----------------------------------------------------------------------- * RNDVAV - Function generating a Vavilov random number. * VARIABLES : RKAPPA : xi/emax * BETA2 : velocity2 * (Last changed on 23/11/06.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,ALGDATA. REAL RKAPPA,BETA2,RKOLD,BETOLD,RNDUNI,VAVRND EXTERNAL RNDUNI,VAVRND +SELF,IF=SAVE. SAVE RKOLD,BETOLD +SELF. *** Initial parameter values (not acceptable) DATA RKOLD/-1/, BETOLD/-1/ *** Check values for applicable range IF(RKAPPA.LT.0.01.OR.RKAPPA.GT.12.OR. - BETA2.LT.0.OR.BETA2.GT.1)THEN NAERR(15)=NAERR(15)+1 RNDVAV=0 RETURN ENDIF *** See whether the initialisation needs to be called. IF(ABS(RKAPPA-RKOLD).GT.1E-5.OR.ABS(BETA2-BETOLD).GT.1E-5)THEN CALL VAVSET(RKAPPA,BETA2,1) RKOLD=RKAPPA BETOLD=BETA2 ENDIF *** Return a value RNDVAV=VAVRND(RNDUNI(1.0)) END +DECK,RNDVVL. REAL FUNCTION RNDVVL(RKAPPA,BETA2) *----------------------------------------------------------------------- * RNDVVL - Function generating a Vavilov random number, providing * better precision than RNDVAV * VARIABLES : RKAPPA : xi/emax * BETA2 : velocity2 * (Last changed on 21/ 3/07.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,ALGDATA. REAL RKAPPA,BETA2,RKOLD,BETOLD,FSPACE(200),XLOW,XHIGH,VVIDEN, - XRAN(1) INTEGER LENGTH,IFAIL EXTERNAL VVIDEN +SELF,IF=SAVE. SAVE RKOLD,BETOLD,FSPACE +SELF. *** Initial parameter values (not acceptable) DATA RKOLD/-1/, BETOLD/-1/ *** Check values for applicable range IF(RKAPPA.LT.0.01.OR.RKAPPA.GT.10.OR. - BETA2.LT.0.OR.BETA2.GT.1)THEN NAERR(15)=NAERR(15)+1 RNDVVL=0 RETURN ENDIF *** See whether the initialisation needs to be called. IF(ABS(RKAPPA-RKOLD).GT.1E-5.OR.ABS(BETA2-BETOLD).GT.1E-5)THEN * Prepare the Vavilov function. CALL VVISET(RKAPPA,BETA2,0,XLOW,XHIGH) * Prepare for random number generation. CALL FUGLXP(VVIDEN,FSPACE,XLOW,XHIGH,IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! RNDVVL WARNING : Error preparing'// - ' the Vavilov function for kappa = ',RKAPPA, - ', beta2 = ',BETA2,'; returning 0.' RNDVVL=0 RETURN ENDIF * If successful, store old kappa and beta2. RKOLD=RKAPPA BETOLD=BETA2 ENDIF *** Return a value LENGTH=1 CALL FUGLUX(FSPACE,XRAN,LENGTH) RNDVVL=XRAN(1) END +DECK,RNDHWF. SUBROUTINE RNDHWF(W,F,RND) *----------------------------------------------------------------------- * RNDHWF - Generates random energies needed to create a single e- in * a gas with asymptotic work function W and Fano factor F, * according to Igor Smirnov's phenomenological model. * (Last changed on 27/ 6/07.) *----------------------------------------------------------------------- implicit none REAL W,F,RND,RNDUNI,WREF,FREF,X,E PARAMETER(WREF=30.0, FREF=0.174) EXTERNAL RNDUNI *** Check parameters IF(W.LE.0.OR.F.LT.0)THEN PRINT *,' !!!!!! RNDHWF WARNING : Work and/or Fano'// - ' parameter out of range; returning 0.' RND=0 RETURN * Special case of F=0 ELSEIF(F.EQ.0)THEN RND=W RETURN ENDIF *** First generate a standardised (W=30, F=0.174) random energy X=RNDUNI(1.0)*WREF*0.82174 * E = 0 to w/2: p = 0, integral = 0 IF(X.LT.0)THEN PRINT *,' !!!!!! RNDHWF WARNING : Random number is below'// - ' the applicable range - program error; returning w/2.' E=WREF/2 * E = w/2 to w: p = 1, integral = E-w/2 ELSEIF(X.LT.WREF/2)THEN E=WREF/2+X * E = w to 3.064 w: p = (w/E)^4, integral = w^4/3 (1/E^3 - 1/w^3) ELSEIF(X.LT.WREF*0.82174)THEN E=(2*WREF**4/(5*WREF-6*X))**(1.0/3.0) * E > 3.064 w: p = 0, integral = 0 ELSE PRINT *,' !!!!!! RNDHWF WARNING : Random number is above'// - ' applicable range - program error; returning 3.064 w.' E=3.064*WREF ENDIF *** Scale. RND=(W/WREF)*SQRT(F/FREF)*E+W*(1-SQRT(F/FREF)) END +DECK,RNDINI. SUBROUTINE RNDINI(NRNDM) *----------------------------------------------------------------------- * RNDINI - Calls all random number generators a number of times. * VARIABLES : NRNDM : Number of calls. * (Last changed on 7/ 4/06.) *----------------------------------------------------------------------- implicit none INTEGER NRNDM,I REAL RVEC(1),RNDM,RANFL,DUMMY DOUBLE PRECISION DVEC(1) *** Loop. DUMMY=0 DO 10 I=1,NRNDM * RANLUX: Underlying generator for most generators CALL RANLUX(RVEC,1) * RANMAR: Used by RNORML CALL RANMAR(RVEC,1) * RANFL: Used by Heed DUMMY=DUMMY+RANFL() * RM48: Used by Magboltz CALL RM48(DVEC,1) * RNDM: Used for non-critical purposes DUMMY=DUMMY+RNDM(I)+RVEC(1) 10 CONTINUE *** Print. PRINT *,' ------ RNDINI MESSAGE : Random number generators'// - ' have been called ',NRNDM,' times.' END +DECK,RNDM,IF=NAGNUM. REAL FUNCTION RNDM(DUMMY) *----------------------------------------------------------------------- * RNDM - Replaces the CERN library routine RNDM (V104) with the NAG * equivalent G05CAF. *----------------------------------------------------------------------- RNDM=REAL(G05CAF(DUMMY)) END +DECK,ROUND. SUBROUTINE ROUND(XMIN,XMAX,N,DIR,STEP) *----------------------------------------------------------------------- * ROUND - Rounds the input range (XMIN.XMAX) to the nearest decent * interval. * VARIABLES : DIR : The new interval may be larger if .TRUE. * N : The number of intermediate points. * STEP : Contains the step size. * (Last changed on 20/ 5/99.) *----------------------------------------------------------------------- implicit none REAL XMAX,XMIN,STEP,STNEW,XMINC,XMAXC INTEGER N,K CHARACTER*(*) DIR *** Check the validity of the input. IF(XMAX.EQ.XMIN)THEN STEP=0.0 RETURN ELSEIF(XMAX.LE.XMIN)THEN PRINT *,' !!!!!! ROUND WARNING : Illegal range: ',XMIN,XMAX RETURN ELSEIF(N.LE.0)THEN PRINT *,' !!!!!! ROUND WARNING : Illegal number of points.' RETURN ENDIF *** Set the rough interval. STEP=(XMAX-XMIN)/REAL(N) * Compute order of magnitude. K=NINT(LOG10(STEP)) * Very large range: abandon. IF(K.GT.30)THEN RETURN * Normal range larger than 1: eliminate order of magnitude. ELSEIF(K.GE.0)THEN STEP=STEP/10.0**K * Very small range: abandon. ELSEIF(K.LT.-30)THEN RETURN * Normal range smaller than 1: eliminate order of magnitude. ELSE STEP=STEP*10.0**(-K) ENDIF * Make more bins. IF(INDEX(DIR,'COARSER').NE.0)THEN IF(STEP.GE.0.1.AND.STEP.LT.0.2)THEN STNEW=0.2 ELSEIF(STEP.GE.0.2.AND.STEP.LT.0.5)THEN STNEW=0.5 ELSEIF(STEP.GE.0.5.AND.STEP.LT.1.0)THEN STNEW=1.0 ELSEIF(STEP.GE.1.0.AND.STEP.LT.2.0)THEN STNEW=2.0 ELSEIF(STEP.GE.2.0.AND.STEP.LT.5.0)THEN STNEW=5.0 ELSEIF(STEP.GE.5.0.AND.STEP.LT.10.0)THEN STNEW=10.0 ELSE PRINT *,' ###### ROUND ERROR : Unable to find a', - ' new interval for STEP=',STEP,' program bug.' RETURN ENDIF * Or make fewer bins. ELSE IF(STEP.GE.0.1.AND.STEP.LT.0.2)THEN STNEW=0.1 ELSEIF(STEP.GE.0.2.AND.STEP.LT.0.5)THEN STNEW=0.2 ELSEIF(STEP.GE.0.5.AND.STEP.LT.1.0)THEN STNEW=0.5 ELSEIF(STEP.GE.1.0.AND.STEP.LT.2.0)THEN STNEW=1.0 ELSEIF(STEP.GE.2.0.AND.STEP.LT.5.0)THEN STNEW=2.0 ELSEIF(STEP.GE.5.0.AND.STEP.LT.10.0)THEN STNEW=5.0 ELSE PRINT *,' ###### ROUND ERROR : Unable to find a', - ' new interval for STEP=',STEP,' program bug.' RETURN ENDIF ENDIF * Add order of magnitude again. IF(K.GE.0)THEN STEP=STNEW*10.0**K ELSE STEP=STNEW/10.0**(-K) ENDIF * Check whether the bins need to be integer. IF(INDEX(DIR,'INTEGER').NE.0.AND.STEP.LT.1)STEP=1 *** Set the new XMIN and XMAX. XMINC=STEP*ANINT(XMIN/STEP) XMAXC=STEP*ANINT(XMAX/STEP) IF(INDEX(DIR,'LARGER').NE.0)THEN IF(XMINC.LE.XMIN+STEP/10.0)XMIN=XMINC IF(XMINC.GT.XMIN+STEP/10.0)XMIN=XMINC-STEP IF(XMAXC.LT.XMAX-STEP/10.0)XMAX=XMAXC+STEP IF(XMAXC.GE.XMAX-STEP/10.0)XMAX=XMAXC ELSE IF(XMINC.LT.XMIN-STEP/10.0)XMIN=XMINC+STEP IF(XMINC.GE.XMIN-STEP/10.0)XMIN=XMINC IF(XMAXC.LE.XMAX+STEP/10.0)XMAX=XMAXC IF(XMAXC.GT.XMAX+STEP/10.0)XMAX=XMAXC-STEP ENDIF END +DECK,SPLINE. SUBROUTINE SPLINE(X,Y,C,N,IFAIL) *----------------------------------------------------------------------- * SPLINE - Routine preparing a cubic spline interpolation through the * the points (X(I),Y(I)) I=1,N. * VARIABLES : Most of the variables are the same as in the reference, * the only major difference being that the indices start * at 1 instead of at 0 and that C (program) is M (ref). * REFERENCE : Stoer and Bulirsch, Einfuhrung in die numerische * Mathematic, I, Heidelberger taschenbucher. *----------------------------------------------------------------------- +SEQ,DIMENSIONS. DIMENSION X(MXLIST),Y(MXLIST),Q(MXLIST),U(MXLIST),C(MXLIST) *** Initialise IFAIL to 0 (success). IFAIL=0 *** Reject the trivial case. IF(N.LE.1)THEN PRINT *,' ###### SPLINE ERROR : Only ',N,' points on', - ' the spline while a minimum of 2 is required.' IFAIL=1 RETURN ENDIF *** The X's should be all different and in strictly ascending order. DO 10 I=1,N-1 IF(X(I).EQ.X(I+1))THEN PRINT *,' ###### SPLINE ERROR : Two ordinates are equal.' IFAIL=1 RETURN ENDIF IF(X(I).GT.X(I+1))THEN PRINT *,' ###### SPLINE ERROR : The ordinates are not in', - ' strictly ascending order.' IFAIL=1 RETURN ENDIF 10 CONTINUE *** Define 'boundary values' of ALFA and D. ALFA=0 D=0 *** Solve the set of linear equations determining the C's. Q(1)=-ALFA/2.0 U(1)=D/2.0 DO 20 K=2,N-1 ALFA=(X(K+1)-X(K))/(X(K+1)-X(K-1)) BETA=1.0-ALFA D=6.0*((Y(K+1)-Y(K))/(X(K+1)-X(K))-(Y(K)-Y(K-1))/(X(K)-X(K-1)))/ - (X(K+1)-X(K-1)) P=BETA*Q(K-1)+2 Q(K)=-ALFA/P U(K)=(D-BETA*U(K-1))/P 20 CONTINUE *** Set the C's starting from the last one. C(N)=0 DO 30 K=N-1,1,-1 C(K)=Q(K)*C(K+1)+U(K) 30 CONTINUE END +DECK,SPLINE2. SUBROUTINE SPLIN2(X,Y,C,N,IFAIL) *----------------------------------------------------------------------- * SPLIN2 - Routine preparing a cubic spline interpolation through the * the points (X(I),Y(I)) I=1,N in double precision. * VARIABLES : Most of the variables are the same as in the reference, * the only major difference being that the indices start * at 1 instead of at 0 and that C (program) is M (ref). * REFERENCE : Stoer and Bulirsch, Einfuhrung in die numerische * Mathematic, I, Heidelberger taschenbucher. *----------------------------------------------------------------------- IMPLICIT DOUBLE PRECISION (A-H,O-Z) +SEQ,DIMENSIONS. DIMENSION X(MXLIST),Y(MXLIST),Q(MXLIST),U(MXLIST),C(MXLIST) *** Initialise IFAIL to 0 (success). IFAIL=0 *** Reject the trivial case. IF(N.LE.1)THEN PRINT *,' ###### SPLIN2 ERROR : Only ',N,' points on', - ' the spline whereas a minimum of 2 is required.' IFAIL=1 RETURN ENDIF *** The x's should be all different and in ascending order. DO 10 I=1,N-1 IF(X(I).EQ.X(I+1))THEN C PRINT *,' ###### SPLIN2 ERROR : Two ordinates are equal.' IFAIL=1 RETURN ENDIF IF(X(I).GT.X(I+1))THEN PRINT *,' ###### SPLIN2 ERROR : The ordinates are not in', - ' strictly ascending order.' IFAIL=1 RETURN ENDIF 10 CONTINUE *** Define 'boundary values' of ALFA and D. ALFA=0 D=0 *** Solve the set of linear equations determining the C's. Q(1)=-ALFA/2.0 U(1)=D/2.0 DO 20 K=2,N-1 ALFA=(X(K+1)-X(K))/(X(K+1)-X(K-1)) BETA=1.0-ALFA D=6.0*((Y(K+1)-Y(K))/(X(K+1)-X(K))-(Y(K)-Y(K-1))/(X(K)-X(K-1)))/ - (X(K+1)-X(K-1)) P=BETA*Q(K-1)+2 Q(K)=-ALFA/P U(K)=(D-BETA*U(K-1))/P 20 CONTINUE *** Define the C's starting from the last one. C(N)=0 DO 30 K=N-1,1,-1 C(K)=Q(K)*C(K+1)+U(K) 30 CONTINUE END +DECK,STRCAL. SUBROUTINE STRCAL(INSTR,IFAIL) *----------------------------------------------------------------------- * STRCAL - Handles string procedure calls. * (Last changed on 21/ 1/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,ALGDATA. +SEQ,GLOBALS. +SEQ,PRINTPLOT. CHARACTER*(MXINCH) STRING,AUX1,AUX2,AUX3 INTEGER INSTR,IFAIL,NARG,IPROC,NC,NC1,NC2,NC3,IFAIL1,IFAIL2, - IFAIL3,IFAIL4,IAUX,IF,IL,I,NOUT,ISEP,ISQ,IDQ,NWORD,I0,I1, - IMATCH,INEXT,INPCMX,IREF EXTERNAL INPCMX *** Assume that this will fail. IFAIL=1 *** Some easy reference variables. NARG=INS(INSTR,3) IPROC=INS(INSTR,1) *** Locate one string inside another. IF(IPROC.EQ.-901)THEN * Check arguments. IF(NARG.NE.3.OR.ARGREF(3,1).GE.2.OR. - MODARG(1).NE.1.OR.MODARG(2).NE.1)THEN PRINT *,' !!!!!! STRCAL WARNING : Incorrect set'// - ' of arguments for STRING_INDEX.' RETURN ENDIF * Get strings from store. CALL STRBUF('READ',NINT(ARG(1)),STRING,NC1,IFAIL1) CALL STRBUF('READ',NINT(ARG(2)),AUX2,NC2,IFAIL2) * Clear previous use of result. CALL ALGREU(NINT(ARG(3)),MODARG(3),ARGREF(3,1)) * And store result of operation. IF(IFAIL1.EQ.0.AND.IFAIL2.EQ.0)THEN ARG(3)=INDEX(STRING(1:NC1),AUX2(1:NC2)) MODARG(3)=2 ELSE ARG(3)=-1 MODARG(3)=2 PRINT *,' !!!!!! STRCAL WARNING : Unable to fetch a'// - ' string for STRING_INDEX.' ENDIF *** Return a substring. ELSEIF(IPROC.EQ.-902)THEN * Check arguments. IF(NARG.NE.4.OR.ARGREF(4,1).GE.2.OR.MODARG(1).NE.1.OR. - MODARG(2).NE.2.OR.MODARG(3).NE.2)THEN PRINT *,' !!!!!! STRCAL WARNING : Incorrect set'// - ' of arguments for STRING_PORTION.' RETURN ENDIF * Get string from store. CALL STRBUF('READ',NINT(ARG(1)),STRING,NC,IFAIL1) * Clear previous use of result. CALL ALGREU(NINT(ARG(4)),MODARG(4),ARGREF(4,1)) * And store result of operation. IF(IFAIL1.NE.0)THEN IFAIL2=1 ELSEIF((ARG(2).GT.NC.AND.ARG(3).GT.NC).OR. - (ARG(2).LT.1.AND.ARG(3).LT.1))THEN CALL STRBUF('STORE',IAUX,' ',0,IFAIL2) ARG(4)=REAL(IAUX) MODARG(4)=1 ELSE IF=MAX(1,MIN(NC,NINT(ARG(2)))) IL=MAX(1,MIN(NC,NINT(ARG(3)))) IF(IL.GE.IF)THEN DO 100 I=IF,IL AUX1(I-IF+1:I-IF+1)=STRING(I:I) 100 CONTINUE ELSE DO 110 I=IF,IL,-1 AUX1(IF-I+1:IF-I+1)=STRING(I:I) 110 CONTINUE ENDIF NC=ABS(IL-IF)+1 CALL STRBUF('STORE',IAUX,AUX1(1:NC),NC,IFAIL2) ARG(4)=REAL(IAUX) MODARG(4)=1 ENDIF IF(IFAIL1.NE.0.OR.IFAIL2.NE.0) - PRINT *,' !!!!!! STRCAL WARNING : Unable to fetch or'// - ' store a string for STRING_PORTION.' *** Delete part of a string. ELSEIF(IPROC.EQ.-903)THEN * Check arguments. IF(NARG.NE.4.OR.ARGREF(4,1).GE.2.OR.MODARG(1).NE.1.OR. - MODARG(2).NE.2.OR.MODARG(3).NE.2)THEN PRINT *,' !!!!!! STRCAL WARNING : Incorrect set'// - ' of arguments for STRING_DELETE.' RETURN ENDIF * Get string from store. CALL STRBUF('READ',NINT(ARG(1)),STRING,NC,IFAIL1) * Clear previous use of result. CALL ALGREU(NINT(ARG(4)),MODARG(4),ARGREF(4,1)) * And store result of operation. IF(IFAIL1.EQ.0)THEN NOUT=0 AUX1=' ' DO 120 I=1,NC IF(I.GE.MIN(NINT(ARG(2)),NINT(ARG(3))).AND. - I.LE.MAX(NINT(ARG(2)),NINT(ARG(3))))GOTO 120 NOUT=NOUT+1 AUX1(NOUT:NOUT)=STRING(I:I) 120 CONTINUE CALL STRBUF('STORE',IAUX,AUX1(1:(MAX(1,NC))),NC, - IFAIL2) ARG(4)=REAL(IAUX) MODARG(4)=1 ELSE IFAIL2=1 ENDIF IF(IFAIL1.NE.0.OR.IFAIL2.NE.0) - PRINT *,' !!!!!! STRCAL WARNING : Unable to fetch or'// - ' store a string for STRING_DELETE.' *** Convert a string to lower case. ELSEIF(IPROC.EQ.-904)THEN * Check arguments. IF(NARG.NE.1.OR.ARGREF(1,1).GE.2.OR.MODARG(1).NE.1)THEN PRINT *,' !!!!!! STRCAL WARNING : Incorrect set'// - ' of arguments for STRING_LOWER.' RETURN ENDIF * Get string from store. CALL STRBUF('READ',NINT(ARG(1)),STRING,NC,IFAIL1) * Clear previous use of result. CALL ALGREU(NINT(ARG(1)),MODARG(1),ARGREF(1,1)) * Store result of operation. IF(IFAIL1.EQ.0)THEN CALL CUTOL(STRING(1:NC)) CALL STRBUF('STORE',IAUX,STRING(1:NC),NC,IFAIL2) ARG(1)=REAL(IAUX) MODARG(1)=1 ELSE IFAIL2=0 ENDIF IF(IFAIL1.NE.0.OR.IFAIL2.NE.0) - PRINT *,' !!!!!! STRCAL WARNING : Unable to fetch or'// - ' store a string for STRING_LOWER.' *** Convert a string to upper case. ELSEIF(IPROC.EQ.-905)THEN * Check arguments. IF(NARG.NE.1.OR.ARGREF(1,1).GE.2.OR.MODARG(1).NE.1)THEN PRINT *,' !!!!!! STRCAL WARNING : Incorrect set'// - ' of arguments for STRING_UPPER.' RETURN ENDIF * Get string from store. CALL STRBUF('READ',NINT(ARG(1)),STRING,NC,IFAIL1) * Clear previous use of result. CALL ALGREU(NINT(ARG(1)),MODARG(1),ARGREF(1,1)) * Store result of operation. IF(IFAIL1.EQ.0)THEN CALL CLTOU(STRING(1:NC)) CALL STRBUF('STORE',IAUX,STRING(1:NC),NC,IFAIL2) ARG(1)=REAL(IAUX) MODARG(1)=1 ELSE IFAIL2=0 ENDIF IF(IFAIL1.NE.0.OR.IFAIL2.NE.0) - PRINT *,' !!!!!! STRCAL WARNING : Unable to fetch or'// - ' store a string for STRING_UPPER.' *** Number of words in a string. ELSEIF(IPROC.EQ.-906)THEN * Check arguments. IF(NARG.NE.2.OR.ARGREF(2,1).GE.2.OR.MODARG(1).NE.1)THEN PRINT *,' !!!!!! STRCAL WARNING : Incorrect set'// - ' of arguments for STRING_WORDS.' RETURN ENDIF * Get string from store. CALL STRBUF('READ',NINT(ARG(1)),STRING,NC,IFAIL1) * Clear previous use of result. CALL ALGREU(NINT(ARG(2)),MODARG(2),ARGREF(2,1)) * Store result of operation. IF(IFAIL1.EQ.0)THEN ARG(2)=0 MODARG(2)=2 ISEP=1 ISQ=0 IDQ=0 DO 130 I=1,NC IF(STRING(I:I).EQ.''''.AND.IDQ.EQ.0)ISQ=1-ISQ IF(STRING(I:I).EQ.'"'.AND.ISQ.EQ.0)IDQ=1-IDQ IF(ISQ.EQ.0.AND.IDQ.EQ.0.AND. - INDEX(' :,=',STRING(I:I)).NE.0)THEN IF(ISEP.EQ.0)ARG(2)=ARG(2)+1 ISEP=1 ELSE ISEP=0 ENDIF 130 CONTINUE IF(ISEP.EQ.0)ARG(2)=ARG(2)+1 IF(ISQ.NE.0)PRINT *,' !!!!!! STRCAL WARNING: Odd'// - ' number of single quotes; one added at end.' IF(IDQ.NE.0)PRINT *,' !!!!!! STRCAL WARNING: Odd'// - ' number of double quotes; one added at end.' ELSE ARG(2)=-1 MODARG(2)=2 PRINT *,' !!!!!! STRCAL WARNING :'// - ' Unable to fetch a string for STRING_WORDS.' ENDIF *** Return a word from a string. ELSEIF(IPROC.EQ.-907)THEN * Check arguments. IF(NARG.NE.3.OR.ARGREF(3,1).GE.2.OR. - MODARG(1).NE.1.OR.MODARG(2).NE.2)THEN PRINT *,' !!!!!! STRCAL WARNING : Incorrect set'// - ' of arguments for STRING_WORD.' RETURN ENDIF * Get string from store. CALL STRBUF('READ',NINT(ARG(1)),STRING,NC,IFAIL1) * Clear previous use of result. CALL ALGREU(NINT(ARG(3)),MODARG(3),ARGREF(3,1)) * Store result of operation. IF(IFAIL1.EQ.0)THEN ISEP=1 ISQ=0 IDQ=0 I0=1 AUX1=' ' NC1=0 NWORD=0 DO 140 I=1,NC IF(STRING(I:I).EQ.''''.AND.IDQ.EQ.0)ISQ=1-ISQ IF(STRING(I:I).EQ.'"'.AND.ISQ.EQ.0)IDQ=1-IDQ IF(ISQ.EQ.0.AND.IDQ.EQ.0.AND. - INDEX(' :,=',STRING(I:I)).NE.0)THEN IF(ISEP.EQ.0)NWORD=NWORD+1 IF(NWORD.EQ.NINT(ARG(2)).AND.ISEP.EQ.0)THEN IF(INDEX('''"',STRING(I0:I0)).NE.0)I0=I0+1 I1=I-1 IF(INDEX('''"',STRING(I1:I1)).NE.0)I1=I1-1 IF(I1.GE.I0.AND.I0.GE.1.AND.I1.GE.1.AND. - I0.LE.NC.AND.I1.LE.NC)THEN AUX1=STRING(I0:I1) NC1=I1-I0+1 ELSE AUX1=' ' NC1=1 ENDIF ENDIF ISEP=1 ELSE IF(ISEP.EQ.1)I0=I ISEP=0 ENDIF 140 CONTINUE IF(ISEP.EQ.0)NWORD=NWORD+1 IF(NWORD.EQ.NINT(ARG(2)).AND.ISEP.EQ.0)THEN IF(INDEX('''"',STRING(I0:I0)).NE.0)I0=I0+1 I1=NC IF(INDEX('''"',STRING(I1:I1)).NE.0)I1=I1-1 IF(I1.GE.I0.AND.I0.GE.1.AND.I1.GE.1.AND. - I0.LE.NC.AND.I1.LE.NC)THEN AUX1=STRING(I0:I1) NC1=I1-I0+1 ELSE AUX1=' ' NC1=1 ENDIF ENDIF CALL STRBUF('STORE',IAUX,AUX1(1:NC1),NC1,IFAIL2) ARG(3)=REAL(IAUX) MODARG(3)=1 ELSE IFAIL2=0 ENDIF IF(IFAIL1.NE.0.OR.IFAIL2.NE.0) - PRINT *,' !!!!!! STRCAL WARNING : Unable to fetch or'// - ' store a string for STRING_WORD.' *** See whether two strings match. ELSEIF(IPROC.EQ.-908)THEN * Check arguments. IF(NARG.NE.3.OR.ARGREF(3,1).GE.2.OR. - MODARG(1).NE.1.OR.MODARG(2).NE.1)THEN PRINT *,' !!!!!! STRCAL WARNING : Incorrect set'// - ' of arguments for STRING_MATCH.' RETURN ENDIF * Get strings from store. CALL STRBUF('READ',NINT(ARG(1)),STRING,NC1,IFAIL1) CALL STRBUF('READ',NINT(ARG(2)),AUX2,NC2,IFAIL2) * Clear previous use of result. CALL ALGREU(NINT(ARG(3)),MODARG(3),ARGREF(3,1)) * Result of opetration. IF(IFAIL1.EQ.0.AND.IFAIL2.EQ.0)THEN IMATCH=INPCMX(STRING(1:NC1),AUX2(1:NC2)) IF(IMATCH.NE.0)THEN ARG(3)=1 ELSE ARG(3)=0 ENDIF MODARG(3)=3 ELSE PRINT *,' !!!!!! STRCAL WARNING : Unable to fetch'// - ' a string for STRING_MATCH.' ENDIF *** Replace parts of a string. ELSEIF(IPROC.EQ.-909)THEN * Check arguments. IF(NARG.NE.3.OR.ARGREF(4,1).GE.2.OR.MODARG(1).NE.1.OR. - MODARG(2).NE.1.OR.MODARG(3).NE.1)THEN PRINT *,' !!!!!! STRCAL WARNING : Incorrect set'// - ' of arguments for STRING_REPLACE.' RETURN ENDIF * Get string from store. CALL STRBUF('READ',NINT(ARG(1)),STRING,NC1,IFAIL1) CALL STRBUF('READ',NINT(ARG(2)),AUX2, NC2,IFAIL2) CALL STRBUF('READ',NINT(ARG(3)),AUX3, NC3,IFAIL3) IF(IFAIL1.NE.0.OR.IFAIL2.NE.0.OR.IFAIL3.NE.0)THEN PRINT *,' !!!!!! STRCAL WARNING : Unable to retrieve'// - ' an argument of STRING_REPLACE; not executed.' RETURN ENDIF * Start. INEXT=1 NOUT=0 * Replace. DO 150 I=1,NC1 IF(I.LT.INEXT)GOTO 150 IF(STRING(I:MIN(NC1,I+NC2-1)).EQ.AUX2(1:NC2).AND. - I+NC2-1.LE.NC1)THEN IF(NOUT+NC3.GT.LEN(AUX1))THEN PRINT *,' !!!!!! STRCAL WARNING : String grows'// - ' too much while replacing characters;'// - ' string not changed.' RETURN ENDIF AUX1(NOUT+1:NOUT+NC3)=AUX3(1:NC3) NOUT=NOUT+NC3 INEXT=I+NC2 ELSE IF(NOUT+1.GT.LEN(AUX1))THEN PRINT *,' !!!!!! STRCAL WARNING : String grows'// - ' too much while replacing characters;'// - ' string not changed.' RETURN ENDIF AUX1(NOUT+1:NOUT+1)=STRING(I:I) NOUT=NOUT+1 INEXT=I+1 ENDIF 150 CONTINUE * Clear previous use of result. CALL ALGREU(NINT(ARG(1)),MODARG(1),ARGREF(1,1)) * And store result of operation. IF(IFAIL1.EQ.0)THEN CALL STRBUF('STORE',IAUX,AUX1(1:NOUT),NOUT,IFAIL4) ARG(1)=REAL(IAUX) MODARG(1)=1 IF(IFAIL4.NE.0)THEN PRINT *,' !!!!!! STRCAL WARNING : Unable to'// - ' store the processed string; original'// - ' string lost.' RETURN ENDIF ENDIF *** List the string buffer. ELSEIF(IPROC.EQ.-910)THEN IF(NARG.NE.0)PRINT *,' !!!!!! STRCAL WARNING : The'// - ' LIST_STRINGS procedure has no arguments; ignored.' CALL STRBUF('DUMP',IREF,' ',1,IFAIL) *** Length of a string. ELSEIF(IPROC.EQ.-911)THEN * Check arguments. IF(NARG.NE.2.OR.ARGREF(2,1).GE.2.OR.MODARG(1).NE.1)THEN PRINT *,' !!!!!! STRCAL WARNING : Incorrect set'// - ' of arguments for STRING_LENGTH.' RETURN ENDIF * Get string from store. CALL STRBUF('READ',NINT(ARG(1)),STRING,NC,IFAIL1) * Clear previous use of result. CALL ALGREU(NINT(ARG(2)),MODARG(2),ARGREF(2,1)) * Store result of operation. IF(IFAIL1.EQ.0)THEN ARG(2)=REAL(NC) MODARG(2)=2 ELSE ARG(2)=-1 MODARG(2)=2 PRINT *,' !!!!!! STRCAL WARNING :'// - ' Unable to fetch a string for STRING_LENGTH.' ENDIF *** Delete strings. ELSEIF(IPROC.EQ.-912)THEN * Without arguments, delete all strings. IF(NARG.LT.1)THEN DO 10 I=1,NGLB IF(GLBMOD(I).EQ.1)THEN CALL STRBUF('DELETE',NINT(GLBVAL(I)),' ',1,IFAIL1) GLBVAL(I)=0 GLBMOD(I)=0 ENDIF 10 CONTINUE * Delete all the matrices in the arguments. ELSE DO 20 I=1,NARG IF(MODARG(I).NE.1)THEN PRINT *,' !!!!!! STRCAL WARNING : Argument ',I, - ' is not a string; not deleted.' GOTO 20 ENDIF CALL STRBUF('DELETE',NINT(ARG(I)),' ',1,IFAIL1) ARG(I)=0 MODARG(I)=0 IF(IFAIL1.NE.0)PRINT *,' !!!!!! STRCAL WARNING :'/