+TITLE. GARFIELD 7.04 /00 010203 00.00 * * GARFIELD, A drift-chamber simulation program. * * This is Garfield version 7.04, updated until 2/ 3/01. Comments and * reports are most welcome. A copy of any note, thesis or publication * for which Garfield has been used, will be highly appreciated. * * Garfield is available free of charge to any interested party, in the * understanding that the program shall not be sold nor resold and that * the program shall be used exclusively for scientific purposes. * * 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 EP division 2, Rue du Reculet * CH-1211 Geneve 23 or F 01630 St Genis Pouilly * Switzerland / Suisse France * tel: + 41 22 7671156 tel: + 33 4 50421784 * Fax: + 41 22 7678350 * email: Rob.Veenhof@cern.ch * * Contributions: * * G.A. Erskine (retired, DD division CERN). * Carlo Mekenkamp (Rijks Universiteit Leiden). * * CERN program library reference: W5050 * * Copyright: Rob Veenhof, 2001. +PATCH,*APOLLO. Pilot patch for Apollo SR10 +IMI,APOLLO. +IMI,SAVE. +IMI,GTSGRAL. +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,*ALLIANT. Various Unix selection patches. +USE,*UNIX. +IMI,ALLIANT. +PATCH,*CONVEX. +USE,*UNIX. +IMI,CONVEX. +PATCH,*IBMAIX. +USE,*UNIX. +IMI,IBMAIX. +PATCH,*UNISYS. +USE,*UNIX. +IMI,UNISYS. +PATCH,*DECS. +USE,*UNIX. +IMI,DECS. +PATCH,*GOULD. +USE,*UNIX. +IMI,GOULD. +PATCH,*HPUX. +USE,*UNIX. +IMI,HPUX. +PATCH,*IBMRT. IBM RT, also used for SP2. +USE,*UNIX. +IMI,ESSL. +IMI,IBMRT. +PATCH,*MACMPW. +USE,*UNIX. +IMI,MACMPW. +PATCH,*MIPS. +USE,*UNIX. +IMI,MIPS. +PATCH,*SGI. +USE,*UNIX. +IMI,SGI. +PATCH,*SUN. +USE,*UNIX. +IMI,SUN. +PATCH,*NEXT. +USE,*UNIX. +IMI,NEXT. +PATCH,*QMVAOS. +USE,*UNIX. +IMI,QMVAOS. +PATCH,*UNIX. Pilot patch for Unix +IMI,UNIX. +IMI,SAVE. +IMI,HIGZ. +PATCH,*LINUX. Pilot patch for IBM PC +IMI,LINUX. +IMI,UNIX. +IMI,SAVE. +IMI,HIGZ. +IMI,QF2C. +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,*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=GAS. +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. * 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 6/ 1/01.) *----------------------------------------------------------------------- +KEEP,DIMWIRE,IF=MANYWIRE. PARAMETER (MXWIRE= 2000,MXSW = 100) +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 = 50000,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, - 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= 10) +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= 50,MXCHAR=MXINCH) PARAMETER (MXINS = 1000,MXREG = 500,MXCONS= -500,MXVAR = 500, - MXALGE= 500,MXARG = 100) PARAMETER (MXMAT = 500,MXEMAT=50000,MXMDIM= 10) PARAMETER (MXZERO=MXWIRE) PARAMETER (MXSTCK= 5) PARAMETER (MXFPNT= 200,MXFPAR= 10) PARAMETER (MXWKLS= 10) PARAMETER (MXHLEV= 9,MXSUBT= 180,MXHLRL=768) PARAMETER (MXDLVL= 10,MXILVL= 20,MXDLIN=500) PARAMETER (MXFRAC= 13) PARAMETER (MXBANG= 10,MXBTAB= 10) PARAMETER (MXORIA= 1000) PARAMETER (MXSHOT= 10,MXZPAR=4*MXSHOT+2) +SEQ,DIMMAP. PARAMETER (MXWMAP= 4) PARAMETER (MXSOLI= 500) PARAMETER (MXPLAN= 5000,MXPOIN=20000,MXEDGE=100) PARAMETER (MXSBUF= 10000) PARAMETER (MXMCA = 10000) +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 * 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. * 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 * 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 * 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 * 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 30/11/00.) *----------------------------------------------------------------------- +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, - XT0,YT0,ZT0,XT1,YT1,ZT1, - TRMASS,TRENER,TRCHAR,TRXDIR,TRYDIR,TRZDIR,TRTH,TRPHI,TRDIST, - TRFLUX 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,NGBOX LOGICAL LTRMS,LTRDEL,LTRINT,LTREXB,TRFLAG,LINCAL, - LFULLB,LFULLP,LFULLT,LSPLIT,LSORT,LOUTL,LEPSG,LGSTEP 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, - XT0,YT0,ZT0,XT1,YT1,ZT1, - TRMASS,TRENER,TRCHAR,TRXDIR,TRYDIR,TRZDIR,TRTH,TRPHI,TRDIST, - TRFLUX, - INDPOS(1000),IPRMAT(3),NCTRW,NCPNAM, - ITRTYP,NTRLIN,NTRSAM,NTRFLX,NLINED,NINORD,NGRIDX,NGRIDY, - NCXLAB,NCYLAB,NCFPRO, - NPRCOL,ICOL0,ICOLBX,ICOLPL,ICOLST,ICOLW1,ICOLW2,ICOLW3, - ICOLD1,ICOLD2,ICOLD3,NGBOX, - LTRMS,LTRDEL,LTRINT,LTREXB,TRFLAG(10),LINCAL, - LFULLB,LFULLP,LFULLT,LSPLIT,LSORT,LOUTL,LEPSG,LGSTEP 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,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. * 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. * (Last changed on 5/12/00.) *----------------------------------------------------------------------- +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 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), - 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, - 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 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 * (Last changed on 27/ 3/98.) *----------------------------------------------------------------------- +KEEP,SOLIDS. DOUBLE PRECISION CBUF(MXSBUF) CHARACTER SOLTYP(MXSOLI) INTEGER NSOLID,ISTART(MXSOLI),ISOLTP(MXSOLI),INDSOL(MXSOLI), - ICCURR,IQ(MXPLAN),NQ,ISOLMT(MXSOLI) COMMON /SOLIDS/ CBUF,ISTART,INDSOL,ISOLTP,NSOLID,ICCURR, - IQ,NQ,ISOLMT COMMON /SOLCHR/ SOLTYP +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 = triangle 3rd order * 4 = parallelogram 1st order * 5 = parallelogram 2nd order * 6 = parallelogram 3rd order * 7 = tetragon 1st order * 8 = tetragon 2nd order * 9 = tetragon 3rd order * 11 = tetrahedron 1st order * 12 = tetrahedron 2nd order * 13 = tetrahedron 3rd order * 14 = parallelepiped 1st order * 15 = parallelepiped 2nd order * 16 = parallelepiped 3rd order * 17 = arbitrary hexahedron 1st order * 18 = arbitrary hexahedron 2nd order * 19 = arbitrary 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. * (Last changed on 29/11/99.) *----------------------------------------------------------------------- +KEEP,FIELDMAP. REAL EXMAP,EYMAP,EZMAP,EWXMAP,EWYMAP,EWZMAP,BXMAP,BYMAP,BZMAP, - VMAP,XMAP,YMAP,ZMAP,XMMIN,XMMAX,YMMIN,YMMAX,ZMMIN,ZMMAX, - XAMIN,XAMAX,YAMIN,YAMAX,ZAMIN,ZAMAX, - VMMIN,VMMAX,EPSMAT,EPSSUR INTEGER MATMAP,NMAP,NEPS,MAPORD,MAPTYP,IDRMAT,INDEWS(MXWMAP), - NWMAP LOGICAL MAPFLG,LMAPPL,SETAX,SETAY,SETAZ CHARACTER EWSTYP(MXWMAP) CHARACTER*10 MATSRC COMMON /FLDMAP/ VMAP(MXMAP,10), - 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,4),YMAP(MXMAP,4),ZMAP(MXMAP,4), - XMMIN,XMMAX,YMMIN,YMMAX,ZMMIN,ZMMAX, - XAMIN,XAMAX,YAMIN,YAMAX,ZAMIN,ZAMAX,VMMIN,VMMAX, - EPSMAT(MXEPS),EPSSUR(MXEPS),MATMAP(MXMAP), - MAPFLG(10+3*MXWMAP), - NMAP,NEPS,MAPORD,MAPTYP,IDRMAT,INDEWS,NWMAP, - LMAPPL,SETAX,SETAY,SETAZ COMMON /FLDCHR/ EWSTYP,MATSRC +KEEP,XGASDATA,IF=NEVER. *----------------------------------------------------------------------- * GASDAT - Common block containing information on the drift speed * GASCHR in the gas.. * VARIABLES : EGAS : E/p values [V/cm.torr]. * VGAS : Drift velocity || E [cm/microsec]. * XGAS : Drift velocity || ExB [cm/microsec]. * YGAS : Drift velocity || Btrans [cm/microsec]. * DGAS : Diffusion corresponding to E/P [cm2/sec]. * AGAS : Townsend coefficient, * BGAS : attachment coefficient, * MGAS : ion mobility * WGAS : Lorentz angle * CVGAS : Spline coefficients belonging to VGAS. * CXGAS : Spline coefficients belonging to XGAS. * CYGAS : Spline coefficients belonging to YGAS. * CDGAS : Spline coefficients belonging to DGAS. * CAGAS : Spline coefficients belonging to AGAS. * CBGAS : Spline coefficients belonging to BGAS. * CMGAS : Spline coefficients belonging to MGAS. * CWGAS : Spline coefficients belonging to WGAS. * NGAS : Number of points in EGAS, VGAS etc. * 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. * 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 || Bt * (9) electron drift velocity || Bt * (10) electron drift velocity || ExB * (11) transverse diffusion || ExB * (12) diffusion correlation(E,Bt) * (13) diffusion correlation(E,ExB) * (14) diffusion correlation(Bt,ExB) * 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. * MEXTR1...4 : Used for mobility coeff. extrapolation. * WEXTR1...4 : Used for Lorentz angle extrapolation. * OEXTR1...4 : Used for transv. diff. 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/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(V/D/A/B/M/W/O)METH : Interpolation method: 0 = spline, * higher: DIVDIF with order I(V/D/A/B/M)METH * HEEDOK : Tells whether HEED has been run. * GASDEN : Density of the gas in g/l for HEED. * (Last changed on 12/ 2/00.) *----------------------------------------------------------------------- +KEEP,GASDATA. DOUBLE PRECISION CLSDIS,CLSAVE REAL EGAS,VGAS,XGAS,YGAS,DGAS,AGAS,BGAS,MGAS,WGAS,OGAS, - CVGAS,CXGAS,CYGAS,CDGAS,CAGAS,CBGAS,CMGAS,CWGAS,COGAS, - VGAS2,XGAS2,YGAS2,DGAS2,AGAS2,BGAS2,MGAS2,WGAS2,OGAS2, - 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, - MEXTR1,MEXTR2,MEXTR3,MEXTR4, - WEXTR1,WEXTR2,WEXTR3,WEXTR4, - OEXTR1,OEXTR2,OEXTR3,OEXTR4, - GASRNG, - Z,A,RHO,CMEAN,EMPROB,EPAIR,PGAS,TGAS,GASDEN, - DTION,DLION LOGICAL GASOK,TAB2D,GASOPT,HEEDOK,GASSET INTEGER NGAS,NCLS,NBANG,NBTAB,NFTAB,NFCLS, - IVMETH,IXMETH,IYMETH,IDMETH,IAMETH,IBMETH,IMMETH, - IWMETH,IOMETH, - IVEXTR,IXEXTR,IYEXTR,IDEXTR,IAEXTR,IBEXTR,IMEXTR, - IWEXTR,IOEXTR, - JVEXTR,JXEXTR,JYEXTR,JDEXTR,JAEXTR,JBEXTR,JMEXTR, - JWEXTR,JOEXTR, - IATHR,IBTHR CHARACTER*80 GASID CHARACTER*(MXCHAR) FCNTAB,FCNCLS CHARACTER*10 CLSTYP COMMON /GASDAT/ CLSDIS(MXPAIR),CLSAVE, - EGAS(MXLIST), - VGAS(MXLIST),XGAS(MXLIST),YGAS(MXLIST),WGAS(MXLIST), - DGAS(MXLIST),OGAS(MXLIST),AGAS(MXLIST),BGAS(MXLIST), - MGAS(MXLIST), - CVGAS(MXLIST),CXGAS(MXLIST),CYGAS(MXLIST),CWGAS(MXLIST), - CDGAS(MXLIST),COGAS(MXLIST),CAGAS(MXLIST),CBGAS(MXLIST), - CMGAS(MXLIST), - 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), - MGAS2(MXLIST,MXBANG,MXBTAB), - BANG(MXBANG),BTAB(MXBTAB), - GASRNG(8,2), - 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, - MEXTR1,MEXTR2,MEXTR3,MEXTR4, - WEXTR1,WEXTR2,WEXTR3,WEXTR4, - OEXTR1,OEXTR2,OEXTR3,OEXTR4, - IVMETH,IXMETH,IYMETH,IDMETH,IAMETH,IBMETH,IMMETH, - IWMETH,IOMETH, - IVEXTR,IXEXTR,IYEXTR,IDEXTR,IAEXTR,IBEXTR,IMEXTR, - IWEXTR,IOEXTR, - JVEXTR,JXEXTR,JYEXTR,JDEXTR,JAEXTR,JBEXTR,JMEXTR, - JWEXTR,JOEXTR, - NGAS,NCLS,NBANG,NBTAB,NFTAB,NFCLS, - IATHR,IBTHR, - GASOK(14),GASOPT(14,4), - TAB2D,HEEDOK,GASSET COMMON /GASCHR/ FCNTAB,FCNCLS,CLSTYP,GASID +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,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 0=unknown, 1=RKF, 2=MC, 3=vacuum * 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 * isochrone as circle or straight line * EQTCLS : Maximum relative distance for an isochrone * to be closed * LEQSRT : Sort isochrones * LEQCRS : Check for drift line - isochrone crossings * LEQMRK : Mark rather than draw isochrones * (Last changed on 7/11/00.) *----------------------------------------------------------------------- +KEEP,DRIFTLINE. DOUBLE PRECISION XU,YU,ZU,TU,XTARG,YTARG,TMC,DMC REAL DXMIN,DYMIN,DZMIN,DXMAX,DYMAX,DZMAX,DTARG,EPSDFI,EPSTWI, - EPSATI,RDF2, - 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,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,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 * SIGSET : Ready for signal calculations. * RESSET : Time resolution has been set. * (Last changed on 16/ 1/00.) *----------------------------------------------------------------------- +KEEP,SIGNALDATA. LOGICAL FPERX,FPERY,LCROSS,TRASET,TRAFLG,LITAIL,LDTAIL,LRTAIL, - LEPULS,SIGSET,RESSET INTEGER NPAIR,ICLUST,NFOUR,MFEXP,MXMIN,MXMAX, - MYMIN,MYMAX,NTRBNK,ITRMAJ,NTIME,NORIA, - NASIMP,NISIMP,NCANG,JIORD,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,IENANG,NTIME,NORIA, - MFEXP,MXMIN,MXMAX,MYMIN,MYMAX,NTRBNK,NASIMP,NISIMP,NCANG, - TRASET,TRAFLG(9),FPERX,FPERY,LCROSS,LITAIL,LDTAIL,LRTAIL, - LEPULS,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 * (Last changed on 7/11/00.) *----------------------------------------------------------------------- +KEEP,INPUT. CHARACTER*(MXINCH+1) STRING CHARACTER*(MXINCH) ARGSTR CHARACTER*30 ERRCDE(MXWORD) CHARACTER*(MXCHAR) WORD(MXWORD) CHARACTER*80 PROMPT,EOFSTR,SHELL CHARACTER ESCAPE INTEGER NCHAR(MXWORD),INDWRD(MXWORD),ICHSET,LUNSTR(5:MXLUN,3), - NWORD,LUN,NCPROM,NCEOF,NCSH,NCARG LOGICAL ERRPRT(MXWORD),LPROM,DOEXEC,DOREAD,LINREC COMMON /INPCOM/ NCHAR,INDWRD,LUNSTR,NWORD,LUN,ICHSET,NCPROM, - ERRPRT,LPROM,DOEXEC,DOREAD,NCEOF,LINREC,NCSH,NCARG COMMON /INPCHR/ ERRCDE,STRING,WORD,PROMPT,EOFSTR,ESCAPE,SHELL, - ARGSTR +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 * (Last changed on 3/ 6/97.) *----------------------------------------------------------------------- +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) LOGICAL EXEC(MXINS),LIGUND COMMON /ALGDAT/ REG,ARG,MODARG,ARGREF,INS,MODREG,ALGENT, - NREG,NCONS,NINS,NERR,NAERR, - NRES,NALGE,IENTRL,ISYNCH,IINS0,ICONS0,EXEC,LIGUND +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. * 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. * 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. * 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) display area. * (Last changed on 9/ 9/99.) *----------------------------------------------------------------------- +KEEP,GRAPHICS. REAL USERX0,USERX1,USERY0,USERY1,FRXMIN,FRXMAX,FRYMIN,FRYMAX, - ARRANG,ARRLEN,DISPX0,DISPX1,DISPY0,DISPY1, - GPXN,GPXN10,GPYN,GPYN10,GPXL,GPYL,GPXT LOGICAL LGRID,LOGX,LOGY,LSTAMP,LGCLRB,LGCLRA,LWAITA,LWAITB,LXCCH INTEGER NWK,WKID(MXWKLS),WKCON(MXWKLS),WKFREF(MXWKLS), - WKLUN(MXWKLS),WKSTAT(MXWKLS),NCWKNM(MXWKLS),NCSTMP CHARACTER*20 WKNAME(MXWKLS),WKATTR(MXWKLS) CHARACTER*80 STAMP COMMON /GRADAT/ USERX0,USERX1,USERY0,USERY1,ARRANG,ARRLEN, - FRXMIN,FRXMAX,FRYMIN,FRYMAX,DISPX0,DISPX1,DISPY0,DISPY1, - GPXN,GPXN10,GPYN,GPYN10,GPXL,GPYL,GPXT, - LGRID,LOGX,LOGY,LSTAMP,LGCLRB,LGCLRA,LWAITA,LWAITB,LXCCH, - NWK,WKID,WKCON,WKFREF,WKLUN,WKSTAT,NCWKNM,NCSTMP COMMON /GRACHR/ WKNAME,WKATTR,STAMP +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: 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. * (Last changed on 20/ 2/97.) *----------------------------------------------------------------------- +KEEP,DOLOOP. INTEGER DOREF,IFREF,LINREF,CURLIN,CDOLVL,CIFLVL,TRACDO,TRACIF, - ISTATE,NDOLIN,NLOOP,NIF COMMON /DODAT/ LINREF(MXDLIN,8),DOREF(MXDLVL,10),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 20/ 3/97.) *----------------------------------------------------------------------- +KEEP,HISTDATA. REAL CONTEN(MXHIST,0:MXCHA+1),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 13/ 2/00.) *----------------------------------------------------------------------- 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=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. PRINT *,' ------------------------------------------------------' PRINT *,' News, including some old but important items. ' PRINT *,' ......................................................' PRINT *,' 28/09/92: Gas mixing a la G. Schultz & J. Gresser. ' PRINT *,' 19/02/94: Polygons (triangle - octagon) available. ' PRINT *,' 20/05/94: Magboltz gas mixing interface added. ' PRINT *,' 04/01/97: Monte Carlo drift line integration added. ' PRINT *,' 27/01/97: Heed clustering interface introduced. ' PRINT *,' 06/02/97: Transverse diffusion reduced in Magboltz. ' PRINT *,' 21/05/97: Reading Maxwell 2D field maps. ' PRINT *,' 28/10/97: Reading Maxwell 3D field maps. ' PRINT *,' 08/10/98: Isochrones in field maps enabled. ' PRINT *,' 31/01/99: Reading Tosca parallelepipedic field maps. ' PRINT *,' 30/04/99: Signals in other electrodes than wires. ' PRINT *,' 21/05/99: New arrival time distribution format. ' PRINT *,' 04/02/00: Magboltz 2 introduced. ' PRINT *,' 24/09/00: Heed interface corrected for cluster losses.' PRINT *,' ......................................................' PRINT *,' Garfield and Heed documentation is available via WWW ' PRINT *,' at http://consult.cern.ch/writeup/garfield ' PRINT *,' and http://consult.cern.ch/writeup/heed ' PRINT *,' ------------------------------------------------------' PRINT *,' ' PRINT *,' ' PRINT *,' Welcome, this is Garfield - version 7.04,'// - ' updated until 6/1/2001.' PRINT *,' ' *** Print a message when ready to start in interactive mode. IF(STDSTR('INPUT'))THEN PRINT *,' ================================================' PRINT *,' ========== Ready - Enter a header ==========' PRINT *,' ================================================' PRINT *,' ' 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(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 28/11/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PARAMETERS. +SEQ,CONSTANTS. +SEQ,CELLDATA. +SEQ,PRINTPLOT. +SEQ,INPUT. +SEQ,GASDATA. +SEQ,GASMIXDATA. +SEQ,DRIFTLINE. +SEQ,BFIELD. +SEQ,OPTDATA,IF=OPTIMISE. +SEQ,SIGNALDATA,IF=SIGNAL. +SEQ,CONTDATA. +SEQ,GLOBALS. +SEQ,DOLOOP. +SEQ,SOLIDS. EXTERNAL STDSTR,RNDM,RANFL LOGICAL STDSTR REAL RVEC(1),RNDM,RANFL,DUMMY DOUBLE PRECISION DVEC(1) CHARACTER*8 DATE,TIME INTEGER IFAIL,I,J,IREF,IRNDM,JRNDM,KRNDM +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. integer inpcmx,arg_length,iarg,nargs,iargc,inext character*128 args external inpcmx,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.04, C=6/1/01 Avalanche signals.') +SELF,IF=-VECTOR. CALL JOBLOG('Version S7.04, C=6/1/01 Avalanche signals.') +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. *** 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 *** 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 =.TRUE. LPROF =.TRUE. LMAPCH =.FALSE. LCNTAM =.TRUE. LINREC =STDSTR('INPUT') LGSTOP =.FALSE. LSYNCH =.FALSE. *** 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. * 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. * 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),'-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),'-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)) 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(IREF.LT.0) - CALL STRBUF('STORE',IREF,'< not known >',13,IFAIL) GLBMOD(2)=1 GLBVAL(2)=IREF 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 GLBVAR(5)='OK ' GLBMOD(5)=3 GLBVAL(5)=1 GLBVAR(7)='OUTPUT ' CALL STRBUF('STORE',IREF,'Standard output',15,IFAIL) GLBMOD(7)=1 GLBVAL(7)=IREF GLBVAR(8)='X ' GLBMOD(8)=2 GLBVAL(8)=0 NGLB=8 *** 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 NASIMP =2 NORIA =MIN(50,MXORIA) FCNANG =' ' NCANG =0 LITAIL =.TRUE. LDTAIL =.FALSE. LRTAIL =.FALSE. LEPULS =.FALSE. 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 +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 DUMMY=0 DO 10 I=1,IRNDM+JRNDM+KRNDM CALL RANLUX(RVEC,1) DUMMY=DUMMY+RANFL() CALL RM48(DVEC,1) DUMMY=DUMMY+RNDM(I)+RVEC(1) 10 CONTINUE IF(LDEBUG)PRINT *,' ++++++ INIT DEBUG : Number of'// - ' RNDM initialisation calls: ',IRNDM+JRNDM+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:') END +DECK,JOBLOGUX,IF=UNIX. 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 3/ 7/97.) *----------------------------------------------------------------------- +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=-DECS. CALL JOBNAM(NAME) HOST='Unknown' +SELF,IF=IBMRT,HPUX,SUN,DECS. irc=getlog(name) irc=hostnm(host) +SELF,IF=LINUX. NAME='Unknown' HOST='Linux' +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(UNIT=12,STATUS='UNKNOWN',ACCESS='SEQUENTIAL', - FILE='/afs/cern.ch/user/r/rjd/Garfield/Log/garfield.log', - IOSTAT=IOS,ERR=2020) *** Skip to the end of the file if the file is not new. 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 *** 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) 2040 CONTINUE 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 9/ 1/97.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. +SEQ,GRAPHICS. LOGICAL OPEN CHARACTER*20 OPSTR *** 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 +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 * 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'')') *** 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 5/ 1/01.) *----------------------------------------------------------------------- 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_LANDAU'.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 * 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 * 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 * 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')THEN IPROC=-206 ELSEIF(WORD(2)(IFIRST:ILAST).EQ.'ATTACHMENT')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.'GET_E/P_TABLE')THEN IPROC=-213 * 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 * 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_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 * 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 * 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 * 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_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 * 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 25/ 6/98.) *----------------------------------------------------------------------- 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 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 1/ 7/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,INPUT. +SEQ,PRINTPLOT. 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)RETURN *** 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.4)THEN ERRCDE(IWRD)='Hex number longer than 4 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. ' GOTO 100 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 20/ 2/91.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,INPUT. CHARACTER*(*) REF CHARACTER*80 REFSTR *** 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. *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,INPUT. CHARACTER*(*) STR1,STR2 CHARACTER*(MXWORD) WRDRES CHARACTER*30 ECDRES LOGICAL ERRRES INTEGER INPCMP 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 7/11/00.) *----------------------------------------------------------------------- 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) +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,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=-VAX,IF=-APOLLO,IF=-IBMRT,IF=-SUN,IF=-HPUX,IF=-LINUX,IF=-DECS. * 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 * 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 * Continue here if no conversion has been done. 70 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,NCHAR(I))) 200 CONTINUE WRITE(LUNOUT,'('' '')') ENDIF ENDIF *** Input line started with an IF clause. IF(IFLAG.EQ.+1)THEN CALL INPDEL(3) CALL INPDEL(2) CALL INPDEL(1) 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 29/ 3/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,ALGDATA. +SEQ,GLOBALS. +SEQ,PRINTPLOT. CHARACTER*(MXINCH) STRING,INDSTR CHARACTER*40 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,'' No Name Mode 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') WRITE(LUNOUT,'(2X,I3,5X,A10,5X,A10,5X,A)') - I,GLBVAR(I),MODE,VALUE(1:NC) 40 CONTINUE WRITE(LUNOUT,'(/2X,''Note: Variables 1 through 4 are'', - '' system defined.''/)') 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.4)THEN PRINT *,' !!!!!! INPGLB WARNING : This variable may'// - ' not be user redefined.' 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. 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 * 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)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) 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) 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) 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 7/11/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,INPUT. +SEQ,PRINTPLOT. +SEQ,GLOBALS. LOGICAL EXIST INTEGER NCFILE,IFAIL CHARACTER*100 INFILE +SELF,IF=UNIX. INTEGER I,NCHOME CHARACTER*80 HOME +SELF. *** Initial input logical unit, first input file. LUN=5 CALL STRBUF('STORE',LUNSTR(5,1),'Standard input',14,IFAIL) 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. 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. 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. 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. * 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=-UNIX. 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. CALL DSNOPN('garflast.dat',12,18,'WRITE-FILE',IFAIL) CALL DSNLOG('garflast.dat','Recording ', - 'Sequential','Write ') +SELF,IF=-CMS,IF=-VAX,IF=-UNIX. 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 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 23/ 5/90.) *----------------------------------------------------------------------- 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.4)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 29/ 3/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,DOLOOP. +SEQ,GLOBALS. +SEQ,ALGDATA. +SEQ,PRINTPLOT. CHARACTER*(MXCHAR) BLANK,FROM,STEP,WHILE,UNTIL,TO 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, - I,J,I0,I1,IFAIL1,IFAIL2,IFAIL3,IFAIL4,IFAIL5,NRES1,NRES2, - NRES3,NRES4,NRES5,ILLCHR,IGLB,NCPRM LOGICAL OK,USE(MXVAR) 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'// - ' lines; increase MXDLIN.' OK=.FALSE. NDOLIN=MXDLIN ENDIF *** Usually no global variable definition. LINREF(NDOLIN,7)=0 LINREF(NDOLIN,8)=0 *** Check whether the line is of the type IF cond THEN expr. CALL INPNUM(NWORD) IF(INPCMP(1,'IF')+INPCMP(1,'ELSEIF').NE.0.AND. - INPCMP(3,'THEN').NE.0)THEN * Check an IF block does not begin here. IF(INPCMP(4,'IF')+INPCMP(4,'ELSE')+INPCMP(4,'ELSEIF')+ - INPCMP(4,'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(4,'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. CALL INPSTR(2,2,STRING,NC) 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.GE.4)THEN CALL INPDEL(3) CALL INPDEL(2) CALL INPDEL(1) NWORD=NWORD-3 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,'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 STEP='1' NCSTEP=1 WHILE='TRUE' NCWHIL=4 UNTIL='FALSE' NCUNTL=5 TO=' ' NCTO=1 * 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 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 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 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 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 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 IF(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 CALL ALGPRE(STEP,NCSTEP,GLBVAR,NGLB,NRES2,USE, - DOREF(NLOOP,2),IFAIL2) IF(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 NRES5=1 IFAIL5=0 DOREF(NLOOP,5)=0 ELSE CALL ALGPRE(FROM,NCFROM,GLBVAR,NGLB,NRES1,USE, - DOREF(NLOOP,1),IFAIL1) CALL ALGPRE(TO,NCTO,GLBVAR,NGLB,NRES5,USE, - DOREF(NLOOP,5),IFAIL5) ENDIF ELSE IFAIL1=0 IFAIL2=0 IFAIL5=0 NRES1=1 NRES2=1 NRES5=1 ENDIF 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)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)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').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').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.3.AND.INPCMP(1,'IF').NE.0.AND. - INPCMP(3,'THEN').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.3.AND.INPCMP(1,'ELSEIF').NE.0.AND. - INPCMP(3,'THEN').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,'VECTOR')+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''/)') DO 210 I=1,NLOOP IF(DOREF(I,9).GT.0)THEN WRITE(LUNOUT,'(2X,I3,1X,A10,9I6)') I, - GLBVAR(DOREF(I,9)),(DOREF(I,J),J=1,8), - DOREF(I,10) 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 24/ 5/90.) *----------------------------------------------------------------------- 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 *** Check the setting of I1, I2. IF(I1.LT.1.OR.I2.LT.1.OR.I2-I1+1.GT.LENOUT.OR.I2.LT.I1)THEN PRINT *,' !!!!!! INPSTR WARNING : Input string is longer'// - ' than calling routine thought; string truncated.' IF(LDEBUG)WRITE(LUNOUT,'(26X,''I1='',I3,'', I2='',I3, - '', LEN(OUT)='',I3)') I1,I2,LENOUT IF(I1.LT.1)I1=1 IF(I2-I1+1.GT.LENOUT)I2=I1+LENOUT-1 IF(I2.LT.1)I2=1 IF(I2.LT.I1)I2=I1 ENDIF *** Set the output string and the number of characters. NC=MIN(I2-I1+1,LENOUT) OUT(1:NC)=STRING(I1:I2) END +DECK,INPSUB. SUBROUTINE INPSUB(STR,NC,IFAIL) *----------------------------------------------------------------------- * INPSUB - Evaluates global variables and substitutes them. * (Last changed on 20/ 3/01.) *----------------------------------------------------------------------- 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(100,MAX(1,NC))),OUT(1:MIN(100,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 31/ 8/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,INPUT. +SEQ,GLOBALS. CHARACTER*(*) STREAM LOGICAL DOXRES,RES,LINRES INTEGER LUNRES +SELF,IF=SAVE. SAVE LUNRES,DOXRES,RES +SELF. DATA LUNRES/5/, DOXRES/.FALSE./, RES/.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')THEN IF(RES)THEN LUN=LUNRES GLBVAL(6)=LUNSTR(LUN,1) DOEXEC=DOXRES LINREC=LINRES RES=.FALSE. ELSE 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 3/10/98.) *----------------------------------------------------------------------- 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:MIN(NC,100)) 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. * 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 24/ 2/91.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,INPUT. INTEGER IW,IINTEG,IREAL,IHEX,I *** First handle the case of incorrect arguments. IF(IW.LT.1.OR.IW.GT.NWORD)THEN INPTYP=-1 RETURN ENDIF *** Handle case of asterisk. IF(WORD(IW).EQ.'*')THEN INPTYP=4 RETURN ENDIF *** Initiliase the flag which are 1 for integers, reals and hex. IINTEG=1 IREAL=1 IHEX=1 *** Loop over the word. DO 10 I=1,NCHAR(IW) IF(INDEX('0123456789ABCDEF',WORD(IW)(I:I)).EQ.0)IHEX=0 IF(INDEX('.E',WORD(IW)(I:I)).NE.0)THEN IINTEG=0 ELSEIF(INDEX('01234567890+- ',WORD(IW)(I:I)).EQ.0)THEN IINTEG=0 IREAL=0 ENDIF 10 CONTINUE *** Determine the type from the value of the flags. IF(IINTEG.EQ.0.AND.IREAL.EQ.1)THEN INPTYP=2 ELSEIF(IINTEG.EQ.1)THEN INPTYP=1 ELSEIF(IHEX.EQ.1)THEN INPTYP=3 ELSE INPTYP=0 ENDIF 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 7/11/00.) *----------------------------------------------------------------------- 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 LOGICAL USE(MXVAR) C LOGICAL EXMEMB INTEGER NCMEMB,NCREM,NCFILE,NC,IFILE,LUNTRY,IEOF,NCAUX,IFAIL, - IKEY,I,IOS,IDOLLR,NNWORD,INPCMP,IDUMMY,NCESC,IENTRY,NREXP EXTERNAL INPCMP +SELF,IF=UNIX. 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 ALGEDT(GLBVAR,NGLB,IENTRY,USE,NREXP) 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=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. FILE='garflast.dat' NCFILE=12 +SELF,IF=CMS. FILE='GARFLAST.INPUT' NCFILE=14 +SELF,IF=-UNIX,IF=-CMS. 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. *** 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 27/ 6/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,DOLOOP. +SEQ,GLOBALS. +SEQ,PRINTPLOT. CHARACTER*(*) STRING REAL RES(5) INTEGER NC,IFLAG,OLDLVL,MODRES(5),ILOOP,IFAIL1,IFAIL2,IFAIL3, - IFAIL4,IFAIL5,IFAIL,IBLOCK,I LOGICAL IFCOND *** 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 a loop with variable, handle initial value. IF(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)) * Loop with variable: handle the loop variable. IF(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 25/ 5/99.) *----------------------------------------------------------------------- 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)IYEAR1=IYEAR1+100 READ(DATE2,'(BN,I2,1X,I2,1X,I2)') IDAY2,IMON2,IYEAR2 IF(IYEAR2.LT.84)IYEAR2=IYEAR2+100 *** 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. 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) ///' 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 3/ 6/97.) *----------------------------------------------------------------------- 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 EXTERNAL INPCMP +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,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,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,'(A133)',IOSTAT=IOS,ERR=2010) 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,'(A133)',IOSTAT=IOS,ERR=2010) 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,'(A133)',IOSTAT=IOS,ERR=2010) 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. 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) ///' 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. 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 17/ 3/92.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. CHARACTER*40 DSN CHARACTER*76 LIST(100) CHARACTER*(*) DSNAME CHARACTER*10 ACCESS,OPER,TYPNAM +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 WARNING : 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. 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/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. CHARACTER*(*) DSNAME,ACCESS CHARACTER*1 STRING LOGICAL EXBACK LOGICAL OPEN,EXIS CHARACTER*(MXNAME) FILE INTEGER NC,NCDSN,LUNDSN,IFAIL,IOS *** Identify the routine if requested. IF(LIDENT)PRINT *,' /// ROUTINE DSNOPN (Unix) ///' 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 *** 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 system('rm '//FILE(1:NC)//'.bak') CALL system('mv '//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 system('rm '//FILE(1:NC)//'.bak') CALL system('mv '//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 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) * 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)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. 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 21/ 1/00.) *----------------------------------------------------------------------- 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 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.'')') *** 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 *** 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 drift line 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.' RETURN 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_EXPONENTIAL.' 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 *** Mathieson fit on other data types. ELSEIF(IPROC.EQ.-65)THEN PRINT *,' !!!!!! ALGCAL WARNING : Mathieson fits are'// - ' only available for 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 6/11/99.) *----------------------------------------------------------------------- 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 CHARACTER*10 VARLIS(MXVAR) 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('$%?><',STRING(1:1)).NE.0)THEN PRINT *,' !!!!!! ALGEDT WARNING : This command cannot be'// - ' executed at the present level; first type EXIT.' GOTO 10 ELSEIF(STRING(1:1).EQ.'*')THEN GOTO 10 *** Add an entry point. ELSEIF(INPCMP(1,'ADD-EN#TRY-#POINT').NE.0)THEN * Update the record for the current entry point. ALGENT(NALGE,3)=1 ALGENT(NALGE,4)=1 ALGENT(NALGE,6)=NINS-IINS0+1 ALGENT(NALGE,10)=0 DO 80 I=ALGENT(NALGE,5),ALGENT(NALGE,5)+ALGENT(NALGE,6)-1 IF(INS(I,2).EQ.0)ALGENT(NALGE,10)=ALGENT(NALGE,10)+1 IF(INS(I,2).EQ.7.OR.ABS(INS(I,2)).EQ.9)ALGENT(NALGE,4)=0 IF(INS(I,2).NE.0.AND.INS(I,2).NE.6.AND.INS(I,2).NE.8.AND. - INS(I,2).NE.9)NCONS=MIN(NCONS,INS(I,1)) IF(ABS(INS(I,2)).NE.9)NCONS=MIN(NCONS,INS(I,3)) 80 CONTINUE ALGENT(NALGE,9)=ICONS0-NCONS+1 NREXP=ALGENT(NALGE,10) * Increment counters. 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 PRINT *,' !!!!!! ALGEDT WARNING : No room for a new'// - ' entry point; try a garbage collect.' GOTO 10 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 * Tell the user which entry point was added. WRITE(LUNOUT,'(/'' New entry point has reference '',I4,/ - '' and starts at line '',I4,''.'',/)') IENTRY,IINS0 *** Remove an entry point. ELSEIF(INPCMP(1,'CL#EAR-EN#TRY-#POINT').NE.0)THEN IF(NWORD.EQ.1)THEN IENCLR=IENTRY ELSEIF(NWORD.EQ.2)THEN IF(INPTYP(2).NE.1)THEN CALL INPMSG(2,'Entry point is not an integer.') IENCLR=0 ELSE CALL INPCHK(2,1,IFAIL1) CALL INPRDI(2,IENCLR,0) ENDIF ELSE PRINT *,' !!!!!! ALGEDT WARNING : CLEAR-ENTRY-POINT'// - ' has either 1 or no argument; nothing cleared.' IENCLR=0 ENDIF CALL ALGCLR(IENCLR) *** Print the number of instructions. ELSEIF(0.NE.INPCMP(1,'C#OUNT'))THEN WRITE(LUNOUT,'(/'' Current number of instructions:'',I4, - ''.''/)') NINS *** Set or display the entry point. ELSEIF(0.NE.INPCMP(1,'D#ISPLAY-EN#TRY-#POINT'))THEN * Read the optional argument (entry point reference number). IENDSP=0 IF(NWORD.EQ.1)THEN IENDSP=IENTRY ELSEIF(NWORD.EQ.2)THEN IF(INPTYP(2).NE.1)THEN CALL INPMSG(2,'Entry point is not an integer.') ELSE CALL INPCHK(2,1,IFAIL1) CALL INPRDI(2,IENTRR,0) IENTNO=0 DO 50 I=1,NALGE IF(ALGENT(I,1).EQ.IENTRR)IENTNO=I 50 CONTINUE IF(IENTNO.EQ.0)THEN CALL INPMSG(2, - 'Entry point does not exist. ') ELSE IENDSP=IENTRR ENDIF ENDIF ELSE PRINT *,' !!!!!! ALGEDT WARNING : DISPLAY-ENTRY-'// - 'POINT has 1 or no arguments; statement ignored.' IENDSP=0 ENDIF * Attempt to locate the entry point in the table. IENTNO=0 DO 40 I=1,NALGE IF(ALGENT(I,1).EQ.IENDSP)IENTNO=I 40 CONTINUE * Display the data if found. IF(IENTNO.NE.0)THEN WRITE(LUNOUT,'(/'' ENTRY POINT DESCRIPTION:''// - 5X,''Reference number: '',I4/ - 5X,''In use (1) or not (0): '',I4/ - 5X,''Correct (1) or not (0): '',I4/ - 5X,''Sequential (1) or not (0): '',I4/ - 5X,''First instruction at line: '',I4/ - 5X,''Number of instructions: '',I4/ - 5X,''Number of registers used: '',I4/ - 5X,''First local constant at: '',I4/ - 5X,''Number of local constants: '',I4/ - 5X,''Number of results produced: '',I4/)') - (ALGENT(IENTNO,I),I=1,10) * Display an error message if the entry point was not found. ELSEIF(IENDSP.NE.0)THEN PRINT *,' !!!!!! ALGEDT WARNING : Unable to find'// - ' the entry point; make sure it is still defined.' ENDIF *** Check whether routine execution can be finished. ELSEIF(0.NE.INPCMP(1,'EX#IT'))THEN * Find out which variables are effectively used. DO 20 I1=1,NVAR USE(I1)=.FALSE. DO 30 I2=1,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. 30 CONTINUE 20 CONTINUE * Update the entry point record. IF(NALGE.GT.0.AND.NALGE.LT.MXALGE)THEN ALGENT(NALGE,3)=1 ALGENT(NALGE,4)=1 ALGENT(NALGE,6)=NINS-IINS0+1 ALGENT(NALGE,10)=0 DO 70 I=ALGENT(NALGE,5), - ALGENT(NALGE,5)+ALGENT(NALGE,6)-1 IF(INS(I,2).EQ.0)ALGENT(NALGE,10)=ALGENT(NALGE,10)+1 IF(INS(I,2).EQ.7.OR.ABS(INS(I,2)).EQ.9) - ALGENT(NALGE,4)=0 IF(INS(I,2).NE.0.AND.INS(I,2).NE.6.AND. - INS(I,2).NE.8.AND.INS(I,2).NE.9) - NCONS=MIN(NCONS,INS(I,1)) IF(ABS(INS(I,2)).NE.9)NCONS=MIN(NCONS,INS(I,3)) 70 CONTINUE ALGENT(NALGE,9)=ICONS0-NCONS+1 NREXP=ALGENT(NALGE,10) ELSE PRINT *,' !!!!!! ALGEDT WARNING : No instructions'// - ' left on EXIT.' NREXP=0 ENDIF PRINT *,' ' PRINT *,' ------------------------------------------------' PRINT *,' ---------- Algebra subsection end ----------' PRINT *,' ------------------------------------------------' PRINT *,' ' * Reset the prompt. CALL INPPRM(' ','BACK-PRINT') RETURN *** Provide a means to enter a function directly. ELSEIF(0.NE.INPCMP(1,'F#UNCTION'))THEN IF(NWORD.LE.1)THEN PRINT *,' !!!!!! ALGEDT WARNING : No function'// - ' provided; nothing done.' ELSE CALL INPSTR(2,MXWORD,STRING,NC) IENTRY=IENTRY-1 IENTRL=IENTRL-1 IINS0=ALGENT(NALGE,5) ICONS0=ALGENT(NALGE,8) NINS=IINS0-1 NCONS=ICONS0+1 NALGE=NALGE-1 CALL ALGPRE(STRING,NC,VARLIS,NVAR,NNRES,USE,IENTRY, - IFAIL) PRINT *,' ' IF(IFAIL.EQ.0)THEN PRINT *,' Translation succeeded, ',NNRES, - ' results are produced.' ELSE PRINT *,' Translation did NOT succeed.' ENDIF PRINT *,' ' IF(NNRES.NE.NREXP.AND.NREXP.NE.0)PRINT *,' Note: the'// - ' calling section expects ',NREXP,' results.' ENDIF *** Garbage collect. ELSEIF(INPCMP(1,'GARB#AGE-#COLLECT').NE.0)THEN CALL ALGGBC *** Insertion of instructions. ELSEIF(INPCMP(1,'I#NSERT').NE.0)THEN IF(NWORD.GT.2)THEN PRINT *,' !!!!!! ALGEDT WARNING : INSERT needs 1'// - ' argument ; the instruction is ignored.' GOTO 10 ELSEIF(NWORD.EQ.1)THEN INS0=NINS+1 IFAIL=0 ELSE CALL INPCHK(2,1,IFAIL) CALL INPRDI(2,INS0,NINS+1) IF(INS0.LT.1.OR.INS0.GT.NINS+1) - CALL INPMSG(2,'Argument out of range. ') CALL INPERR ENDIF IF(INS0.LT.1.OR.INS0.GT.NINS+1.OR.IFAIL.EQ.1)THEN PRINT *,' !!!!!! ALGEDT WARNING : Incorrect syntax'// - ' or value of argument for INSERT; line ignored.' GOTO 10 ENDIF * Make sure there is room to insert lines. IF(NINS.GE.MXINS)THEN PRINT *,' !!!!!! ALGEDT WARNING : No room to insert'// - ' new lines ; delete some or increase MXINS.' GOTO 10 ENDIF * Ask for the new lines, initialise the insert counter: INSC. INSC=NINS PRINT *,' ====== ALGEDT INPUT : Please enter new'// - ' lines, terminate with a blank line.' CALL INPPRM('Ins','ADD-NOPRINT') 200 CONTINUE * Check that the insert counter can still be incremented. IF(INSC+1.GT.MXINS)THEN PRINT *,' !!!!!! ALGEDT WARNING : No further lines'// - ' can be accepted; delete some or increase MXINS.' GOTO 210 ENDIF * Read the line to be inserted, CALL INPGET CALL INPNUM(NWORD) IF(NWORD.EQ.0)GOTO 210 * and check that the types are correct. CALL INPCHK(1,1,IFAIL1) CALL INPCHK(2,1,IFAIL2) CALL INPCHK(3,1,IFAIL3) CALL INPCHK(4,1,IFAIL4) CALL INPERR IF(IFAIL1.NE.0.OR.IFAIL2.NE.0.OR.IFAIL3.NE.0.OR. - IFAIL4.NE.0.OR.NWORD.NE.4)THEN GOTO 200 ENDIF * Read the contents of the line and check the syntax. INSC=INSC+1 CALL INPRDI(1,INS(INSC,1),MXREG+1) CALL INPRDI(2,INS(INSC,2), 10) CALL INPRDI(3,INS(INSC,3),MXREG+1) CALL INPRDI(4,INS(INSC,4),MXREG+1) IF(ISYNCH.EQ.1.AND. - ((INS(INSC,2).EQ.6.AND.(INS(INSC,1).GT.10.OR. - INS(INSC,1).LT.-9)).OR. - (INS(INSC,2).EQ.0.AND.INS(INSC,3).LT.0).OR. - (INS(INSC,2).LT.0.OR.INS(INSC,2).GT.17.OR. - (INS(INSC,2).GT.7.AND.INS(INSC,2).LT.10)).OR. - (((INS(INSC,2).GE.1.AND.INS(INSC,2).LE.5).OR. - (INS(INSC,2).GE.10.AND.INS(INSC,2).LE.17)).AND. - (INS(INSC,1).LT.MXCONS.OR.INS(INSC,1).GT.MXREG)).OR. - INS(INSC,3).LT.MXCONS.OR.INS(INSC,3).GT.MXREG.OR. - INS(INSC,4).LT.MXCONS.OR.INS(INSC,4).GT.MXREG))THEN PRINT *,' !!!!!! ALGEDT WARNING : Line is invalid'// - ' in ALGEBRA mode; ignored.' INSC=INSC-1 ELSEIF(ISYNCH.EQ.2)THEN PRINT *,' !!!!!! ALGEDT WARNING : PROCEDURE mode'// - ' checking is not yet available; to to NONE.' ISYNCH=0 ENDIF GOTO 200 * End of the list reached. 210 CONTINUE * Reset the prompt. CALL INPPRM(' ','BACK-PRINT') * Move the inserted lines to their new position. DO 230 I=1,INSC-NINS DO 240 J=1,4 IBUF(J)=INS(NINS+I,J) INS(NINS+I,J)=INS(INS0+I-1+INSC-NINS,J) INS(INS0+I-1+INSC-NINS,J)=INS(INS0+I-1,J) INS(INS0+I-1,J)=IBUF(J) 240 CONTINUE 230 CONTINUE NINS=INSC *** Handle the range of the instructions needing one. ELSEIF(INPCMP(1,'L#IST')+INPCMP(1,'PR#INT')+ - INPCMP(1,'DEL#ETE')+INPCMP(1,'EXEC#UTE').NE.0)THEN IF(NINS.EQ.0)THEN PRINT *,' The instruction buffer is empty.' GOTO 10 ENDIF CALL INPSTR(1,1,STRING,NC) IF(NWORD.EQ.1)THEN ILIST1=1 ILIST2=NINS ELSEIF(NWORD.EQ.2)THEN CALL INPCHK(2,1,IFAIL) CALL INPRDI(2,ILIST1,1) IF(IFAIL.NE.0)THEN CALL INPERR PRINT *,' !!!!!! ALGEDT WARNING : Incorrect'// - ' argument type for '//STRING(1:NC)//'.' GOTO 10 ENDIF IF(ILIST1.LE.0.OR.ILIST1.GT.NINS)THEN PRINT *,' !!!!!! ALGEDT WARNING : The argument'// - ' is out of range for '//STRING(1:NC)//'.' GOTO 10 ENDIF ILIST2=ILIST1 ELSEIF(NWORD.EQ.3)THEN CALL INPCHK(2,1,IFAIL1) CALL INPRDI(2,ILIST1,1) IF(0.EQ.INPCMP(3,'L#AST'))THEN CALL INPCHK(3,1,IFAIL2) CALL INPRDI(3,ILIST2,NINS) ELSE IFAIL2=0 ILIST2=NINS ENDIF IF(IFAIL1.NE.0.OR.IFAIL2.NE.0)THEN CALL INPERR PRINT *,' !!!!!! ALGEDT WARNING : Incorrect'// - ' argument type(s) for '//STRING(1:NC)//'.' GOTO 10 ENDIF IF(ILIST1.LE.0.OR.ILIST2.GT.NINS.OR.ILIST1.GT.ILIST2) - PRINT *,' !!!!!! ALGEDT WARNING : Incorrect'// - ' argument range for '//STRING(1:NC)// - '; adjusted to the bounds.' ILIST1=MIN(NINS,MXINS,MAX(1,ILIST1)) ILIST2=MAX(ILIST1,MIN(ILIST2,NINS,MXINS)) ELSE PRINT *,' !!!!!! ALGEDT WARNING : Number of'// - ' arguments incorrect for '//STRING(1:NC)//'.' GOTO 10 ENDIF * Deleting of instructions, update the entry point also. IF(INPCMP(1,'DEL#ETE').NE.0)THEN DO 140 IENT=1,NALGE IF(ALGENT(IENT,5).LE.ILIST1.AND.(IENT.EQ.NALGE.OR. - ALGENT(MIN(IENT+1,NALGE),5).GT.ILIST1))THEN IF(ALGENT(IENT,2).EQ.0)THEN PRINT *,' !!!!!! ALGEDT WARNING : The'// - ' lines to be deleted start in'// - ' a cleared entry point; ignored.' GOTO 10 ELSEIF(ALGENT(IENT,6).GE.ILIST2-ILIST1+1)THEN IENUPD=IENT GOTO 150 ELSE PRINT *,' !!!!!! ALGEDT WARNING : The'// - ' range of lines to be deleted spans'// - ' more than 1 entry point; ignored.' GOTO 10 ENDIF ENDIF 140 CONTINUE PRINT *,' ###### ALGEDT ERROR : Unable to find the'// - ' entry point for the delete range; program bug.' GOTO 10 150 CONTINUE DO 110 IDEL=ILIST1,NINS-(ILIST2-ILIST1)-1 DO 120 ICOPY=1,4 INS(IDEL,ICOPY)=INS(IDEL+(ILIST2-ILIST1)+1,ICOPY) 120 CONTINUE 110 CONTINUE IF(ILIST2.LT.IINS0)IINS0=IINS0-ILIST2+ILIST1-1 NINS=NINS-ILIST2+ILIST1-1 ALGENT(IENUPD,6)=ALGENT(IENUPD,6)-ILIST2+ILIST1-1 DO 160 IENT=IENUPD+1,NALGE ALGENT(IENT,5)=ALGENT(IENT,5)-ILIST2+ILIST1-1 160 CONTINUE * Executing instructions. ELSEIF(INPCMP(1,'EXEC#UTE').NE.0)THEN DO 130 IEXEC=ILIST1,ILIST2 IF(INS(IEXEC,2).EQ.0.OR.INS(IEXEC,2).EQ.7.OR. - INS(IEXEC,2).EQ.8.OR.ABS(INS(IEXEC,2)).EQ.9)THEN PRINT *,' The following instruction is not'// - ' executed:' CALL ALGPRT(IEXEC,IEXEC) GOTO 130 ELSE CALL ALGEX2(IEXEC,IFAIL) IF(IFAIL.NE.0)THEN WRITE(LUNOUT,*) ' ++++++ ALGEDT DEBUG :'// - ' Arithmetic error while evaluating:' CALL ALGPRT(IEXEC,IEXEC) IF(INS(IEXEC,2).EQ.6)WRITE(LUNOUT,1010) - INS(IEXEC,3),REG(INS(IEXEC,3)) IF(INS(I,2).NE.6)WRITE(LUNOUT,1010) - INS(IEXEC,1),REG(INS(IEXEC,1)), - INS(IEXEC,3),REG(INS(IEXEC,3)) WRITE(LUNOUT,'('' '')') ENDIF ENDIF 130 CONTINUE * Listing of instructions. ELSEIF(INPCMP(1,'L#IST').NE.0)THEN WRITE(LUNOUT,'('' '')') DO 100 ILIST=ILIST1,ILIST2 WRITE(LUNOUT,'(1X,I3,'' : '',4I4)') - ILIST,(INS(ILIST,I),I=1,4) 100 CONTINUE WRITE(LUNOUT,'('' '')') * Printing of the instructions. ELSEIF(INPCMP(1,'PR#INT').NE.0)THEN CALL ALGPRT(ILIST1,ILIST2) ENDIF *** Show memory occupation. ELSEIF(INPCMP(1,'MEM#ORY').NE.0)THEN WRITE(LUNOUT,'(/'' GLOBAL MEMORY USAGE:''// - 5X,''Number of registers in use: '',I3/ - 5X,''Number of constants in use: '',I3/ - 5X,''Number of instructions in use: '',I3/, - 5X,''Number of entry points in use: '',I3/)') - NREG,-NCONS,NINS,NALGE IF(NALGE.GE.1)THEN WRITE(LUNOUT,'(/'' USAGE PER ENTRY POINT:''// - '' Refno Instructions Registers'', - '' Constants Comments'')') DO 510 I=1,NALGE NCPRT=0 STRING=' ' IF(ALGENT(I,2).EQ.0)THEN STRING(NCPRT+1:NCPRT+9)='Cleared, ' NCPRT=NCPRT+9 ENDIF IF(ALGENT(I,3).EQ.0)THEN STRING(NCPRT+1:NCPRT+13)='Not useable, ' NCPRT=NCPRT+13 ENDIF IF(NCPRT.LT.3)NCPRT=3 WRITE(LUNOUT,'(5X,I5,3I15,2X,A)') ALGENT(I,1), - ALGENT(I,6),ALGENT(I,7),ALGENT(I,9), - STRING(1:NCPRT-2) 510 CONTINUE WRITE(LUNOUT,'('' '')') ELSE WRITE(LUNOUT,'(/'' NO ENTRY POINTS IN USE.''/)') ENDIF *** Take care of the options. ELSEIF(INPCMP(1,'OPT#IONS').NE.0)THEN IF(NWORD.EQ.1)THEN WRITE(LUNOUT,'(/'' LOCAL OPTIONS CURRENTLY IN'', - '' EFFECT:'')') IF(ISYNCH.EQ.0)THEN WRITE(LUNOUT,'(/'' Instruction list lines'', - '' are not checked.'')') ELSEIF(ISYNCH.EQ.1)THEN WRITE(LUNOUT,'(/'' Instruction list lines'', - '' are checked on ALGEBRA syntax.'')') ELSEIF(ISYNCH.EQ.2)THEN WRITE(LUNOUT,'(/'' Instruction list lines'', - '' are checked on PROCEDURE syntax.'')') ENDIF IF(LIGUND)THEN WRITE(LUNOUT,'('' Exponential underflow'', - '' is ignored.''/)') ELSE WRITE(LUNOUT,'('' Exponential underflow'', - '' is signaled.''/)') ENDIF ENDIF DO 310 I=2,NWORD IF(INPCMP(I,'NO-SYN#TAX-#CHECK').NE.0)THEN ISYNCH=0 ELSEIF(INPCMP(I,'ALG#EBRA-SYN#TAX-#CHECK').NE.0)THEN ISYNCH=1 ELSEIF(INPCMP(I,'PRO#CEDURE-SYN#TAX-#CHECK').NE.0)THEN ISYNCH=2 ELSEIF(INPCMP(I,'I#GNORE-UND#ERFLOW')+ - INPCMP(I,'I#GNORE-EXP#ONENTIAL-UND#ERFLOW').NE.0)THEN LIGUND=.TRUE. ELSEIF(INPCMP(I,'S#IGNAL-UND#ERFLOW')+ - INPCMP(I,'S#IGNAL-EXP#ONENTIAL-UND#ERFLOW').NE.0)THEN LIGUND=.FALSE. ELSE CALL INPMSG(I,'The option is not known. ') ENDIF 310 CONTINUE CALL INPERR *** Set/show register values, if the keyword is REGISTER. ELSEIF(0.NE.INPCMP(1,'R#EGISTER'))THEN CALL INPCHK(2,1,IFAIL1) CALL INPCHK(3,2,IFAIL2) CALL INPERR IF(NWORD.LE.1.OR.NWORD.GT.3)THEN PRINT *,' !!!!!! ALGEDT WARNING : Incorrect number'// - ' of arguments for the REGISTER instruction.' ELSEIF(NWORD.EQ.2.AND.IFAIL1.NE.0.OR. - NWORD.EQ.3.AND.(IFAIL1.NE.0.OR.IFAIL2.NE.0))THEN PRINT *,' !!!!!! ALGEDT WARNING : Incorrect argument'// - ' type(s) for the REGISTER instruction.' ELSE CALL INPRDI(2,I,1) IF(I.LT.MXCONS.OR.I.GT.MXREG)THEN PRINT *,' !!!!!! ALGEDT WARNING : The argument'// - ' to REGISTER is not a valid array index.' ELSE IF(NWORD.EQ.2)WRITE(LUNOUT,'(/'' Current value'', - '' of register '',I3,'' is '',E15.8,''.''/)') - I,REG(I) IF(NWORD.EQ.3)CALL INPRDR(3,REG(I),0.0) ENDIF ENDIF *** Reset the algebra system. ELSEIF(INPCMP(1,'RESE#T').NE.0)THEN * Initialise. CALL ALGINT * Assign a new entry point. NALGE=1 IENTRY=IENTRL+1 IENTRL=IENTRL+1 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 number of results the calling section expects. ELSEIF(INPCMP(1,'RESU#LTS').NE.0)THEN IF(NREXP.NE.0)THEN PRINT *,' The calling section expects ',NREXP, - ' results.' ELSE PRINT *,' The calling section did not specify the', - ' number of expected results.' ENDIF *** Simplify the instruction list. ELSEIF(INPCMP(1,'SIM#PLIFY').NE.0)THEN NREG=0 NCONS=0 DO 410 I=1,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 IF(NREG.LT.INS(I,1))NREG=INS(I,1) IF(NCONS.GT.INS(I,1))NCONS=INS(I,1) ENDIF IF(ABS(INS(I,2)).NE.9)THEN IF(NREG.LT.INS(I,3))NREG=INS(I,3) IF(NCONS.GT.INS(I,3))NCONS=INS(I,3) ENDIF 410 CONTINUE CALL ALGSIM(VARLIS,NVAR,USE,IFAIL) *** Allow testing of the instruction list. ELSEIF(0.NE.INPCMP(1,'TEST'))THEN IF(NWORD.NE.1+NVAR)THEN PRINT *,' !!!!!! ALGEDT WARNING : Each parameter to'// - ' the function must be specified when using TEST.' ELSE IFAIL=0 DO 320 I=2,NWORD CALL INPCHK(I,2,IFAIL1) IF(IFAIL1.NE.0)IFAIL=1 CALL INPRDR(I,VAR(I-1),0.0) MODVAR(I-1)=2 320 CONTINUE CALL INPERR IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! ALGEDT WARNING : Syntax errors'// - ' in the test parameters ; line ignored.' GOTO 10 ENDIF DO 330 I=1,10 RES(I)=0.0 330 CONTINUE CALL ALGEXE(IENTRY,VAR,MODVAR,NVAR,RES,MODRES,10,IFAIL) WRITE(LUNOUT,'(/'' Elements in the result array'', - '' which have been assigned a value.''/ - '' ============================'', - ''=================================''/)') DO 340 I=1,10 IPRINT=0 DO 341 J=1,NINS IF(INS(J,2).EQ.0.AND.INS(J,4).EQ.I)IPRINT=1 341 CONTINUE IF(IPRINT.EQ.1)WRITE(LUNOUT,'('' Result('',I3, - '') = '',E15.8)') I,RES(I) 340 CONTINUE IF(IFAIL.NE.0)THEN WRITE(LUNOUT,'(/'' Note: an error has'', - '' been detected.''/)') ELSE WRITE(LUNOUT,'(/'' No errors detected.''/)') ENDIF ENDIF *** Show the variable names if VARIABLES is the keyword. ELSEIF(0.NE.INPCMP(1,'VAR#IABLES'))THEN WRITE(LUNOUT,'(/'' List of acceptable variable names:''/ - '' ==================================''/)') DO 300 I=1,NVAR WRITE(LUNOUT,'(5X,A10,'' --> 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 3/ 6/97.) *----------------------------------------------------------------------- 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 number 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) *** 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 31/10/99.) *----------------------------------------------------------------------- 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) *** Output formats. 1060 FORMAT(26X,'REG(',I3,')=',E15.7:'; REG(',I3,')=',E15.7) *** 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 *** Lines of the result-assignment type. IF(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) ENDIF IFAIL=1 GOTO 3000 ENDIF * Back transfer of arguments to origin registers and variables. DO 100 I=1,INS(INEXT,3) 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 31/10/99.) *----------------------------------------------------------------------- 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) *** Output formats. 1060 FORMAT(26X,'REG(',I3,')=',E15.7:'; REG(',I3,')=',E15.7) *** 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 *** Lines of the result-assignment type. IF(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) ENDIF IFAIL=1 GOTO 3000 ENDIF * Back transfer of arguments to origin registers and variables. DO 100 I=1,INS(INEXT,3) 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 18/ 3/01.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,ALGDATA. +SEQ,MATDATA. EXTERNAL RNDUNI,RANLAN,RNDEXP,RNDNOR,RNDPOL,RNDFUN,DENLAN REAL RNDUNI,RANLAN,RNDEXP,RNDNOR,RNDPOL,RNDFUN,DENLAN,EPS INTEGER I,IFAIL,IFAIL1,NPOIS,IERR,NCAUX,IREF,ISIZ(1),ISLOT,MATSLT CHARACTER*20 AUXSTR EXTERNAL MATSLT *** 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)).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.88.0)THEN NAERR(2)=NAERR(2)+1 RETURN ELSEIF(REG(INS(I,3)).LT.-88.0)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))) * 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 * 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) 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 18/ 3/01.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,ALGDATA. +SEQ,PRINTPLOT. +SEQ,GLOBALS. INTEGER I,J,IFAIL,IFAIL1,IFAIL2,IFAIL3,NC1,NC2,IREF CHARACTER*(MXINCH) STR1,STR2 *** 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 * 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 6/10/00.) *----------------------------------------------------------------------- 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 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 *** 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 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 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 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 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 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 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 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).GT.0)THEN CONTEN(IHIST4,J)=CONTEN(IHIST1,J)**CONTEN(IHIST3,J) ELSE 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(ABS(CONTEN(IHIST3,J)).GT.88.0)RETURN CONTEN(IHIST4,J)=EXP(CONTEN(IHIST3,J)) 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(CONTEN(IHIST3,J)) 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)=RNDUNI(REG(INS(I,3))) ELSEIF(INS(I,1).EQ.22)THEN CONTEN(IHIST4,J)=RNDNOR(0.0,1.0) ELSEIF(INS(I,1).EQ.23)THEN CONTEN(IHIST4,J)=RNDEXP(CONTEN(IHIST3,J)) ELSEIF(INS(I,1).EQ.24)THEN CALL RNPSSN(CONTEN(IHIST3,J),NPOIS,IERR) CONTEN(IHIST4,J)=REAL(NPOIS) ELSEIF(INS(I,1).EQ.25)THEN CONTEN(IHIST4,J)=RANLAN(RNDUNI(1.0)) ELSEIF(INS(I,1).EQ.26)THEN CONTEN(IHIST4,J)=RNDPOL(CONTEN(IHIST3,J)) ELSEIF(INS(I,1).EQ.27)THEN CONTEN(IHIST4,J)=RNDFUN(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 18/ 3/01.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,ALGDATA. +SEQ,MATDATA. +SEQ,GLOBALS. +SEQ,PRINTPLOT. REAL DENLAN,RNDUNI,RANLAN,RNDEXP,RNDNOR,RNDPOL,RNDFUN,EPS 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 *** 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 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 RETURN ENDIF ELSEIF(MODREG(INS(I,3)).EQ.5)THEN * Validity of reference number. IF(IMAT3.LE.0)THEN MODREG(INS(I,4))=0 REG(INS(I,4))=0 IF(LDEBUG)PRINT *,' ++++++ ALGEX6 DEBUG :'// - ' Refering to unbooked matrix ',IMAT3 RETURN ENDIF * 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)PRINT *,' ++++++ ALGEX6 DEBUG : Creating'// - ' a scalar 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)PRINT *,' ++++++ 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)PRINT *,' ++++++ ALGEX6 DEBUG : Creating'// - ' a scalar 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)PRINT *,' ++++++ 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.MODREG(INS(I,1)).EQ.5)THEN IMAT1=MATSLT(IREF1) IF(IMAT1.LE.0)THEN IF(LDEBUG)PRINT *,' ++++++ ALGEX6 DEBUG : Unable'// - ' to locate matrix 1.' RETURN ENDIF ENDIF * Third word. IF(MODREG(INS(I,3)).EQ.5)THEN IMAT3=MATSLT(IREF3) IF(IMAT3.LE.0)THEN IF(LDEBUG)PRINT *,' ++++++ ALGEX6 DEBUG : Unable'// - ' to locate matrix 3.' RETURN ENDIF ENDIF * Result. IMAT4=MATSLT(IREF4) IF(IMAT4.LE.0)THEN IF(LDEBUG)PRINT *,' ++++++ ALGEX6 DEBUG : Unable'// - ' to locate 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).GT.0)THEN MVEC(MORG(IMAT4)+J)=MVEC(MORG(IMAT1)+J)** - MVEC(MORG(IMAT3)+J) ELSE MVEC(MORG(IMAT4)+J)=0.0 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(ABS(MVEC(MORG(IMAT3)+J)).GT.88.0)RETURN MVEC(MORG(IMAT4)+J)=EXP(MVEC(MORG(IMAT3)+J)) 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)) 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((SX2-SX1**2/MLEN(IMAT3))/ - MLEN(IMAT3)) ENDIF 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 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)) 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,ALGINT. SUBROUTINE ALGINT *----------------------------------------------------------------------- * ALGINT - Subroutine (re)initialising the /ALGDAT/ common block. * (Last changed on 30/ 8/99.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,ALGDATA. +SEQ,CONSTANTS. INTEGER I,J,IENTRY REAL CUMRNF(200) LOGICAL FUNSET COMMON /RNDFCM/ IENTRY,FUNSET,CUMRNF *** Initial number of constants, registers, results, errors, instr. NCONS=-6 ICONS0=-7 NREG=0 NRES=0 NINS=0 IINS0=1 *** Initialise error count. DO 60 I=1,100 NAERR(I)=0 60 CONTINUE NERR=0 *** Initialise the executability and the instructions. DO 10 I=1,MXINS EXEC(I)=.TRUE. INS(I,1)=0 INS(I,2)=0 INS(I,3)=0 INS(I,4)=0 10 CONTINUE *** Initialise the values of all registers. DO 20 I=MXCONS,MXREG REG(I)=0 20 CONTINUE *** Initialise the constants. REG(0) =0.0 REG(-1)=1.0 REG(-2)=2.0 REG(-3)=PI REG(-4)=0 REG(-5)=1 REG(-6)=0 MODREG(0) =2 MODREG(-1)=2 MODREG(-2)=2 MODREG(-3)=2 MODREG(-4)=3 MODREG(-5)=3 MODREG(-6)=0 *** Set the checking mode to algebra. ISYNCH=1 *** Algebra options. LIGUND=.FALSE. *** Initialise the entry reference table. DO 30 I=1,MXALGE DO 40 J=1,9 ALGENT(I,J)=0 40 CONTINUE 30 CONTINUE NALGE=0 IENTRL=0 *** Initialise the argument list and argument reference table. DO 50 I=1,MXARG ARG(I)=0.0 MODARG(I)=0 ARGREF(I,1)=-1 ARGREF(I,2)=MXREG+1 50 CONTINUE *** Random number generators. FUNSET=.FALSE. END +DECK,ALGPRE. SUBROUTINE ALGPRE(T,NT,VARLIS,NVAR,NNRES,USE,IENTRY,IFAIL) *----------------------------------------------------------------------- * ALGPRE - Subroutine translating the string T into a series of state- * ments to be executed by ALGEXE. * VARIABLES : VARLIS : List of acceptable parameter names. * NVAR : Number of elements in the VARLIS array. * T : The input string, it has NT elements. * S : Is T where operators have been replaced by * O, functions by F, constants and variables * by R. * P : Specifies which operation, function, * register is meant by the code in S. * USE(I) : .TRUE. if variable I is effectively used. * NNRES : =NRES, number of results found in T. * CHAR, NEXT, STRING, AUX: Auxiliary. * (Last changed on 11/ 3/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,ALGDATA. +SEQ,PRINTPLOT. CHARACTER CHAR,NEXT CHARACTER*9 MODFLG CHARACTER*10 VARLIS(MXVAR) CHARACTER*(*) T CHARACTER*(MXINCH) S INTEGER P(MXINCH),NBRACK,NINDEX,NT,NVAR,NNRES,IENTRY,IFAIL, - I,J,II,IT,IS,IV,IC,IN,IR,IFAILR,IFAILS,IFAILC,IAUX,LASTOP, - NDIM,IDIM,IDIM0,IARG,ISEND,JS,LENS,IIS,I1,I2, - MINREG,MAXREG,ISTART,IEXEC,NPASS REAL EPS,AUX LOGICAL OPER,LETTER,NUMBER,CHANGE,USE(MXVAR),REJECT,LOOP,PREC, - PRECS,RNDUSE,USECON *** Define some statement function to ease decoding. OPER (CHAR)=INDEX('+-*/=#<>&|^~',CHAR).NE.0 LETTER(CHAR)=INDEX('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 S(IS+1:IS+1)='$' 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 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 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.'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(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 * Print the list if LDEBUG is on. IF(LDEBUG)WRITE(LUNOUT,'(/26X,''Code string:''/26X,A)') - S(1:MIN(LEN(S),IS+1)) * Replace $-, (-, O- and F- by functions (-6), $+ etc by F +6. DO 160 IS=1,LEN(S)-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,LEN(S)-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,LEN(S)-1 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,LEN(S)-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.30)RNDUSE=.TRUE. INS(NINS,2)=6 INS(NINS,3)=P(IS+1) IF(P(IS+1).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 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,LEN(S)-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,LEN(S)-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,LEN(S)-1 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,LEN(S) 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 ** Print the current string. IF(LDEBUG)THEN IF(CHANGE)THEN DO 241 IIS=LEN(S),1,-1 IF(S(IIS:IIS).NE.' ')THEN LENS=IIS GOTO 242 ENDIF 241 CONTINUE LENS=1 242 CONTINUE WRITE(LUNOUT,'(26X,''Pass'',I3,'': '',A)') - NPASS,S(1:LENS) 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,LEN(S)-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,LEN(S)-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))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 21/ 7/00.) *----------------------------------------------------------------------- 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 * The instruction is a RESULT type statement IF(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.+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.+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,COLSHM. SUBROUTINE COLSHM *----------------------------------------------------------------------- * COLSHM - Plots a colour map for the shadowing effects. * (Last changed on 30/11/00.) *----------------------------------------------------------------------- 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=9 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))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') 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) 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 25/ 3/00.) *----------------------------------------------------------------------- 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') 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 a fill area. ELSEIF(IPROC.EQ.-807)THEN * Check number of arguments. IF(NARG.LT.6.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. DO 60 I=1,2*(NARG/2) IF(MODARG(I).NE.2)THEN PRINT *,' !!!!!! GRACAL WARNING : Some arguments of'// - ' PLOT_AREA are of incorrect type.' RETURN ENDIF 60 CONTINUE * 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.GE.1)THEN CALL CLTOU(TITLE(1:NCTIT)) CALL GRATTS(TITLE(1:NCTIT),'AREA') ENDIF ELSE IFAIL1=0 ENDIF * Plot the line segment. 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) * 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 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 *** 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 * 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_MARKERS.' 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='CROSS' NCTIT=5 IFAIL1=0 ENDIF CALL GRATTS(TITLE(1:NCTIT),'POLYMARKER') * Plot the markers. CALL MATPMK(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 PLOT_MARKERS.' *** 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.) *** Set a window. ELSEIF(IPROC.EQ.-813)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_WINDOW; not executed.' RETURN ELSE CALL GSWN(NINT(ARG(1)),ARG(2),ARG(3),ARG(4),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(0.1,1.0-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(0.9,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(GPYL,0.9,YTXT(1:NCYTXT)) * Restore. CALL GSELNT(1) CALL GSTXAL(0,0) CALL GSCHUP(0.0,1.0) *** 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) *----------------------------------------------------------------------- * GRACWK - Activates a workstation - GKS version. * (Last changed on 9/10/95.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. +SEQ,GRAPHICS. EXTERNAL INPCMX INTEGER INPCMX,IWK,IFAIL,IERR,ISTATE CHARACTER*(*) NAME *** Locate workstation. CALL GRQIWK(NAME,IWK,IFAIL) IF(IFAIL.NE.0)RETURN *** 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) 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 21/ 5/97.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,GRAPHICS. +SEQ,PRINTPLOT. CHARACTER*(MXCHAR) STRING CHARACTER*(MXNAME) FILE CHARACTER*20 NAME LOGICAL KTYPE,KCONID,KOFF,KFILE,KGKSID INTEGER NC,IKEY,INEXT,NWORD,NCFILE,IOFF,ICO,ICONID,IWKTYP,ICAT,I, - IFAIL1,INPCMP,NCNAME,IERR EXTERNAL INPCMP *** 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 *,' !!!!!! 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 *** 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,NWORD IF(I.LT.INEXT)GOTO 20 * Each keyword has 1 argument. IF(I+1.GT.NWORD)THEN CALL INPMSG(I,'Argument is missing.') GOTO 20 ENDIF * Type specification. IF(INPCMP(I,'TY#PE').NE.0)THEN CALL INPSTR(I+1,I+1,STRING,NC) CALL GRWKID(STRING(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. * GKS identifier. ELSEIF(INPCMP(I,'GKS-ID#ENTIFIER').NE.0)THEN 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. * Connection identifier. ELSEIF(INPCMP(I,'CON#NECTION-ID#ENTIFIER').NE.0)THEN CALL INPCHK(I+1,1,IFAIL1) CALL INPRDI(I+1,ICONID,0) INEXT=I+2 KCONID=.TRUE. * Logical unit offset. ELSEIF(INPCMP(I,'OFF#SET').NE.0)THEN CALL INPCHK(I+1,1,IFAIL1) CALL INPRDI(I+1,IOFF,0) INEXT=I+2 KOFF=.TRUE. * File name. ELSEIF(INPCMP(I,'F#ILE-NAME')+INPCMP(I,'NAME').NE.0)THEN CALL INPSTR(I+1,I+1,FILE,NCFILE) INEXT=I+2 KFILE=.TRUE. * Anything else is not valid. ELSE CALL INPMSG(I,'Not a valid keyword.') ENDIF 20 CONTINUE *** 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 +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. IF(NWK.GE.MXWKLS)THEN PRINT *,' !!!!!! GRADWK WARNING : No storage left for'// - ' workstations; ignored.' RETURN ENDIF NWK=NWK+1 WKNAME(NWK)=NAME(1:NCNAME) NCWKNM(NWK)=NCNAME WKID(NWK)=IWKTYP IF(KFILE)THEN CALL STRBUF('STORE',WKFREF(NWK),FILE,NCFILE,IFAIL1) WKCON(NWK)=IOFF ELSE WKFREF(NWK)=-1 WKCON(NWK)=ICONID ENDIF WKSTAT(NWK)=0 END +DECK,GRAINP. SUBROUTINE GRAINP *----------------------------------------------------------------------- * GRAINP - Serves as a subsection reading graphics command lines. * (Last changed on 12/ 9/99.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PARAMETERS. +SEQ,GRAPHICS. +SEQ,CONTDATA. +SEQ,PRINTPLOT. +SEQ,CONSTANTS. LOGICAL LOOP INTEGER INPCMP,NWORD,INEXT,I,NC,MXOPWK,MXACWK,MXWKAS,INIT,IERR, - IKEY,IFAIL,IFAIL1,NITERR,NSTEPR,IDEFM,IREGM,IEMPTY,IFRAME, - LEVEL,ISTA,IDEFD,IUPDD,IDEF,IUPD,IWK,IDUM1,IDUM2,IDUM,NACT REAL EPSR,DNR,AUX CHARACTER*(MXCHAR) STRING EXTERNAL INPCMP +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)) 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 WRITE(LUNOUT,'('' Current tip length: '',F10.3, - '' x total length.'')') ARRLEN ELSE CALL INPCHK(IKEY+1,2,IFAIL1) CALL INPRDR(IKEY+1,ARRLEN,ARRLEN) 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)) 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,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)) 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 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 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 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 WRITE(LUNOUT,'(/'' LIST OF CURRENTLY KNOWN'', - '' WORKSTATIONS: ''// - '' No Workstation name State '', - '' Type C/O Unit File name''/)') DO 70 I=1,NWK WRITE(STRING,'(I3,'': '',A20,9X,3(I5,1X),20X)') - I,WKNAME(I),WKID(I),WKCON(I),WKLUN(I) STRING(27:33)='unknown' IF(WKSTAT(I).LT.2)STRING(27:33)='defined' IF(WKSTAT(I).EQ.2)STRING(27:33)=' open' IF(WKSTAT(I).EQ.3)STRING(27:33)=' active' IF(WKFREF(I).GT.0)THEN CALL STRBUF('READ',WKFREF(I),STRING(53:80),NC, - IFAIL1) ELSE STRING(47:51)=' -' STRING(53:80)='not associated with a file' ENDIF WRITE(LUNOUT,'(1X,A79)') STRING(1:79) 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)) 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-#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,'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/ - '' 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/)') - LGRID,LSTAMP,LOGX,LOGY,LGCLRB,LGCLRA, - LWAITB,LWAITA,LXCCH 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.' *** 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.' *** Reset the colour table. ELSEIF(INPCMP(IKEY,'RESET-#COLOURS')+ - INPCMP(IKEY,'!RESET-#COLOURS').NE.0)THEN CALL GRCOLS *** 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 24/ 5/91.) *----------------------------------------------------------------------- CHARACTER*40 LIST(100) CHARACTER*(*) NAME +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 WARNING : 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 30/ 8/93.) *----------------------------------------------------------------------- +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,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 11/ 5/96.) *---------------------------------------------------------------------- +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,' ') 1050 FORMAT(F6.1,' ') 1030 FORMAT(A5,I1,' ') 1040 FORMAT(A5,I2,' ') *** 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(1.015*RMAX*COS(ANGLE)) YSC=YUTOD(1.015*RMAX*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) 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 30/11/00.) *----------------------------------------------------------------------- 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 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 EXTERNAL INPTYP,INPCMP,INPCMX,DSNCMP *** Buffer declarations, first the sizes. INTEGER MXPLBU,MXPMBU,MXTXBU,MXFABU PARAMETER(MXPLBU=40,MXPMBU=40,MXTXBU=40,MXFABU=40) * 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 /35/ DATA (LINNAM(I),LINWID(I),LINTYP(I),LINCOL(I),I=1,35) / - '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, - 'ISO#CHRONES ', 1.00, 2, 1, - 'DR#IFT-L#INE ', 1.00, 1, 1, - 'E-DR#IFT-L#INE ', 1.00, 1, 1, - 'ION-DR#IFT-L#INE ', 1.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, - 'PL#ANES ', 1.00, 1, 1, - 'STR#IPS ', 3.00, 1, 1, - 'TUBE ', 1.00, 1, 1, - 'TR#ACK ', 1.00, 2, 1, - 'PHOTON ', 1.00, 3, 1, - 'DELTA-#ELECTRON ', 1.00, 2, 1, - 'AUGER-#ELECTRON ', 1.00, 2, 1, - 'SOLID ', 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, - 'DASH#ED ', 1.00, 2, 1, - 'DOT#TED ', 1.00, 3, 1, - 'DASH-DOT#TED ', 1.00, 4, 1, - 'ERR#OR-BAR ', 1.00, 1, 1, - 'ERR#OR-BAND ', 1.00, 1, 1, - 'OUT#LINE ', 1.00, 1, 1/ * Next the polymarkers. DATA NMRK /21/ DATA (MRKNAM(I),MRKSIZ(I),MRKTYP(I),MRKCOL(I),I=1,21) / - '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#CHRONES ', 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/ * 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 /27/ DATA (FARNAM(I),FARPAS(1,I),FARPAS(2,I),FARREF(1,I),FARREF(2,I), - FARINT(I),FARSTY(I),FARCOL(I),I=1,27) / +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. - '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, - 'FUNCTION-1 ', 1.00, 1.00, 0.00, 0.00, 0, 0, 1, - 'FUNCTION-2 ', 1.00, 1.00, 0.00, 0.00, 0, 0, 1, - 'FUNCTION-3 ', 1.00, 1.00, 0.00, 0.00, 0, 0, 1, - 'FUNCTION-4 ', 1.00, 1.00, 0.00, 0.00, 0, 0, 1, - 'FUNCTION-5 ', 1.00, 1.00, 0.00, 0.00, 0, 0, 1, - 'FUNCTION-6 ', 1.00, 1.00, 0.00, 0.00, 0, 0, 1, - 'FUNCTION-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').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').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').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').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 *** 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,GRCELL. SUBROUTINE GRCELL(VXMIN,VYMIN,VXMAX,VYMAX,TITLE) *----------------------------------------------------------------------- * GRCELL - Draws the cell within the specified region. * (Last changed on 12/11/98.) *----------------------------------------------------------------------- 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')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 8/10/98.) *----------------------------------------------------------------------- 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')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 8/10/98.) *----------------------------------------------------------------------- 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),CROSSD,CUT,PLOTX,PLOTY EXTERNAL CROSSD 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/ +SELF,IF=SAVE. SAVE IADJAC +SELF. *** 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)=U4 XPL(2)=U1 YPL(1)=V4 YPL(2)=V1 CALL GPL2(2,XPL,YPL) PHIARR=ATAN2(YPL(2)-YPL(1),XPL(2)-XPL(1)) XPL(1)=U1-SQRT((U1-U4)**2+(V1-V4)**2)* - 0.2*COS(PHIARR+ARRANG) YPL(1)=V1-SQRT((U1-U4)**2+(V1-V4)**2)* - 0.2*SIN(PHIARR+ARRANG) XPL(2)=U1 YPL(2)=V1 XPL(3)=U1-SQRT((U1-U4)**2+(V1-V4)**2)* - 0.2*COS(PHIARR-ARRANG) YPL(3)=V1-SQRT((U1-U4)**2+(V1-V4)**2)* - 0.2*SIN(PHIARR-ARRANG) CALL GPL2(3,XPL,YPL) CALL GTX(REAL(U4+1.2*(U1-U4)), - 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)=U4 XPL(2)=U2 YPL(1)=V4 YPL(2)=V2 CALL GPL2(2,XPL,YPL) PHIARR=ATAN2(YPL(2)-YPL(1),XPL(2)-XPL(1)) XPL(1)=U2-SQRT((U2-U4)**2+(V2-V4)**2)* - 0.2*COS(PHIARR+ARRANG) YPL(1)=V2-SQRT((U2-U4)**2+(V2-V4)**2)* - 0.2*SIN(PHIARR+ARRANG) XPL(2)=U2 YPL(2)=V2 XPL(3)=U2-SQRT((U2-U4)**2+(V2-V4)**2)* - 0.2*COS(PHIARR-ARRANG) YPL(3)=V2-SQRT((U2-U4)**2+(V2-V4)**2)* - 0.2*SIN(PHIARR-ARRANG) CALL GPL2(3,XPL,YPL) CALL GTX(REAL(U4+1.2*(U2-U4)), - 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)=U4 XPL(2)=U3 YPL(1)=V4 YPL(2)=V3 CALL GPL2(2,XPL,YPL) PHIARR=ATAN2(YPL(2)-YPL(1),XPL(2)-XPL(1)) XPL(1)=U3-SQRT((U3-U4)**2+(V3-V4)**2)* - 0.2*COS(PHIARR+ARRANG) YPL(1)=V3-SQRT((U3-U4)**2+(V3-V4)**2)* - 0.2*SIN(PHIARR+ARRANG) XPL(2)=U3 YPL(2)=V3 XPL(3)=U3-SQRT((U3-U4)**2+(V3-V4)**2)* - 0.2*COS(PHIARR-ARRANG) YPL(3)=V3-SQRT((U3-U4)**2+(V3-V4)**2)* - 0.2*SIN(PHIARR-ARRANG) CALL GPL2(3,XPL,YPL) CALL GTX(REAL(U4+1.2*(U3-U4)), - 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) 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 8/10/98.) *---------------------------------------------------------------------- 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(OPTION.NE.'PLOT')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 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 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 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(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(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(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. 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(0,0) CALL GSCHUP(0.0,1.0) CALL GSELNT(0) CALL GRTX(0.1,0.95,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)=0.95+0.04*COS(0.02*I*PI) YU(I)=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)=0.95+XAUX YU(1)=0.05+YAUX+0.005 XU(2)=0.95+XAUX YU(2)=0.05+YAUX-0.005 CALL GPL2(2,XU,YU) XU(1)=0.95+XAUX+0.005 YU(1)=0.05+YAUX XU(2)=0.95+XAUX-0.005 YU(2)=0.05+YAUX CALL GPL2(2,XU,YU) CALL GSELNT(1) 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 30/10/99.) *---------------------------------------------------------------------- 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,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)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,0.1-GPXN10-YPOWER,'1') ELSEIF(IDEC.EQ.1)THEN CALL GSTXAL(2,1) CALL GRTX(XSC,0.1-GPXN10-YPOWER,'10') ELSE CALL GSTXAL(2,1) CALL GRTX(XSC,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,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,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(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)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(0.1-GPYN10,YSC,'1') ELSEIF(IDEC.EQ.1)THEN CALL GSTXAL(3,3) CALL GRTX(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(0.1-GPYN10-XPOWER,YSC,'10') CALL GSTXAL(1,0) CALL GRTX(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(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(0.1,1.0-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(0.9,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(1.0-GPYL-XPOWER,GPXL+YPOWER,'*10') CALL GRATTS('NUMBERS','TEXT') CALL GRTX(1.0-GPYL,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(GPYL,0.9,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(GPYL,0.92,'*10') CALL GRATTS('NUMBERS','TEXT') CALL GRTX(GPYL+XPOWER,0.92+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) END +DECK,GRCLWK. SUBROUTINE GRCLWK(NAME) *----------------------------------------------------------------------- * GRCLWK - Closes a workstation - GKS version. * (Last changed on 21/ 3/92.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. +SEQ,GRAPHICS. EXTERNAL INPCMX INTEGER INPCMX CHARACTER*(*) NAME CHARACTER*(MXNAME) AUX *** Locate workstation. CALL GRQIWK(NAME,IWK,IFAIL) IF(IFAIL.NE.0)RETURN *** 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 5/ 9/99.) *----------------------------------------------------------------------- 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 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,'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 3/ 6/98.) *----------------------------------------------------------------------- implicit none 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(0.1,0.93,TEXT) ELSEIF(I.EQ.2)THEN CALL GRTX(0.1,0.91,TEXT) ELSEIF(I.EQ.3)THEN CALL GRTX(0.5,0.93,TEXT) ELSEIF(I.EQ.4)THEN CALL GRTX(0.5,0.91,TEXT) ELSEIF(I.EQ.5)THEN CALL GRTX(0.1,0.01,TEXT) ENDIF *** Switch back to the regular coordinate system. CALL GSELNT(1) 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 5/ 9/93.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. +SEQ,GRAPHICS. EXTERNAL STDSTR CHARACTER*80 DUMMY LOGICAL STDSTR,WAIT *** 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 30 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 30 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 27/ 6/98.) *---------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PARAMETERS. +SEQ,GRAPHICS. CHARACTER*(*) XTXT,TITLE CHARACTER*20 AUX1,AUX2,AUX3 INTEGER NCHA,I,IOUT,NC1,NC2,NC3 REAL XPL(MXLIST),YPL(MXLIST),CONTEN(0:NCHA+1),SUM,XMIN,XMAX, - YMIN,YMAX 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((YMIN.GT.0.0).AND.(.NOT.LOGY))YMIN=0.0 IF(YMAX.LE.YMIN)YMAX=YMIN+1.0 YMAX=1.1*YMAX *** 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. CALL GRATTS('FUNCTION-1','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 9/ 9/99.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,GRAPHICS. +SEQ,PRINTPLOT. +SEQ,CONSTANTS. CHARACTER*8 DATE,TIME CHARACTER*(MXNAME) FILE +SELF,IF=APOLLO,CRAY,UNIX. CHARACTER*1 STRING +SELF,IF=CMS. INTEGER IFAIL +SELF,IF=HIGZ. INTEGER NWORDS REAL RPAW PARAMETER (NWORDS=50000) COMMON /PAWC/ RPAW(NWORDS) +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='GKS_error.log',STATUS='UNKNOWN',IOSTAT=IOS, - ERR=2020) CALL DSNLOG('GKS_error.log','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=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=CRAY,UNIX. *** Open a file for GKS error messages. OPEN(UNIT=10,FILE='GKS_error.log',STATUS='UNKNOWN',IOSTAT=IOS, - ERR=2020) CALL DSNLOG('GKS_error.log','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=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=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 * 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))) CALL GRACWK(WKNAME(NWK)(1:NCWKNM(NWK))) 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),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))) CALL GRACWK(WKNAME(NWK)(1:NCWKNM(NWK))) 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. 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. STAMP=' with Garfield version 7.04.' 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 *** Handle problems when opening various files RETURN +SELF,IF=APOLLO,CMS,CRAY,UNIX,VAX. 2010 CONTINUE PRINT *,' ###### GRINIT ERROR : Unable to write the graphics'// - ' error logging file ; end of program execution.' CALL INPIOS(IOS) CALL QUIT +SELF,IF=APOLLO,CMS,CRAY,UNIX. 2020 CONTINUE PRINT *,' ###### GRINIT ERROR : Unable to open the graphics'// - ' error logging file ; end of program execution.' CALL INPIOS(IOS) CALL QUIT +SELF. END +DECK,GRLINE. SUBROUTINE GRLINE(NU,XU,YU) *----------------------------------------------------------------------- * GRLINE - Draws a line in either log or linear coordinates. * (Last changed on 13/ 2/97.) *----------------------------------------------------------------------- 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 * 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. 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,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 27/ 6/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,GRAPHICS. +SEQ,PRINTPLOT. INTEGER NU,I REAL XU(NU),YU(NU),XPL(MXLIST),YPL(MXLIST) *** Check number of points. IF(NU.GT.MXLIST)WRITE(10,'('' !!!!!! GRMARK WARNING : Buffer'', - '' overflow, NU='',I3,''; bug, please report.'')') NU IF(LDEBUG)WRITE(10,'('' ++++++ GRMARK DEBUG : Line has '',I3, - '' points, scales: '',2L1)') NU,LOGX,LOGY *** Copy, transforming if needed. DO 10 I=1,MIN(NU,MXLIST) IF(LOGX)THEN IF(XU(I).LE.0.0)THEN C WRITE(10,'('' !!!!!! GRMARK WARNING : Negative'', C - '' value x='',E12.5,'' received.'')') XU(I) XPL(I)=FRXMIN-2*ABS(FRXMAX-FRXMIN) ELSE XPL(I)=LOG10(XU(I)) ENDIF ELSE XPL(I)=XU(I) ENDIF IF(LOGY)THEN IF(YU(I).LE.0.0)THEN C WRITE(10,'('' !!!!!! GRMARK WARNING : Negative'', C - '' value y='',E12.5,'' received.'')') YU(I) YPL(I)=FRYMIN-2*ABS(FRYMAX-FRYMIN) ELSE YPL(I)=LOG10(YU(I)) ENDIF ELSE YPL(I)=YU(I) ENDIF IF(LDEBUG)WRITE(10,'(26X,2E12.5,'' -> '',2E12.5)') - XU(I),YU(I),XPL(I),YPL(I) 10 CONTINUE *** Plot the line. CALL GPM(MIN(NU,MXLIST),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. SUBROUTINE GRMETA(IWKTYP,IOFF,FILE,NCFILE,IFLAG,IFAIL) *----------------------------------------------------------------------- * GRMETA - Returns the workstation identifier from the command line. * (Last changed on 21/ 1/00.) *----------------------------------------------------------------------- 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. integer iargc,nargs,iarg external iargc +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 external inpcmx *** Default settings. call grwkid('*batch_default',iwktyp,ioff,icat,idum) file='garfield.metafile' ncfile=17 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 -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 ** 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 *** Things worked fine. ifail=0 end +DECK,GRMETAV,IF=VAX. SUBROUTINE GRMETA(IWKTYP,IOFF,FILE,NCFILE,IFLAG,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 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,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 *** 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 26/ 5/94.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,PARAMETERS. +SEQ,GRAPHICS. +SEQ,PRINTPLOT. CHARACTER*120 STRING CHARACTER*8 DATE,TIME EXTERNAL STDSTR LOGICAL STDSTR *** 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(0.96,0.96,'Plotted at '//TIME//' on '//DATE// - STRING(1:NCSTR)) * Restore the normal environment. CALL GSTXAL(0,0) CALL GRTX(0.03,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,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. END +DECK,GRAOPT. SUBROUTINE GRAOPT(OPT) *----------------------------------------------------------------------- * GRAOPT - Log/linear scales and other options. * (Last changed on 18/ 6/98.) *----------------------------------------------------------------------- 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').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),'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)') - LOGX,LOGY,LGRID,LSTAMP,LGCLRB,LGCLRA,LWAITB,LWAITA, - LXCCH RETURN ENDIF 10 CONTINUE END +DECK,GRARRO. SUBROUTINE GRARRO(X0,Y0,X1,Y1) *----------------------------------------------------------------------- * GRARRO - Plots an arrow. * (Last changed on 2/ 7/99.) *----------------------------------------------------------------------- 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(2)-VIEWP(1))*(LOG10(X0)-WINDOW(1))/ - (WINDOW(2)-WINDOW(1)) ELSEIF(LOGX)THEN X0NDC=-1 ELSE X0NDC=(VIEWP(2)-VIEWP(1))*(X0-WINDOW(1))/ - (WINDOW(2)-WINDOW(1)) ENDIF IF(LOGX.AND.X1.GT.0)THEN X1NDC=(VIEWP(2)-VIEWP(1))*(LOG10(X1)-WINDOW(1))/ - (WINDOW(2)-WINDOW(1)) ELSEIF(LOGX)THEN X1NDC=-1 ELSE X1NDC=(VIEWP(2)-VIEWP(1))*(X1-WINDOW(1))/ - (WINDOW(2)-WINDOW(1)) ENDIF IF(LOGY.AND.Y0.GT.0)THEN Y0NDC=(VIEWP(4)-VIEWP(3))*(LOG10(Y0)-WINDOW(3))/ - (WINDOW(4)-WINDOW(3)) ELSEIF(LOGY)THEN Y0NDC=-1 ELSE Y0NDC=(VIEWP(4)-VIEWP(3))*(Y0-WINDOW(3))/ - (WINDOW(4)-WINDOW(3)) ENDIF IF(LOGY.AND.Y1.GT.0)THEN Y1NDC=(VIEWP(4)-VIEWP(3))*(LOG10(Y1)-WINDOW(3))/ - (WINDOW(4)-WINDOW(3)) ELSEIF(LOGY)THEN Y1NDC=-1 ELSE Y1NDC=(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) ALEN=SQRT((X1NDC-X0NDC)**2+(Y1NDC-Y0NDC)**2) XPL(1)=X1NDC-ALEN*ARRLEN*COS(DBLE(PHIARR)+ARRANG) YPL(1)=Y1NDC-ALEN*ARRLEN*SIN(DBLE(PHIARR)+ARRANG) XPL(2)=X1NDC YPL(2)=Y1NDC XPL(3)=X1NDC-ALEN*ARRLEN*COS(DBLE(PHIARR)-ARRANG) YPL(3)=Y1NDC-ALEN*ARRLEN*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 13/11/96.) *----------------------------------------------------------------------- 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(2)-VIEWP(1))*(LOG10(XTXT)-WINDOW(1))/ - (WINDOW(2)-WINDOW(1)) ELSEIF(LOGX)THEN XNDC=-1 ELSE XNDC=(VIEWP(2)-VIEWP(1))*(XTXT-WINDOW(1))/ - (WINDOW(2)-WINDOW(1)) ENDIF IF(LOGY.AND.YTXT.GT.0)THEN YNDC=(VIEWP(4)-VIEWP(3))*(LOG10(YTXT)-WINDOW(3))/ - (WINDOW(4)-WINDOW(3)) ELSEIF(LOGY)THEN YNDC=-1 ELSE YNDC=(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 13/12/00.) *----------------------------------------------------------------------- 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+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+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+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+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+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+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+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+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.'&sqrt;')THEN STROUT(NOUT+1:NOUT+6)='"\\122#' INEXT=I+6 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+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+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+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+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+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+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+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+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 * 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+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.'CH4')THEN STROUT(NOUT+1:NOUT+5)='CH?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+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+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 * 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,'(25X,''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 18/10/93.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,CONTDATA. +SEQ,PRINTPLOT. REAL FC,XST,YST,DIR,X0,Y0,X1,Y1,X2,Y2 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,I3,A)') ' !!!!!! GRCTRA WARNING : Stepped'// - ' into forbidden zone, 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) *----------------------------------------------------------------------- * GRDAWK - Deactivates a workstation - GKS version. * (Last changed on 21/ 3/92.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. +SEQ,GRAPHICS. EXTERNAL INPCMX INTEGER INPCMX,IWK,IFAIL,IERR,ISTATE CHARACTER*(*) NAME *** Locate workstation. CALL GRQIWK(NAME,IWK,IFAIL) IF(IFAIL.NE.0)RETURN *** 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)) ENDIF IF(WKSTAT(IWK).EQ.2)THEN PRINT *,' !!!!!! GRDLWK WARNING : '//NAME(1:NCNAME)// - ' is still open ; closing ...' CALL GRCLWK(NAME(1:NCNAME)) 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) 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) *----------------------------------------------------------------------- * GROPWK - Opens a workstation - version for GKS. * (Last changed on 6/ 3/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. +SEQ,GRAPHICS. EXTERNAL INPCMX INTEGER INPCMX,IFAIL,IFAIL1,IWK,I,NC,IERR,ISTATE,IOS CHARACTER*(*) NAME CHARACTER*(MXNAME) AUX LOGICAL OPENED *** Locate workstation. CALL GRQIWK(NAME,IWK,IFAIL) IF(IFAIL.NE.0)RETURN *** 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 *** And at last open the workstation, start with the file if any. 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) +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) ** 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 *** 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) END +DECK,GRTERMA,IF=APOLLO,UNIX. SUBROUTINE GRTERM(IWKTYP,ICON,IFLAG,IFAIL) *----------------------------------------------------------------------- * GRTERM - Returns the workstation identifier from the command line. * Version for GKS. * (Last changed on 21/ 1/00.) *----------------------------------------------------------------------- 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. integer arg_length,iargc,nargs external iargc +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 +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 2/ 4/95.) *----------------------------------------------------------------------- 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.) *----------------------------------------------------------------------- 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 18/ 6/95.) *----------------------------------------------------------------------- +SEQ,PRINTPLOT *KEEP,HIFLAG. *CMZ : 1.21/05 16/06/94 14.37.23 by O.Couet *-- Author : COMMON /HIFLAG/ GFLAG,GLFLAG,ZFLAG,PFLAG,MFLAG,TFLAG +,ASFLAG,GRFLAG,AXFLAG,CFLAG LOGICAL GFLAG,GLFLAG,ZFLAG,PFLAG,MFLAG,TFLAG +,ASFLAG,GRFLAG,AXFLAG,CFLAG *** 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 5/10/98.) *----------------------------------------------------------------------- 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')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 5/10/98.) *----------------------------------------------------------------------- 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')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 28/10/98.) *----------------------------------------------------------------------- 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(MXLIST),YCUR(MXLIST),ZCUR(MXLIST), - XNEW(MXLIST),YNEW(MXLIST),ZNEW(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(MXLIST),DRAWN(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.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.MXLIST)GOTO 3010 NCUR=NCUR+1 CALL PLACO3(X0,Y0,Z0,XCUR(NCUR),YCUR(NCUR),ZCUR(NCUR)) DRAW(NCUR)=.TRUE. IF(NCUR.GE.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, merely 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.MXLIST)THEN PRINT *,' !!!!!! PLAGPP WARNING : Too many'// - ' points generated on curve; not plotted.' RETURN ENDIF IF(NNEW.GE.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.MXLIST)THEN PRINT *,' !!!!!! PLAGPP WARNING : Too many points'// - ' generated on curve; not plotted.' RETURN ENDIF IF(NNEW.GE.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.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.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 30/11/00.) *----------------------------------------------------------------------- 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 *** 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 *** 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 12/ 8/99.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CONSTANTS. +SEQ,PARAMETERS. +SEQ,SOLIDS. +SEQ,GRAPHICS. +SEQ,PRINTPLOT. INTEGER IREF,IOFCOL,NMAX,N,IVOL,ICOL,IFAIL,I PARAMETER(NMAX=50) 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 *** 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+8.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 N=MIN(NMAX-1,NINT(CBUF(IREF+9))) IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLACYP DEBUG : Drawing a'', - '' cylinder of volume '',I4/26X,''Radius='',E10.3, - '', Half-length='',E10.3/26X,''Centre= '',3E10.3/ - 26X,''Direction='',3E10.3)') IVOL,R,ZL,X0,Y0,Z0,A,B,C * 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. IF(N.LT.1)THEN IF(R.LT.1E-3*MAX(ABS(FRXMAX-FRXMIN),ABS(FRYMAX-FRYMIN)))THEN N=MIN(MXEDGE-1,NMAX-1,5) ELSEIF(R.LT.1E-2*MAX(ABS(FRXMAX-FRXMIN), - ABS(FRYMAX-FRYMIN)))THEN N=MIN(MXEDGE-1,NMAX-1,10) ELSEIF(R.LT.1E-1*MAX(ABS(FRXMAX-FRXMIN), - ABS(FRYMAX-FRYMIN)))THEN N=MIN(MXEDGE-1,NMAX-1,100) ELSE N=MIN(MXEDGE-1,NMAX-1) ENDIF ENDIF *** Create the top lid. DO 10 I=1,N * Local coordinates, U=R*COS(AROT+2.0D0*PI*DBLE(I)/DBLE(N)) V=R*SIN(AROT+2.0D0*PI*DBLE(I)/DBLE(N)) 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',IREF,N,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.' *** Create the bottom lid. DO 20 I=1,N * Local coordinates, U=R*COS(AROT+2.0D0*PI*DBLE(I)/DBLE(N)) V=R*SIN(AROT+2.0D0*PI*DBLE(I)/DBLE(N)) 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',IREF,N,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.' *** Create the side panels. U=R*COS(AROT+2.0D0*PI*DBLE(0)/DBLE(N)) V=R*SIN(AROT+2.0D0*PI*DBLE(0)/DBLE(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 cylinder. DO 30 I=1,N * Bottom and top of the line along the axis of the cylinder. U=R*COS(AROT+2.0D0*PI*DBLE(I)/DBLE(N)) V=R*SIN(AROT+2.0D0*PI*DBLE(I)/DBLE(N)) 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+2.0D0*PI*(I-0.5)/DBLE(N))- - SP*SIN(AROT+2.0D0*PI*(I-0.5)/DBLE(N)), - SP*CT*COS(AROT+2.0D0*PI*(I-0.5)/DBLE(N))+ - CP*SIN(AROT+2.0D0*PI*(I-0.5)/DBLE(N)), - -ST*COS(AROT+2.0D0*PI*(I-0.5)/DBLE(N)),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',IREF,4,XPL,YPL,ZPL, - CP*CT*COS(AROT+2.0D0*PI*(I-0.5)/DBLE(N))- - SP*SIN(AROT+2.0D0*PI*(I-0.5)/DBLE(N)), - SP*CT*COS(AROT+2.0D0*PI*(I-0.5)/DBLE(N))+ - CP*SIN(AROT+2.0D0*PI*(I-0.5)/DBLE(N)), - -ST*COS(AROT+2.0D0*PI*(I-0.5)/DBLE(N)), - 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 12/ 8/99.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CONSTANTS. +SEQ,PARAMETERS. +SEQ,SOLIDS. +SEQ,GRAPHICS. +SEQ,PRINTPLOT. INTEGER IREF,NMAX,N,IVOL,IFAIL,I,NPL,ICOL PARAMETER(NMAX=50) 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 *** 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+8.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 N=MIN(NMAX-1,NINT(CBUF(IREF+9))) IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ PLACYC DEBUG : Drawing a'', - '' cylinder of volume '',I4/26X,''Radius='',E10.3, - '', Half-length='',E10.3/26X,''Centre= '',3E10.3/ - 26X,''Direction='',3E10.3)') IVOL,R,ZL,X0,Y0,Z0,A,B,C * 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. IF(N.LT.1)THEN IF(R.LT.1E-3*MAX(ABS(FRXMAX-FRXMIN),ABS(FRYMAX-FRYMIN)))THEN N=MIN(MXEDGE-1,NMAX-1,5) ELSEIF(R.LT.1E-2*MAX(ABS(FRXMAX-FRXMIN), - ABS(FRYMAX-FRYMIN)))THEN N=MIN(MXEDGE-1,NMAX-1,10) ELSEIF(R.LT.1E-1*MAX(ABS(FRXMAX-FRXMIN), - ABS(FRYMAX-FRYMIN)))THEN N=MIN(MXEDGE-1,NMAX-1,100) ELSE N=MIN(MXEDGE-1,NMAX-1) ENDIF ENDIF *** Initialise the number of points. NPL=0 *** Go through the lines of the top lid, first point. U=R*COS(AROT+2.0D0*PI*DBLE(0)/DBLE(N)) V=R*SIN(AROT+2.0D0*PI*DBLE(0)/DBLE(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=R*COS(AROT+2.0D0*PI*DBLE(I)/DBLE(N)) V=R*SIN(AROT+2.0D0*PI*DBLE(I)/DBLE(N)) 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+2.0D0*PI*DBLE(0)/DBLE(N)) V=R*SIN(AROT+2.0D0*PI*DBLE(0)/DBLE(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=R*COS(AROT+2.0D0*PI*DBLE(I)/DBLE(N)) V=R*SIN(AROT+2.0D0*PI*DBLE(I)/DBLE(N)) 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=1,N * Bottom and top of the line along the axis of the cylinder. U=R*COS(AROT+2.0D0*PI*DBLE(I)/DBLE(N)) V=R*SIN(AROT+2.0D0*PI*DBLE(I)/DBLE(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 *,' !!!!!! 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',IREF,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/ 8/99.) *----------------------------------------------------------------------- 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, - AROT 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+8.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) * Axial rotation. AROT=CBUF(IREF+14) *** 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,PLABXP. SUBROUTINE PLABXP(IVOL,IOFCOL) *----------------------------------------------------------------------- * PLABXP - Plots a box in 3D perspective. * (Last changed on 19/11/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CONSTANTS. +SEQ,PARAMETERS. +SEQ,SOLIDS. +SEQ,GRAPHICS. +SEQ,PRINTPLOT. INTEGER IVOL,IREF,IOFCOL,ICOL,IFAIL 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. 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',IREF,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.' * The x=xmax face. 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',IREF,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.' * The y=ymin face. 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',IREF,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.' * The y=ymax face. 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',IREF,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.' * The z=zmin face. 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',IREF,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.' * The z=zmax face. 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',IREF,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.' *** 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 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',IREF,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 8/10/98.) *----------------------------------------------------------------------- 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+11.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*1.0001 V=-YL*1.0001 W=-ZL*1.0001 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*1.0001 V=+YL*1.0001 W=-ZL*1.0001 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*1.0001 V=+YL*1.0001 W=-ZL*1.0001 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*1.0001 V=-YL*1.0001 W=-ZL*1.0001 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*1.0001 V=-YL*1.0001 W=+ZL*1.0001 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*1.0001 V=+YL*1.0001 W=+ZL*1.0001 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*1.0001 V=+YL*1.0001 W=+ZL*1.0001 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*1.0001 V=-YL*1.0001 W=+ZL*1.0001 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*1.0001 V=-YL*1.0001 W=-ZL*1.0001 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*1.0001 V=-YL*1.0001 W=+ZL*1.0001 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*1.0001 V=-YL*1.0001 W=-ZL*1.0001 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*1.0001 V=-YL*1.0001 W=+ZL*1.0001 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*1.0001 V=+YL*1.0001 W=-ZL*1.0001 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*1.0001 V=+YL*1.0001 W=+ZL*1.0001 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*1.0001 V=+YL*1.0001 W=-ZL*1.0001 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*1.0001 V=+YL*1.0001 W=+ZL*1.0001 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 31/ 8/98.) *----------------------------------------------------------------------- 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+8.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,''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) *** 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 END +DECK,PLASPP. SUBROUTINE PLASPP(IVOL,IOFCOL) *----------------------------------------------------------------------- * PLASPP - Plots a sphere in 3D perspective. * (Last changed on 4/ 2/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CONSTANTS. +SEQ,PARAMETERS. +SEQ,SOLIDS. +SEQ,GRAPHICS. +SEQ,PRINTPLOT. INTEGER IVOL,IREF,IOFCOL,ICOL,NMAX,I,J,N,IFAIL 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. 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) * 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',IREF,4,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 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',IREF,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+8.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,PLACHP. SUBROUTINE PLACHP(IVOL,IOFCOL) *----------------------------------------------------------------------- * PLACHP - Plots a cylindrical hole in a box. * (Last changed on 1/ 9/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CONSTANTS. +SEQ,PARAMETERS. +SEQ,SOLIDS. +SEQ,GRAPHICS. +SEQ,PRINTPLOT. INTEGER IVOL,IREF,IOFCOL,ICOL,IFAIL, - N,NMAX,I,ISIDE 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 *** 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 : Cylindrical hole ',IVOL, - ' is 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 *** 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',IREF,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',IREF,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',IREF,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',IREF,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',IREF,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',IREF,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',IREF,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',IREF,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',IREF,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 4/ 2/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CONSTANTS. +SEQ,PARAMETERS. +SEQ,SOLIDS. +SEQ,GRAPHICS. +SEQ,PRINTPLOT. INTEGER IREF,IVOL,IFAIL,NCUT,N,NMAX,I,ICOL,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, - XBOX(8),YBOX(8),ZBOX(8),XCUT(12),YCUT(12),ZCUT(12), - X0PL,Y0PL,Z0PL,APL,BPL,CPL *** 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 : Cylindrical hole ',IREF, - ' is 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 *** 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',IREF,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',IREF,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',IREF,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',IREF,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) *----------------------------------------------------------------------- * PLABXI - Determines whether a point is located inside a box. * (Last changed on 31/ 8/98.) *----------------------------------------------------------------------- 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+11.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 : Cylindrical hole ',IVOL, - ' is 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,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 CROSSD,ONLIND,ADD,SKIP,INSIDE,EDGE EXTERNAL CROSSD,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) ELSE XCUT=0 YCUT=0 ZCUT=0 IFAIL=1 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 22/ 9/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PARAMETERS. 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 C print *,' PLACHK - Not enough points: ',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 C print *,' PLACHK - 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 C print *,' PLACHK - 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 C print *,' PLACHK - No third point, DIST2=',DIST,' EPS=',EPS 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 29/ 9/98.) *----------------------------------------------------------------------- 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. * 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. 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)) 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. 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)) 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)) 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.MXCORN.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 19/11/98.) *----------------------------------------------------------------------- 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,VEC(3),FNORM, - XCUT,YCUT,ZCUT,XEMIN,XEMAX,YEMIN,YEMAX,ZEMIN,ZEMAX LOGICAL CROSSD,PLAGT,KEEP,MARK(2*MXPLAN) EXTERNAL CROSSD,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. VEC(1)=APL1 VEC(2)=BPL1 VEC(3)=CPL1 CALL DFEQN(3,FPRMAT,3,IPRMAT,1,VEC) FNORM=SQRT(VEC(1)**2+VEC(2)**2+VEC(3)**2) IF(FNORM.LE.0.OR.NPL2.LE.2)THEN PRINT *,' !!!!!! PLASRP WARNING : Unable to project a'// - ' panel; panel skipped.' GOTO 10 ENDIF APL2=VEC(1)/FNORM BPL2=VEC(2)/FNORM CPL2=VEC(3)/FNORM DPL2=0 DO 20 J=1,NPL2 DPL2=DPL2+APL2*XPL2(J)+BPL2*YPL2(J)+CPL2*ZPL2(J) 20 CONTINUE DPL2=DPL2/NPL2 * 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,PLAPLT. SUBROUTINE PLAPLT *----------------------------------------------------------------------- * PLAPLT - Plots the current set of planes. * (Last changed on 30/ 9/98.) *----------------------------------------------------------------------- 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) * 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 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.' 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 8/ 1/98.) *----------------------------------------------------------------------- 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 C 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 CALL SORTZV(ISTART,IND,MXPLAN,-1,0,0) 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 C 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) C dpl=dpl+apl*xpl(i)+bpl*ypl(i)+cpl*zpl(i) 50 CONTINUE C dpl=dpl/npl C do i=1,npl C if(abs(dpl-xpl(i)*apl-ypl(i)*bpl-zpl(i)*cpl).gt.1e-4)then C print *,' PLABU1 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 C 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)PRINT *,' ++++++ PLABU1 DEBUG :'// - ' Requested polygon is 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 *** 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 29/ 9/98.) *----------------------------------------------------------------------- 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 CALL SORTZV(ISTART,IND,MXPLAN,-1,0,0) 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 IF(LDEBUG)PRINT *,' ++++++ PLABU2 DEBUG :'// - ' 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 +PATCH,ROUTINES. +DECK,ARGGET,IF=UNIX. 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 30/ 9/98.) *---------------------------------------------------------------------- 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 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 30/ 9/98.) *---------------------------------------------------------------------- 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 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,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. FUNCTION DENLAN(X) *----------------------------------------------------------------------- * DENLAN - Stolen from G110 in GENLIB. *----------------------------------------------------------------------- C DIMENSION P1(0:4),P2(0:4),P3(0:4),P4(0:4),P5(0:4),P6(0:4) DIMENSION Q1(0:4),Q2(0:4),Q3(0:4),Q4(0:4),Q5(0:4),Q6(0:4) DIMENSION A1(1:3),A2(1:2) 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 DATA (A1(I),I=1,3) 1/ 0.41666 66667E-1,-0.19965 27778E-1, 0.27095 38966E-1/ C 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. * Adapted from DIVDIF (CERN program library E105). * (Last changed on 19/10/93.) *----------------------------------------------------------------------- IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION A(*),F(*),T(20),D(20) LOGICAL EXTRA DATA MMAX/10/ C C TABULAR INTERPOLATION USING SYMMETRICALLY PLACED ARGUMENT POINTS. C C START. FIND SUBSCRIPT IX OF X IN ARRAY A. IF( (NN.LT.2) .OR. (MM.LT.1) ) THEN PRINT *,' ###### DIVDF2 ERROR : Invalid dimensions'// - ' received for the arguments.' GO TO 20 ENDIF 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=1 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 18/ 9/99.) *----------------------------------------------------------------------- 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 CHARACTER*(MXCHAR) STRING,OPTION CHARACTER*10 VARLIS(MXVAR) LOGICAL USE(MXVAR),FUNSET EXTERNAL MATSLT,FRNDFU 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 *** 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. 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,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 21/ 8/96.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. REAL X(*),Y(*),EY(*) REAL XPL(200),YPL(200) DOUBLE PRECISION XXX,YYY DOUBLE PRECISION XX(MXLIST),YY(MXLIST),EEY(MXLIST),SFACT,SSIG, - AA(*),EA(*),CHI2,D(2,4),YTOT,YSUM,YINT,XFIRST,XLAST,TOL INTEGER N,IFAIL,NDATA,IWORK(2) 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. YSUM=0 YINT=0 YTOT=0 SFACT=0 SSIG=0 NDATA=0 NSTART=N/3 XSET=.FALSE. D(1,1)=0 D(1,2)=0 D(1,3)=0 D(2,1)=0 D(2,2)=0 D(2,3)=0 DO 100 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 ENDIF * Exponential fit matrix. 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 100 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.' *** 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.' *** < 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 6/10/00.) *----------------------------------------------------------------------- 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 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 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 17/ 9/00.) *----------------------------------------------------------------------- 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(USE(I).AND.GLBMOD(I).EQ.0)THEN PRINT *,' !!!!!! FUNFIT WARNING : The function uses the'// - ' uninitialised variable '//GLBVAR(I) OK=.FALSE. ELSEIF(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(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 13/ 3/99.) *----------------------------------------------------------------------- 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 DATA IVEC/0/ +SELF,IF=SAVE. SAVE RVEC,IVEC +SELF. *** 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,STDSTR. LOGICAL FUNCTION STDSTR(STREAM) *----------------------------------------------------------------------- * STDSTR - Checks whether the data stream STREAM is connected to * standard input or output. * (Last changed on 21/ 1/00.) *----------------------------------------------------------------------- implicit none +SEQ,PRINTPLOT. CHARACTER*(*) STREAM INTEGER LENARG,IARG,NARGS,INIT,INPCMX,iargc,DUMMY CHARACTER*128 ARGS LOGICAL LSTATE,INTRAC EXTERNAL INPCMX,INTRAC,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. * 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. * (Last changed on 21/ 2/94.) *----------------------------------------------------------------------- +SEQ,CONSTANTS. *** 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 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 *** 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,''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,'(/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,'(/'' Minimisation finished.'')') ENDIF END +DECK,MSNFIT. SUBROUTINE MSNFIT(X,Y,EY,N,LPRINT,LFITK3,AA,EA,IFAIL) *----------------------------------------------------------------------- * MSNFIT - Fits a Mathieson distribution. * (Last changed on 17/ 4/97.) *----------------------------------------------------------------------- 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'// - ' too small for fit; no fit.' IFAIL=1 RETURN ELSEIF(NUSE.LE.3)THEN PRINT *,' !!!!!! MSNFIT WARNING : Too few 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 18/ 1/99). *----------------------------------------------------------------------- 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 +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 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) *** 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. IF(XRNG(IFLD).GT.0)THEN 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 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 *** 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,DECS. IF(LPROPR)WRITE(LUNPRO,'(A1,'' '',A,$)') - CHAR(13),OUT(1:MAX(78,NCOUT)) +SELF,IF=-IBMRT,IF=-SUN,IF=-HPUX,IF=-LINUX,IF=-DECS. IF(LPROPR)WRITE(LUNPRO,'(''+ '',A)') OUT(1:MAX(78,NCOUT)) +SELF. *** That's all for this entry. RETURN ENTRY PROEND *** Say that we're done. 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,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=-DECS. IF(LPROPR)WRITE(LUNPRO,'(''+ '',A)') OUT(1:MAX(78,NCFAC+12)) +SELF. ENDIF *** Reset the fields flag. NFLD=0 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,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.) *----------------------------------------------------------------------- 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,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 :'// - ' Deleting a string failed.' 20 CONTINUE ENDIF *** Other procedures are not known. ELSE PRINT *,' !!!!!! STRCAL WARNING : Unknown procedure code'// - ' received.' RETURN ENDIF *** Things worked fine. IFAIL=0 END +DECK,STRBUF. SUBROUTINE STRBUF(COMM,IREF,STRING,NC,IFAIL) *----------------------------------------------------------------------- * STRBUF - General purpose dynamical string store. * (Last changed on 6/11/99.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. +SEQ,GLOBALS. INTEGER MXSTRL,MXNSTR PARAMETER (MXSTRL=20000,MXNSTR=1000) CHARACTER*(*) STRING,COMM CHARACTER*(MXSTRL) BUFFER CHARACTER*10 NAME INTEGER IREF,IREFL,NC,REF(3,MXNSTR),NBUF,ISTART,I,J,IFAIL,NOLD LOGICAL ACTIVE(MXNSTR) +SELF,IF=SAVE. SAVE BUFFER,REF,NBUF,ISTART,IREFL,ACTIVE +SELF. DATA ISTART,NBUF,IREFL /1,0,1/ *** Identify the routine if requested. IF(LIDENT)PRINT *,' /// ROUTINE STRBUF ///' *** If requested, store the string. IF(COMM.EQ.'STORE')THEN * Garbage collection if there is no more space. IF(ISTART+NC-1.GT.MXSTRL.OR.NBUF+1.GT.MXNSTR)THEN * Inform in case debugging is requested. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ STRBUF DEBUG :'', - '' Garbage collection to make room for a new'', - '' string.''/26X,''Free storage: '',I5, - '', Needed: '',I5/26X,''Strings in store: '',I5, - '', Available: '',I5)') - MXSTRL-ISTART+1,NC,NBUF,MXNSTR * Reset the start pointer, string number pointer etc. ISTART=1 NOLD=NBUF NBUF=0 * Loop over the strings in store, skipping those that are dropped. DO 10 I=1,NOLD IF(.NOT.ACTIVE(I))GOTO 10 NBUF=NBUF+1 IF(REF(2,I).GT.0)THEN DO 30 J=1,REF(2,I) BUFFER(ISTART+J-1:ISTART+J-1)= - BUFFER(REF(1,I)+J-1:REF(1,I)+J-1) 30 CONTINUE ENDIF REF(1,NBUF)=ISTART REF(2,NBUF)=REF(2,I) REF(3,NBUF)=REF(3,I) ISTART=ISTART+REF(2,NBUF) ACTIVE(NBUF)=.TRUE. 10 CONTINUE * Check the amount of free storage again. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ STRBUF DEBUG :'', - '' Free storage after garbage collect: '',I5/ - 26X,''Number of strings in use: '',I5)') - MXSTRL-ISTART+1,NBUF IF(ISTART+NC-1.GT.MXSTRL.OR.NBUF+1.GT.MXNSTR)THEN PRINT *,' ###### STRBUF WARNING : No room to'// - ' store your string; delete some strings'// - ' or increase MXSTRL, MXNSTR and recompile.' IFAIL=1 RETURN ENDIF ENDIF * Store the new string. NBUF=NBUF+1 IF(NC.GT.0)BUFFER(ISTART:ISTART+NC-1)=STRING(1:NC) IREF=IREFL IREFL=IREFL+1 REF(1,NBUF)=ISTART REF(2,NBUF)=NC REF(3,NBUF)=IREF ACTIVE(NBUF)=.TRUE. ISTART=ISTART+NC IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ STRBUF DEBUG :'', - '' Stored "'',A,''"''/26X,''Reference='',I5, - '', Start='',I5,'', Record='',I5)') - STRING(1:NC),IREF,REF(1,NBUF),NBUF IFAIL=0 *** Read an existing string. ELSEIF(COMM.EQ.'READ')THEN DO 100 I=1,NBUF IF(REF(3,I).NE.IREF)GOTO 100 IF(.NOT.ACTIVE(I))PRINT *,' !!!!!! STRBUF WARNING :'// - ' The string has been deleted but is still in store.' IF(REF(2,I).GT.LEN(STRING))PRINT *,' !!!!!! STRBUF'// - ' WARNING : String longer than receiving string'// - ' length; truncated.' IF(REF(2,I).GT.0)THEN STRING=BUFFER(REF(1,I):REF(1,I)+REF(2,I)-1) ELSE STRING=' ' ENDIF NC=MIN(REF(2,I),LEN(STRING)) IFAIL=0 RETURN 100 CONTINUE PRINT *,' !!!!!! STRBUF WARNING : The string you ask for'// - ' is not in store.' NC=20 STRING='< string not found >' IFAIL=1 *** Delete the string. ELSEIF(COMM.EQ.'DELETE')THEN DO 200 I=1,NBUF IF(REF(3,I).NE.IREF)GOTO 200 ACTIVE(I)=.FALSE. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ STRBUF DEBUG :'', - '' Deleted string with reference '',I5)') IREF IFAIL=0 RETURN 200 CONTINUE PRINT *,' !!!!!! STRBUF WARNING : The string you ask for'// - ' is not in store.' IFAIL=1 *** Dump the entire contents. ELSEIF(COMM.EQ.'DUMP')THEN WRITE(LUNOUT,'(/'' CURRENTLY KNOWN STRINGS:''// - '' No Start NC Ref Global String'')') DO 300 I=1,NBUF NAME='< none >' DO 710 J=1,NGLB IF(GLBMOD(J).EQ.1.AND.NINT(GLBVAL(J)).EQ.REF(3,I)) - NAME=GLBVAR(J) 710 CONTINUE IF(.NOT.ACTIVE(I))THEN WRITE(LUNOUT,'(4(1X,I5),1X,A10,1X,A)') I,REF(1,I), - REF(2,I),REF(3,I),NAME,'(deleted)' ELSE WRITE(LUNOUT,'(4(1X,I5),1X,A10,1X,A)') I,REF(1,I), - REF(2,I),REF(3,I),NAME, - BUFFER(REF(1,I):REF(1,I)+REF(2,I)-1) ENDIF 300 CONTINUE IFAIL=0 WRITE(LUNOUT,'(/'' Total of '',I3,'' strings.''/)') NBUF *** Anything else is not valid. ELSE PRINT *,' ###### STRBUF ERROR : Unknown command ',COMM, - ' received.' IFAIL=1 ENDIF END +DECK,STRSAV. SUBROUTINE STRSAV(VAL,NAME,IFAIL) *----------------------------------------------------------------------- * STRSAV - Assigns a string to a global variable. * (Last changed on 31/ 8/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,GLOBALS. +SEQ,PRINTPLOT. CHARACTER*(*) VAL,NAME INTEGER IFAIL,JVAR,I,IFAIL1,IREF *** Tracing and debugging output. IF(LIDENT)PRINT *,' /// ROUTINE STRSAV ///' IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ STRSAV WARNING : Storing '', - A,'' 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 *,' !!!!!! STRSAV WARNING : No global variable'// - ' space left for ',NAME,'; string not saved.' RETURN ENDIF *** Otherwise re-use an existing global. ELSE CALL ALGREU(NINT(GLBVAL(JVAR)),GLBMOD(JVAR),0) ENDIF *** Assign the string to the global. CALL STRBUF('STORE',IREF,VAL,LEN(VAL),IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! STRSAV WARNING : Unable to store the'// - ' string; global variable not assigned a value.' RETURN ENDIF GLBVAL(JVAR)=IREF GLBMOD(JVAR)=1 *** Things seem to have worked. IFAIL=0 END +DECK,TIMLOG. SUBROUTINE TIMLOG(NAME) *----------------------------------------------------------------------- * TIMLOG - Routine accumulating data on CPU-time usage and printing * its data when called with an empty name. * VARIABLES : CPU : CPU time used since previous timing. * TIME : Vector containing the cpu times used. * NAME : Description of the step just completed. * LIST : List of the above descriptions. * ICOUNT : Counts the number of names entered. *----------------------------------------------------------------------- CHARACTER*(*) NAME CHARACTER*40 LIST(100) +SELF,IF=-VECTOR,-CMS. INTEGER TIME(100) +SELF,IF=VECTOR,IF=CMS. DOUBLE PRECISION TVEC(4),TLAST(4) INTEGER TIME(4,100) +SELF,IF=SAVE. SAVE LIST,TIME,ICOUNT +SELF. *** Initialise ICOUNT. DATA ICOUNT/0/ *** If the input is all blank, print the LIST and TIME vectors. IF(NAME(1:1).EQ.' ')THEN WRITE(*,'(''1'')') IF(ICOUNT.EQ.0)THEN PRINT *,' No steps have been executed.' RETURN ENDIF PRINT *,' CPU time usage for some selected steps:' PRINT *,' =======================================' PRINT *,' ' +SELF,IF=-VECTOR,-CMS. PRINT *,' Description of the step '// - ' CPU time used' PRINT *,' ' DO 10 J=1,MIN(ICOUNT,100) PRINT '(2X,A40,I14)',LIST(J),TIME(J) 10 CONTINUE +SELF,IF=VECTOR,IF=CMS. PRINT *,' Description of the step '// - ' CPU time used % Vector' PRINT *,' ' DO J=1,MIN(ICOUNT,100) IF(TIME(3,J).GT.0)THEN IVFRAC=INT(100.0*REAL(TIME(4,J))/REAL(TIME(3,J))) ELSE IVFRAC=0 ENDIF PRINT '(2X,A40,I14,I12)',LIST(J),TIME(3,J),IVFRAC ENDDO +SELF. *** Otherwise store the information obtained. ELSEIF(ICOUNT.LT.100)THEN ICOUNT=ICOUNT+1 LIST(ICOUNT)=NAME +SELF,IF=-VECTOR,-CMS. CALL TIMED(CPU) TIME(ICOUNT)=INT(1000.0*CPU) +SELF,IF=VECTOR,IF=CMS. CALL VCLOC(TVEC) IF(ICOUNT.GE.1)THEN DO I=1,4 TIME(I,ICOUNT)=INT(TVEC(I)-TLAST(I)) ENDDO ELSE TIME(I,ICOUNT)=INT(TVEC(I)) ENDIF DO I=1,4 TLAST(I)=TVEC(I) ENDDO +SELF. *** Print a warning if 100 items have been stored. ELSEIF(ICOUNT.EQ.100)THEN ICOUNT=101 PRINT *,' !!!!!! TIMLOG WARNING : 100 Items have been'// - ' stored ; no further CPU time registration.' ENDIF END +DECK,UNITS. SUBROUTINE UNITS(XIN,UIN,XOUT,UOUT,IFAIL) *----------------------------------------------------------------------- * UNITS - Converts units. * (Last changed on 29/ 3/98.) *----------------------------------------------------------------------- implicit none REAL XIN,XOUT CHARACTER*(*) UIN,UOUT INTEGER IFAIL,INPCMX EXTERNAL INPCMX *** Preset the output and failure flag. XOUT=0 IFAIL=1 *** If this is a pressure unit. IF(INPCMX(UIN,'ATM#OSPHERE')+INPCMX(UIN,'BAR')+ - INPCMX(UIN,'MBAR')+INPCMX(UIN,'M#ILLI-BAR')+ - INPCMX(UIN,'TORR#ICELLI')+INPCMX(UIN,'MM-HG')+ - INPCMX(UIN,'INCH-HG')+INPCMX(UIN,'PA#SCAL')+ - INPCMX(UIN,'HPA#SCAL')+INPCMX(UIN,'H#ECTO-PA#SCAL')+ - INPCMX(UIN,'N/M2').NE.0)THEN * Convert all incoming units to atmospheres. IF(INPCMX(UIN,'ATM#OSPHERE').NE.0)THEN XOUT=XIN/1 ELSEIF(INPCMX(UIN,'BAR').NE.0)THEN XOUT=XIN/1.01325 ELSEIF(INPCMX(UIN,'TORR#ICELLI')+ - INPCMX(UIN,'MM-HG').NE.0)THEN XOUT=XIN/760 ELSEIF(INPCMX(UIN,'INCH-HG').NE.0)THEN XOUT=XIN/29.9213 ELSEIF(INPCMX(UIN,'PA#SCAL')+INPCMX(UIN,'N/M2').NE.0)THEN XOUT=XIN/101325 ELSEIF(INPCMX(UIN,'HPA#SCAL')+ - INPCMX(UIN,'H#ECTO-PA#SCAL')+ - INPCMX(UIN,'MBAR')+ - INPCMX(UIN,'M#ILLI-BAR').NE.0)THEN XOUT=XIN/1013.25 ELSE PRINT *,' !!!!!! UNITS WARNING : Incoming unit ', - UIN,' not recognised.' XOUT=0 IFAIL=1 RETURN ENDIF * Convert atmospheres to the desired unit. IF(INPCMX(UOUT,'ATM#OSPHERE').NE.0)THEN XOUT=XOUT*1 ELSEIF(INPCMX(UOUT,'BAR').NE.0)THEN XOUT=XOUT*1.01325 ELSEIF(INPCMX(UOUT,'TORR#ICELLI')+ - INPCMX(UOUT,'MM-HG').NE.0)THEN XOUT=XOUT*760 ELSEIF(INPCMX(UOUT,'INCH-HG').NE.0)THEN XOUT=XOUT*29.9213 ELSEIF(INPCMX(UOUT,'PA#SCAL')+INPCMX(UOUT,'N/M2').NE.0)THEN XOUT=XOUT*101325 ELSEIF(INPCMX(UOUT,'HPA#SCAL')+ - INPCMX(UOUT,'H#ECTO-PA#SCAL')+ - INPCMX(UOUT,'MBAR')+ - INPCMX(UOUT,'M#ILLI-BAR').NE.0)THEN XOUT=XOUT*1013.25 ELSE PRINT *,' !!!!!! UNITS WARNING : Unit mismatch, ', - UIN,' is a pressure while ',UOUT,' is not.' XOUT=0 IFAIL=1 RETURN ENDIF *** Temperature units. ELSEIF(INPCMX(UIN,'K#ELVIN')+INPCMX(UIN,'C#ELSIUS')+ - INPCMX(UIN,'F#AHRENHEIT')+INPCMX(UIN,'RA#NKINE')+ - INPCMX(UIN,'RE#AUMUR').NE.0)THEN * Convert all incoming units to Celsius. IF(INPCMX(UIN,'K#ELVIN').NE.0)THEN XOUT=XIN-273.15 ELSEIF(INPCMX(UIN,'C#ELSIUS').NE.0)THEN XOUT=XIN ELSEIF(INPCMX(UIN,'F#AHRENHEIT').NE.0)THEN XOUT=(XIN-32.0)*5.0/9.0 ELSEIF(INPCMX(UIN,'RA#NKINE').NE.0)THEN XOUT=(XIN-32.0-459.67)*5.0/9.0 ELSEIF(INPCMX(UIN,'RE#AUMUR').NE.0)THEN XOUT=XIN*5.0/4.0 ELSE PRINT *,' !!!!!! UNITS WARNING : Incoming unit ', - UIN,' not recognised.' XOUT=0 IFAIL=1 RETURN ENDIF * Convert Celsius to the desired unit. IF(INPCMX(UOUT,'K#ELVIN').NE.0)THEN XOUT=XOUT+273.15 ELSEIF(INPCMX(UOUT,'C#ELSIUS').NE.0)THEN XOUT=XOUT ELSEIF(INPCMX(UOUT,'F#AHRENHEIT').NE.0)THEN XOUT=XOUT*9.0/5.0+32.0 ELSEIF(INPCMX(UOUT,'RA#NKINE').NE.0)THEN XOUT=XOUT*9.0/5.0+32.0+459.67 ELSEIF(INPCMX(UOUT,'RE#AUMUR').NE.0)THEN XOUT=XOUT*4.0/5.0 ELSE PRINT *,' !!!!!! UNITS WARNING : Unit mismatch, ', - UIN,' is a temperature while ',UOUT,' is not.' XOUT=0 IFAIL=1 RETURN ENDIF *** Other units. ELSE PRINT *,' !!!!!! UNITS WARNING : Incoming unit ',UIN, - ' is not known.' XOUT=0 IFAIL=1 RETURN ENDIF *** Seems to have worked. IFAIL=0 END +DECK,VMCMS,IF=CMS. SUBROUTINE VMCMS(COMMAN,IRC) *----------------------------------------------------------------------- * VMCMS - Replacement for the CERN library routine VMCMS (Z305) using * the assembly language routine below. *----------------------------------------------------------------------- CHARACTER*(*) COMMAN CALL SUBSET(COMMAN,LEN(COMMAN),IRC) END +DECK,SUBSET,T=ASSEMBLER,IF=CMS. SUBSET CSECT * * CALL SUBSET(command,len,iretcode), or just CALL SUBSET. * * This routine executes a system command (CP or CMS) in SUBSET mode. * If a command is provided, that command is executed in SUBSET mode. * If the 'len' of the command is non-positive in a FORTVS program, * then the implicit length of the 'command' character value is used. * The return code from the command is stored in 'iretcode'. * If no args, CMS SUBSET is entered and any number of commands can be * entered at the terminal; the program is resumed by entering 'RETURN'. * * CMS SUBSET mode documentation taken from CMS routine DMSINT. * * The SUBSET technique is used so that: * 1) Commands which otherwise would overlay a program are rejected. * 2) Commands may be entered as normal without CP or EXEC prefix, * assuming of course that IMPCP and IMPEX are on. * 3) Tokenising the command line is left to the system. * * Written L.S.Lowe, Birmingham, 1982. 472-1301 ex 2428. * Updated L.S.Lowe, Jul 83, in order to allow the FORTVS release 3 * extended argument list to be used if the given command length is <=0. * Updated S.O'Neale, Apr 85, to accept the argument passing of the * Siemens Fortran 77 compiler. Patchy selection of FORTVS or FUJITSU * is required. * USING *,R12 SAVE (14,12),,* SAVE REGS LR R12,R15 LOAD BASE REG LTR R1,R1 TEST FOR PARMS BZ SUBENTER NO - ENTER CMS SUBSET LM R4,R6,0(R1) YES - GET USER'S PARMS ST R4,ATTNLIST+12 STORE BUFFER ADDRESS ICM R7,15,0(R5) GET AND TEST LENGTH BP SUBLENCH JUMP IF POSITIVE LR R15,R1 COPY ARG LIST POINTER SH R15,=H'4' POINT TO WORD BEFORE ARG LIST CLC 0(4,R15),=F'12' VALIDATE FORTVS EXTENDED PARMLIST BNE SUBARGER JUMP IF ERROR L R5,12(,R1) OK - GET FIRST ARG LENGTH ADDRESS L R7,0(,R5) LOAD FIRST ARG LENGTH SUBLENCH LTR R7,R7 TEST LENGTH BNP SUBARGER ERROR IF NON-POSITIVE CH R7,=H'255' TEST LENGTH BH SUBARGER ERROR IF TOO LONG STC R7,ATTNLIST+12 STORE LENGTH IN STACK LIST LA R1,ATTNLIST POINT TO STACK LIST SVC 202 STACK THE LINE LIFO DC AL4(*+4) POSSIBLE ERROR RETURN LA R1,SUBRLIST POINT TO SUBSET & RETURN PLIST SVC 202 EXECUTE ONE COMMAND IN CMS SUBSET DC AL4(*+4) POSSIBLE ERROR RETURN B SUBDONE JUMP TO STORE RETCODE SUBARGER WRTERM 'SUBSET: invalid argument list' SR R15,R15 FOR SYNTAX ERROR BCTR R15,0 SET RETURN CODE -1 SUBDONE DS 0H ST R15,0(,R6) STORE RETURN CODE FOR USER LTR R15,R15 TEST RETURN CODE BZ *+8 SKIP IF ZERO LA R15,4 NON-ZERO - SET UP A RETURN 1 B SUBEXIT AND JUMP TO EXIT SUBENTER LA R1,SUBPLIST POINT TO SUBSET PLIST SVC 202 ENTER CMS SUBSET MODE DC AL4(*+4) POSSIBLE ERROR RETURN SR R15,R15 CLEAR RETURN CODE SUBEXIT RETURN (14,12),T,RC=(15) RETURN TO CALLER * DC 0F'0' ATTNLIST DC CL8'ATTN',CL4'LIFO',A(1) SUBPLIST DC CL8'SUBSET',8X'FF' SUBRLIST DC CL8'SUBSET',CL8'(RETURN)',8X'FF' REGEQU END +DECK,VMNAME,IF=CMS. SUBROUTINE VMNAME(FILE,NCFILE,IFAIL) *----------------------------------------------------------------------- * VMNAME - Verifies the format of a VM file name. * (Last changed on 4/ 4/94.) *----------------------------------------------------------------------- CHARACTER*(*) FILE CHARACTER*20 WRONG *** Initialise. NCWR=0 WRONG=' ' IFAIL=0 NCSEG=0 *** Scan for dots, remove multiple blanks and spot illegal characters. J=0 DO 10 I=1,NCFILE * Replace dots by blanks. IF(FILE(I:I).EQ.'.')FILE(I:I)=' ' * No multiple blanks. IF(FILE(I:I).NE.' '.OR. - (I.GT.1.AND.FILE(MAX(1,I-1):MAX(1,I-1)).NE.' '))J=J+1 * Straight copy. FILE(J:J)=FILE(I:I) * Illegal characters. IF(INDEX('ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789$_ ', - FILE(J:J)).NE.0)GOTO 10 NCWR=NCWR+1 IF(NCWR.LE.LEN(WRONG))WRONG(NCWR:NCWR)=FILE(J:J) 10 CONTINUE * Update string length. IF(FILE(J:J).NE.' ')THEN NCFILE=J ELSE NCFILE=MAX(1,J-1) ENDIF * Stop of any were found. IF(NCWR.GT.0)THEN PRINT *,' !!!!!! VMNAME WARNING : Invalid characters "'// - WRONG(1:MIN(20,NCWR))//'" found in file name "', - FILE(1:NCFILE),'".' IFAIL=1 RETURN ENDIF *** Stop if the string is entirely blank. IF(FILE(1:NCFILE).EQ.' ')THEN PRINT *,' !!!!!! VMNAME WARNING : The file name is'// - ' empty.' IFAIL=1 RETURN ENDIF *** Count segments and verify each segment, begin by dissecting. IFN0=1 IFN1=INDEX(FILE(1:NCFILE),' ')-1 IF(IFN1.NE.-1.AND.IFN1+2.LE.NCFILE)THEN IFT0=IFN1+2 IFT1=IFT0+INDEX(FILE(IFT0:NCFILE),' ')-2 IF(IFT1.EQ.IFT0-2)IFT1=NCFILE ELSE PRINT *,' !!!!!! VMNAME WARNING : The file type has not'// - ' been specified; not valid.' IFAIL=1 RETURN ENDIF IF(IFT1.NE.0.AND.IFT1+2.LE.NCFILE)THEN IFM0=IFT1+2 IFM1=IFM0+INDEX(FILE(IFM0:NCFILE),' ')-2 IF(IFM1.EQ.IFM0-2)THEN IFM1=NCFILE ELSE PRINT *,' !!!!!! VMNAME WARNING : Text "', - FILE(IFM1+2:NCFILE),'" found after'// - ' the file mode ; blanked out.' FILE(IFM1+2:NCFILE)=' ' NCFILE=IFM1 ENDIF ELSE IFM0=0 IFM1=0 ENDIF * Verify the individual segments. IF(IFN0.NE.0.AND.IFN1.NE.0.AND.IFN1-IFN0+1.GT.8)THEN PRINT *,' !!!!!! VMNAME WARNING : Name part of the file'// - ' name "',FILE(IFN0:IFN1),'" too long ; rejected.' IFAIL=1 RETURN ENDIF IF(IFT0.NE.0.AND.IFT1.NE.0.AND.IFT1-IFT0+1.GT.8)THEN PRINT *,' !!!!!! VMNAME WARNING : Type part of the file'// - ' name "',FILE(IFT0:IFT1),'" too long ; rejected.' IFAIL=1 RETURN ENDIF IF(IFM0.NE.0.AND.IFM1.NE.0.AND.IFM1-IFM0+1.GT.2)THEN PRINT *,' !!!!!! VMNAME WARNING : Mode part of the file'// - ' name "',FILE(IFM0:IFM1),'" too long ; rejected.' IFAIL=1 RETURN ENDIF IF((IFM0.NE.0.AND.INDEX('ABCDEFGHIJKLMNOPQRSTUVWXYZ', - FILE(MAX(1,IFM0):MAX(1,IFM0))).EQ.0).OR. - (IFM1.NE.IFM0.AND.IFM0.NE.0.AND.INDEX('0123456789', - FILE(MAX(1,IFM1):MAX(1,IFM1))).EQ.0))THEN PRINT *,' !!!!!! VMNAME WARNING : File mode format of "'// - FILE(IFM0:IFM1),'" not valid ; rejected.' IFAIL=1 RETURN ENDIF END +DECK,WLDCRD. SUBROUTINE WLDCRD(REFIN,WILDIN,FREEND,MATCH) *----------------------------------------------------------------------- * WLDCRD - Compares a string with a wildcard (the asterix may stand * for any number of arbitrary characters). * VARIABLES : REF : The reference string, without asterix * WILD : The wildcard * FREEND : Equivalent to a final asterix in WILD. * MATCH : Set to .TRUE. only if the strings match. * IW0, IW1 : Begin and end of a segment in the wildcard * IR0, IR1 : Begin of the part of the reference string * to be searched and the start of the match. *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,INPUT. CHARACTER*(*) REFIN,WILDIN CHARACTER*80 REF,WILD LOGICAL FREEND,MATCH,ASTER *** Check for empty strings. IF(REFIN.EQ.' '.OR.LEN(REFIN).EQ.0.OR. - WILDIN.EQ.' '.OR.LEN(WILDIN).EQ.0)THEN MATCH=.FALSE. RETURN ENDIF *** Avoid out of bounds array references. IF(LEN(REFIN).GT.80.OR.LEN(WILDIN).GT.80)THEN PRINT *,' ###### WLDCRD ERROR : Input strings too long:'// - ' REF: ',LEN(REF),' WILD: ',LEN(WILD) PRINT *,' (program bug - please'// - ' report); strings declared non-matching.' MATCH=.FALSE. RETURN ENDIF *** Copy the strings translating to upper case. NREF=0 DO 10 I=1,LEN(REFIN) IC=ICHAR(REFIN(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 REF(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 REF(I:I)=CHAR(IC+64) * Anything else: don't do anything. ELSE REF(I:I)=CHAR(IC) ENDIF * Keep track of the lenghts. IF(REF(I:I).NE.' ')NREF=I 10 CONTINUE ** Do the same for the wildcard. NWILD=0 DO 20 I=1,LEN(WILDIN) IC=ICHAR(WILDIN(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 WILD(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 WILD(I:I)=CHAR(IC+64) * Anything else: don't do anything. ELSE WILD(I:I)=CHAR(IC) ENDIF * Keep track of the lenghts. IF(WILD(I:I).NE.' ')NWILD=I 20 CONTINUE *** Compare segment by segment. IW0=1 IW1=1 IR0=1 IR1=1 INIT=1 * Pick up the next segment of the wildcard. 100 CONTINUE IW1=IW0+INDEX(WILD(IW0:NWILD),'*')-2 IF(IW1.EQ.IW0-2)THEN IW1=NWILD ELSEIF(IW1.LT.IW0)THEN IW0=IW1+2 IF(IW0.GT.NWILD)GOTO 500 GOTO 100 ENDIF * Attempt to match with the reference string. IR1=IR0+INDEX(REF(IR0:NREF),WILD(IW0:IW1))-1 IF(IR1.EQ.IR0-1)THEN MATCH=.FALSE. RETURN ENDIF * Check the asterix at the beginning of the wildcard. IF(IR1.NE.1.AND.INIT.EQ.1.AND.WILD(1:1).NE.'*')THEN MATCH=.FALSE. RETURN ENDIF * Update the start of string pointers. IR0=IR1+(IW1-IW0+1) IW0=IW1+2 * Check whether the end has been reached. IF(IW0.GT.NWILD.OR.IR0.GT.NREF)GOTO 500 * Look for the next segment. INIT=0 GOTO 100 *** End of the line is reached. 500 CONTINUE * Figure out whether the end of the wildcard is pure asterix. ASTER=.TRUE. DO 510 I=MAX(1,IW0-1),NWILD IF(WILD(I:I).NE.'*')THEN ASTER=.FALSE. GOTO 520 ENDIF 510 CONTINUE 520 CONTINUE * Match if both strings have been used up entirely. IF(IR0.GT.NREF.AND.IW0.GT.NWILD)THEN MATCH=.TRUE. * Free end of reference string matching. ELSEIF(IR0.LE.NREF)THEN IF((IW0.GT.NWILD.AND.FREEND).OR. - (IW0.LE.NWILD+1.AND.ASTER))THEN MATCH=.TRUE. ELSE MATCH=.FALSE. ENDIF * Excess of non-asterix characters at the end of the wildcard. ELSEIF(IW0.LE.NWILD)THEN IF(IR0.GT.NREF.AND..NOT.ASTER)THEN MATCH=.FALSE. ELSE MATCH=.TRUE. ENDIF * Strange case. ELSE PRINT *,' ###### WLDCRD ERROR : No handling available,'// - ' program bug ; declared not to match.' PRINT *,' IW0=',IW0,', IW1=',IW1, - ', NWILD=',NWILD,', WILD="'//WILD(1:NWILD)//'"' PRINT *,' IR0=',IR0,', IR1=',IR1, - ', NREF =',NREF,', REF ="'//REF(1:NREF)//'"' PRINT *,' FREEND=',FREEND, - ', ASTER=',ASTER MATCH=.FALSE. ENDIF END +DECK,BSORT. SUBROUTINE BSORT(A,NR,COMPGT) *----------------------------------------------------------------------- * BSORT - Bubble sort using function COMPGT for comparisons. * Variables: * (Last changed on 20/ 1/97.) *----------------------------------------------------------------------- implicit none INTEGER NR,A(NR),AUX,I,J,INEW,NSWAP,NCOMP LOGICAL COMPGT EXTERNAL COMPGT *** Counters. NCOMP=0 NSWAP=0 C print *,' Initial ',(A(I),I=1,NR) C do i=1,nr C print *,(compgt(a(i),a(j)),j=1,nr) C enddo *** Loop over element to be put into place. DO 10 I=NR-1,1,-1 CALL PROSTA(1,REAL(NR-I)) *** Find its proper place. INEW=I DO 20 J=I+1,NR IF(COMPGT(A(I),A(J)))INEW=J NCOMP=NCOMP+1 20 CONTINUE *** Move it into that place. IF(INEW.NE.I)THEN * Check the sort. DO 50 J=I+1,INEW IF(COMPGT(A(J),A(I)))THEN PRINT *,' !!!!!! BSORT WARNING : Data not sortable'// - ' use the SPLIT-INTERSECTING-PLANES option.' RETURN ENDIF 50 CONTINUE * Exchange. C print *,' Exchanging ',A(I),' and ',A(INEW) AUX=A(I) DO 30 J=I+1,INEW A(J-1)=A(J) 30 CONTINUE A(INEW)=AUX NSWAP=NSWAP+1 ENDIF 10 CONTINUE C print *,' Final ',(A(I),I=1,NR) *** Statistics. C print *,' Comparisons: ',ncomp,', Swaps: ',nswap END +DECK,QSORT,IF=NEVER. SUBROUTINE QSORT(A,NR,LESSEQ) *----------------------------------------------------------------------- * QSORT - Quick sort algorithm of the objects in array A, using the * function LESSEQ for comparison. Based on CERNLIB M109. * Variables: L : Lower limit of the interval (input) * R : Upper limit of the interval (input) * I : Lower limit of upper sub-interval (output) * J : Upper limit of lower sub-interval (output) * (Last changed on 9/ 1/98.) *---------------------------------------------------------------------- implicit none INTEGER MXLEV PARAMETER(MXLEV=20) INTEGER NR,A(NR),X,LT(MXLEV),RT(MXLEV),TEMP,LEVEL,L,R,I,J,M, - NCOMP,NSWAP LOGICAL LESSEQ EXTERNAL LESSEQ *** Initial division level and subdivision range. LEVEL=1 LT(1)=1 RT(1)=NR *** Counters. NCOMP=0 NSWAP=0 *** Move a level higher up. 10 CONTINUE L=LT(LEVEL) R=RT(LEVEL) LEVEL=LEVEL-1 *** Start sort. 20 CONTINUE *** See whether lower and upper limit coincide. IF(R.LE.L)THEN * Sort not finished, move a level back. IF(LEVEL.GT.0)THEN GOTO 10 * Sort finished, reverse the order of the rows. ELSE print *,' Comparisons: ',ncomp,', Swaps: ',nswap RETURN ENDIF ENDIF *** Sort the new interval around its middle point. I=L J=R M=(L+R)/2 X=A(M) *** Sort the lower half of this interval. 30 CONTINUE NCOMP=NCOMP+1 IF(LESSEQ(X,A(I)))GOTO 40 I=I+1 GOTO 30 *** Search for a point in the upper half that is smaller. 40 CONTINUE NCOMP=NCOMP+1 IF(LESSEQ(A(J),X))THEN * When found, swap I and J and resume if there are more points. IF(I.LE.J)THEN TEMP=A(I) A(I)=A(J) A(J)=TEMP NSWAP=NSWAP+1 I=I+1 J=J-1 IF(I.LE.J)GOTO 30 ENDIF * See whether a level can be added. IF(LEVEL+1.GT.MXLEV)THEN PRINT *,' !!!!!! SORTQ WARNING : Subdivision level'// - ' exceeds maximum; increase MXLEV.' RETURN ENDIF LEVEL=LEVEL+1 * Add a level and restart search. IF((R-I).GE.(J-L))THEN LT(LEVEL)=I RT(LEVEL)=R R=J ELSE LT(LEVEL)=L RT(LEVEL)=J L=I ENDIF GOTO 20 ENDIF J=J-1 GOTO 40 END +PATCH,HISTOGRAM. +DECK,HISADM. SUBROUTINE HISADM(ACTION,IREF,NNCHA,XXMIN,XXMAX,AUTO,IFAIL) *----------------------------------------------------------------------- * HISADM - Takes care of histogram booking. * range setting if requested. * (Last changed on 11/ 2/97.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,HISTDATA. +SEQ,PRINTPLOT. +SEQ,GLOBALS. CHARACTER*(*) ACTION CHARACTER*10 NAME INTEGER IREF,IFAIL,NNCHA,I,J,NLIST REAL XXMIN,XXMAX LOGICAL AUTO *** Allocate a new histogram. IF(ACTION.EQ.'ALLOCATE'.OR.ACTION.EQ.'INTEGER')THEN * Check the request is reasonable. IF(NNCHA.GT.MXCHA.OR.NNCHA.LE.0.OR. - (XXMIN.GE.XXMAX.AND..NOT.AUTO))THEN PRINT *,' !!!!!! HISADM WARNING : Unreasonable'// - ' allocation request refused.' IFAIL=1 RETURN ENDIF * Look for a free slot. DO 10 I=1,MXHIST * Found a free slot. IF(.NOT.HISUSE(I))THEN IREF=I DO 20 J=0,MXCHA+1 CONTEN(IREF,J)=0.0 20 CONTINUE SX0(IREF)=0.0D0 SX1(IREF)=0.0D0 SX2(IREF)=0.0D0 NENTRY(IREF)=0 XMIN(IREF)=XXMIN XMAX(IREF)=XXMAX NCHA(IREF)=NNCHA SET(IREF)=.NOT.AUTO HISUSE(IREF)=.TRUE. IF(ACTION.EQ.'INTEGER')THEN HISLIN(IREF)=.TRUE. ELSE HISLIN(IREF)=.FALSE. ENDIF IFAIL=0 IF(LDEBUG)PRINT *,' ++++++ HISADM DEBUG :'// - ' Histogram ',IREF,' allocated.' RETURN ENDIF 10 CONTINUE * No free slot found. PRINT *,' !!!!!! HISADM WARNING : No free histogram'// - ' storage available; no slot allocated.' IREF=0 IFAIL=1 *** Release an allocated histogram. ELSEIF(ACTION.EQ.'DELETE')THEN IF(IREF.GE.1.AND.IREF.LE.MXHIST)THEN HISUSE(IREF)=.FALSE. IF(LDEBUG)PRINT *,' ++++++ HISADM DEBUG :'// - ' Histogram ',IREF,' deallocated.' DO 45 J=1,NGLB IF(GLBMOD(J).EQ.4.AND.NINT(GLBVAL(J)).EQ.IREF) - GLBMOD(J)=0 45 CONTINUE IFAIL=0 ELSE PRINT *,' !!!!!! HISADM WARNING : Histogram to be'// - ' deleted not found.' IFAIL=1 ENDIF *** List of histograms. ELSEIF(ACTION.EQ.'LIST')THEN * Print a header. WRITE(LUNOUT,'(/'' OVERVIEW OF EXISTING HISTOGRAMS''// - '' Number Global Integral Average'', - '' RMS Minimum Maximum''/)') * Loop over all histograms. NLIST=0 DO 30 I=1,MXHIST * Case 1: histogram slot not in use. IF(.NOT.HISUSE(I))GOTO 30 * Locate the global variable name that goes with the histogram. NAME='(none)' DO 40 J=1,NGLB IF(GLBMOD(J).EQ.4.AND.NINT(GLBVAL(J)).EQ.I) - NAME=GLBVAR(J) 40 CONTINUE * Case 2: histogram in use but still empty, range set. IF(NENTRY(I).EQ.0.AND.SET(I))THEN WRITE(LUNOUT,'(2X,I6,1X,A10,'' No entries yet'',16X, - 2(1X,E10.3))') I,NAME,XMIN(I),XMAX(I) * Case 3: histogram in use but still empty, range not yet set. ELSEIF(NENTRY(I).EQ.0)THEN WRITE(LUNOUT,'(2X,I6,1X,A10,'' Autorange histogram'', - '' without entries sofar'')') I,NAME * Case 4: entries available. ELSEIF(SET(I))THEN IF(SX0(I).LT.0)THEN WRITE(LUNOUT,'(2X,I6,1X,A10,1X,E10.3, - '' No statistics yet'',2(1X,E10.3))') - I,NAME,SX0(I),XMIN(I),XMAX(I) ELSEIF(SX0(I).LT.2)THEN WRITE(LUNOUT,'(2X,I6,1X,A10,2(1X,E10.3), - '' Undefined'',2(1X,E10.3))') - I,NAME,SX0(I),SX1(I)/SX0(I),XMIN(I),XMAX(I) ELSE WRITE(LUNOUT,'(2X,I6,1X,A10,5(1X,E10.3))') - I,NAME,SX0(I),SX1(I)/SX0(I), - SQRT((SX2(I)-SX1(I)**2/SX0(I))/ - (SX0(I)-1)),XMIN(I),XMAX(I) ENDIF ELSE WRITE(LUNOUT,'(2X,I6,1X,A10,3(1X,E10.3), - '' Range not yet set'')') I,NAME, - SX0(I),SX1(I)/SX0(I), - SQRT((SX2(I)-SX1(I)**2/SX0(I))/ - (SX0(I)-1)) ENDIF * Increment the counter. NLIST=NLIST+1 30 CONTINUE * Say how many histograms are currently known. WRITE(LUNOUT,'(/'' Number of histograms booked: '',I5/)') - NLIST *** Unknown action. ELSE PRINT *,' !!!!!! HISADM WARNING : Invalid action requested.' IFAIL=1 ENDIF END +DECK,HISBAR. SUBROUTINE HISBAR(IREF,NBAR,XBAR,IFAIL) *----------------------------------------------------------------------- * HISBAR - Returns the barycentre. * (Last changed on 4/ 2/96.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,HISTDATA. INTEGER IREF,NBAR,IFAIL REAL XBAR,XSUM,SUM,SUMMAX,WSUM *** Preset output for the event of failure. XBAR=0.0 IFAIL=1 *** Ensure that IREF exists and has a range. IF(IREF.LE.0.OR.IREF.GT.MXHIST)THEN PRINT *,' !!!!!! HISBAR WARNING : Histogram reference'// - ' not valid; no barycentre.' RETURN ELSEIF(.NOT.SET(IREF))THEN PRINT *,' !!!!!! HISBAR WARNING : The scale of the'// - ' input histogram is not yet set; no barycentre.' RETURN ELSEIF(NCHA(IREF).LE.0)THEN PRINT *,' !!!!!! HISBAR WARNING : Input histogram'// - ' has no bins; no barycentre.' RETURN ENDIF *** Also make sure the the number of bins to average over is OK. IF(NBAR.LE.0)THEN PRINT *,' !!!!!! HISBAR WARNING : Number of bins to'// - ' average over < 1; no barycentre.' RETURN ENDIF *** Locate the maximum. SUMMAX=-1 DO 10 I=1,MAX(1,NCHA(IREF)-NBAR+1) SUM=0 XSUM=0 WSUM=0 DO 20 J=I,MIN(I+NBAR-1,NCHA(IREF)) SUM=SUM+ABS(CONTEN(IREF,J)) XSUM=XSUM+CONTEN(IREF,J)* - (XMIN(IREF)+(J-0.5)*(XMAX(IREF)-XMIN(IREF))/ - REAL(NCHA(IREF))) WSUM=WSUM+CONTEN(IREF,J) 20 CONTINUE IF(SUM.GT.SUMMAX.AND.WSUM.NE.0)THEN SUMMAX=SUM XBAR=XSUM/WSUM ENDIF 10 CONTINUE *** Check that a maximum has been found. IF(SUMMAX.LE.0)THEN PRINT *,' !!!!!! HISBAR WARNING : No maximum has been'// - ' found; no barycentre.' RETURN ENDIF *** Seems to have worked. IFAIL=0 END +DECK,HISCAL. SUBROUTINE HISCAL(INSTR,IFAIL) *----------------------------------------------------------------------- * HISCAL - Processes histogram related procedure calls. * (Last changed on 18/ 3/01.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,ALGDATA. +SEQ,HISTDATA. +SEQ,MATDATA. +SEQ,GLOBALS. CHARACTER*(MXINCH) STRING CHARACTER*80 XTXT,TITLE CHARACTER*8 MEMBER REAL XXMIN,XXMAX,AVER,SIGMA,HMIN,HMAX,ENTRY,WEIGHT,XX LOGICAL HAUTO,HEXIST,HSET,FRAME,HINT INTEGER INPCMX,IPROC,NARG,IFAIL,INSTR,NNCHA,NNENTR,IREF,IFAIL1, - IFAIL2,IFAIL3,NCMEMB,NCREM,NCXTXT,NC,NCTITL,I,J,ISTR,NBIN, - IHISRF,IMATRF,IMATSL,MATSLT,ISIZ(1),NHIST,ISENT,ISWGT, - NSIZE EXTERNAL INPCMX,MATSLT *** Assume the CALL will fail. IFAIL=1 *** Some easy reference variables. NARG=INS(INSTR,3) IPROC=INS(INSTR,1) *** Book a histogram. IF(IPROC.EQ.-602)THEN * Check number and type of arguments. IF(NARG.LT.1.OR.NARG.GT.5.OR. - (NARG.EQ.2.AND.MODARG(2).NE.2.AND.MODARG(2).NE.1).OR. - (NARG.GT.2.AND.MODARG(2).NE.2).OR. - (NARG.EQ.3.AND.MODARG(3).NE.1).OR. - (NARG.GE.4.AND.(MODARG(3).NE.2.OR.MODARG(4).NE.2)).OR. - (NARG.GE.5.AND.MODARG(5).NE.1))THEN PRINT *,' !!!!!! HISCAL WARNING : Incorrect argument'// - ' list provided for BOOK_HISTOGRAM.' RETURN ENDIF * Check that the reference number can be transferred back. IF(ARGREF(1,1).GE.2)THEN PRINT *,' !!!!!! HISCAL WARNING : Unable to return'// - ' the histogram reference to calling procedure.' RETURN ENDIF * Free memory associated with argument. CALL ALGREU(NINT(ARG(1)),MODARG(1),ARGREF(1,1)) * Store arguments. IF(NARG.GE.2)THEN NNCHA=NINT(ARG(2)) ELSE NNCHA=100 ENDIF IF(NARG.GE.4)THEN HMIN=ARG(3) HMAX=ARG(4) HAUTO=.FALSE. ELSE HMIN=-1 HMAX=+1 HAUTO=.TRUE. ENDIF HINT=.FALSE. IF(MODARG(NARG).EQ.1)THEN CALL STRBUF('READ',NINT(ARG(NARG)),XTXT,NCXTXT,IFAIL1) IF(NCXTXT.LE.0)THEN XTXT=' ' NCXTXT=1 ENDIF CALL CLTOU(XTXT(1:NCXTXT)) IF(INDEX(XTXT(1:MAX(1,NCXTXT)),'MANUAL').NE.0)THEN IF(NARG.LT.5)THEN PRINT *,' !!!!!! HISCAL WARNING : The'// - ' MANUAL option requires the range'// - ' to be specified; assuming AUTO.' ELSE HAUTO=.FALSE. ENDIF ELSEIF(INDEX(XTXT(1:MAX(1,NCXTXT)),'AUTO').NE.0)THEN HAUTO=.TRUE. ENDIF IF(INDEX(XTXT(1:MAX(1,NCXTXT)),'INTEGER').NE.0)THEN HINT=.TRUE. ELSEIF(INDEX(XTXT(1:MAX(1,NCXTXT)),'REAL').NE.0)THEN HINT=.FALSE. ENDIF ENDIF * Book the histogram. IF(HINT)THEN CALL HISADM('INTEGER',IHISRF,NNCHA,HMIN,HMAX, - HAUTO,IFAIL1) ELSE CALL HISADM('ALLOCATE',IHISRF,NNCHA,HMIN,HMAX, - HAUTO,IFAIL1) ENDIF * Back-transfer the reference number. IF(IFAIL1.EQ.0)THEN ARG(1)=IHISRF MODARG(1)=4 ELSE PRINT *,' !!!!!! HISCAL WARNING : Unable to allocate'// - ' the histogram.' ARG(1)=0 MODARG(1)=0 ENDIF *** Fill histogram. ELSEIF(IPROC.EQ.-603)THEN * Check number and type of arguments. IF(MODARG(1).NE.4.OR. - (MODARG(2).NE.2.AND.MODARG(2).NE.5).OR. - (NARG.GE.3.AND.MODARG(3).NE.2.AND.MODARG(3).NE.5).OR. - NARG.LT.2.OR.NARG.GT.3)THEN PRINT *,' !!!!!! HISCAL WARNING : Incorrect argument'// - ' list provided for FILL_HISTOGRAM.' RETURN ENDIF * Locate entries. IF(MODARG(2).EQ.5)THEN ISENT=MATSLT(NINT(ARG(2))) IF(ISENT.LE.0)THEN PRINT *,' !!!!!! HISCAL WARNING : Unable'// - ' to locate the entries; no filling.' RETURN ENDIF ELSE ISENT=0 ENDIF * Locate weights. IF(MODARG(3).EQ.5.AND.NARG.GE.3)THEN ISWGT=MATSLT(NINT(ARG(3))) IF(ISWGT.LE.0)THEN PRINT *,' !!!!!! HISCAL WARNING : Unable'// - ' to locate the weights; no filling.' RETURN ENDIF ELSE ISWGT=0 ENDIF * Verify compatibility. IF(ISENT.NE.0.AND.ISWGT.NE.0)THEN IF(MLEN(ISENT).NE.MLEN(ISWGT))THEN PRINT *,' !!!!!! HISCAL WARNING : Entry'// - ' and weight vectors are not'// - ' compatible; no filling.' RETURN ELSE NSIZE=MLEN(ISENT) ENDIF ELSEIF(ISENT.NE.0)THEN NSIZE=MLEN(ISENT) ELSEIF(ISWGT.NE.0)THEN NSIZE=MLEN(ISWGT) ELSE NSIZE=1 ENDIF * Perform filling. DO 110 I=1,NSIZE IF(ISENT.EQ.0)THEN ENTRY=ARG(2) ELSE ENTRY=MVEC(MORG(ISENT)+I) ENDIF IF(ISWGT.EQ.0)THEN IF(NARG.GE.3)THEN WEIGHT=ARG(3) ELSE WEIGHT=1.0 ENDIF ELSE WEIGHT=MVEC(MORG(ISWGT)+I) ENDIF CALL HISENT(NINT(ARG(1)),ENTRY,WEIGHT) 110 CONTINUE *** Plot a histogram. ELSEIF(IPROC.EQ.-604)THEN * Check number and type of arguments. IF(MODARG(1).NE.4.OR. - (NARG.GE.2.AND.MODARG(2).NE.1).OR. - (NARG.GE.3.AND.MODARG(3).NE.1).OR. - (NARG.GE.4.AND.MODARG(4).NE.1).OR. - NARG.LT.1.OR.NARG.GT.4)THEN PRINT *,' !!!!!! HISCAL WARNING : Incorrect argument'// - ' list provided for PLOT_HISTOGRAM.' RETURN ENDIF * Check option. FRAME=.TRUE. IF(NARG.GE.4)THEN CALL STRBUF('READ',NINT(ARG(4)),TITLE,NCTITL,IFAIL1) IF(NCTITL.LT.1)THEN TITLE=' ' NCTITL=1 ENDIF CALL CLTOU(TITLE(1:NCTITL)) IF(INDEX(TITLE(1:NCTITL),'NOFRAME').NE.0)THEN FRAME=.FALSE. ELSEIF(INDEX(TITLE(1:NCTITL),'FRAME').NE.0)THEN FRAME=.TRUE. ENDIF ENDIF * Fetch titles. IF(NARG.GE.2)THEN CALL STRBUF('READ',NINT(ARG(2)),XTXT,NCXTXT,IFAIL1) IF(IFAIL1.NE.0)XTXT=' ' IF(IFAIL1.NE.0)NCXTXT=1 ELSE XTXT='Coordinate' NCXTXT=10 ENDIF IF(NARG.GE.3)THEN CALL STRBUF('READ',NINT(ARG(3)),TITLE,NCTITL,IFAIL2) IF(IFAIL2.NE.0)TITLE=' ' IF(IFAIL2.NE.0)NCTITL=1 ELSE TITLE='Title' NCTITL=5 ENDIF IF((NARG.LT.3.OR.TITLE(1:NCTITL).EQ.'*').AND. - ARGREF(1,2).GE.1.AND.ARGREF(1,2).LE.NGLB)THEN TITLE=GLBVAR(ARGREF(1,2)) NCTITL=LEN(GLBVAR(ARGREF(1,2))) ENDIF * Plot. CALL HISPLT(NINT(ARG(1)),XTXT(1:NCXTXT),TITLE(1:NCTITL), - FRAME) *** Print a histogram. ELSEIF(IPROC.EQ.-605)THEN * Check number and type of arguments. IF(MODARG(1).NE.4.OR. - (NARG.GE.2.AND.MODARG(2).NE.1).OR. - (NARG.GE.3.AND.MODARG(3).NE.1).OR. - NARG.LT.1.OR.NARG.GT.3)THEN PRINT *,' !!!!!! HISCAL WARNING : Incorrect argument'// - ' list provided for PRINT_HISTOGRAM.' RETURN ENDIF * Fetch strings. IF(NARG.GE.2)THEN CALL STRBUF('READ',NINT(ARG(2)),XTXT,NCXTXT,IFAIL1) IF(IFAIL1.NE.0)XTXT=' ' IF(IFAIL1.NE.0)NCXTXT=1 ELSE XTXT='Coordinate' NCXTXT=10 ENDIF IF(NARG.GE.3)THEN CALL STRBUF('READ',NINT(ARG(3)),TITLE,NCTITL,IFAIL2) IF(IFAIL2.NE.0)TITLE=' ' IF(IFAIL2.NE.0)NCTITL=1 ELSE TITLE='Title' NCTITL=5 ENDIF IF((NARG.LT.3.OR.TITLE(1:NCTITL).EQ.'*').AND. - ARGREF(1,2).GE.1.AND.ARGREF(1,2).LE.NGLB)THEN TITLE=GLBVAR(ARGREF(1,2)) NCTITL=LEN(GLBVAR(ARGREF(1,2))) ENDIF * Print. CALL HISPRT(NINT(ARG(1)),XTXT(1:NCXTXT),TITLE(1:NCTITL)) *** Delete a histogram. ELSEIF(IPROC.EQ.-606)THEN * Without arguments, delete all histograms. IF(NARG.LT.1)THEN DO 10 I=1,NGLB IF(GLBMOD(I).EQ.4)THEN CALL HISADM('DELETE',NINT(GLBVAL(I)), - 0,0.0,0.0,.FALSE.,IFAIL1) GLBVAL(I)=0 GLBMOD(I)=0 ENDIF 10 CONTINUE CALL HISINT * Delete all the matrices in the arguments. ELSE DO 40 I=1,NARG IF(MODARG(I).NE.4)THEN PRINT *,' !!!!!! HISCAL WARNING : Argument ',I, - ' is not an histogram; not deleted.' GOTO 40 ENDIF CALL HISADM('DELETE',NINT(ARG(I)), - 0,0.0,0.0,.FALSE.,IFAIL1) ARG(I)=0 MODARG(I)=0 IF(IFAIL1.NE.0)PRINT *,' !!!!!! HISCAL WARNING :'// - ' Deleting an histogram failed.' 40 CONTINUE ENDIF *** List histograms. ELSEIF(IPROC.EQ.-607)THEN * Check number and type of arguments. IF(NARG.NE.0)THEN PRINT *,' !!!!!! HISCAL WARNING : Incorrect argument'// - ' list provided for LIST_HISTOGRAMS.' RETURN ENDIF * List. CALL HISADM('LIST',0,0,0.0,0.0,.FALSE.,IFAIL1) *** Write a histogram to disk. ELSEIF(IPROC.EQ.-608)THEN * Check number and type of arguments. IF(MODARG(1).NE.4.OR.MODARG(2).NE.1.OR. - (NARG.GE.3.AND.MODARG(3).NE.1).OR. - (NARG.GE.4.AND.MODARG(4).NE.1).OR. - NARG.LT.2.OR.NARG.GT.4)THEN PRINT *,' !!!!!! HISCAL WARNING : Incorrect argument'// - ' list provided for WRITE_HISTOGRAM.' RETURN ENDIF * Fetch file name. CALL STRBUF('READ',NINT(ARG(2)),STRING,NC,IFAIL1) * Member name. IF(NARG.GE.3)THEN CALL STRBUF('READ',NINT(ARG(3)),MEMBER,NCMEMB,IFAIL2) IF(NCMEMB.GT.8)PRINT *,' !!!!!! HISCAL WARNING :'// - ' Member name truncated to first 8 characters' NCMEMB=MIN(8,NCMEMB) ELSE DO 20 J=1,NGLB IF(GLBMOD(J).NE.4)GOTO 20 IF(NINT(GLBVAL(J)).EQ.NINT(ARG(1)))THEN MEMBER=GLBVAR(J) NCMEMB=8 GOTO 30 ENDIF 20 CONTINUE MEMBER='< none >' NCMEMB=8 30 CONTINUE IFAIL2=0 ENDIF * Remark. IF(NARG.GE.4)THEN CALL STRBUF('READ',NINT(ARG(4)),TITLE,NCREM,IFAIL3) IF(NCREM.GT.29)PRINT *,' !!!!!! HISCAL WARNING :'// - ' Remark truncated to first 29 characters' NCREM=MIN(29,NCREM) ELSE TITLE='none' NCREM=4 IFAIL3=0 ENDIF * Write the histogram. IF(IFAIL1.EQ.0.AND.IFAIL2.EQ.0.AND.IFAIL3.EQ.0)THEN CALL HISWRT(NINT(ARG(1)),STRING(1:NC),MEMBER(1:NCMEMB), - TITLE(1:NCREM),IFAIL2) IF(IFAIL2.NE.0)PRINT *,' !!!!!! HISCAL WARNING :'// - ' Writing histogram to disk failed.' ELSE PRINT *,' !!!!!! HISCAL WARNING :'// - ' Not able to obtain a name; histogram'// - ' not written to disk.' ENDIF *** Read a histogram from disk. ELSEIF(IPROC.EQ.-609)THEN * Check number and type of arguments. IF(ARGREF(1,1).GE.2.OR. - MODARG(2).NE.1.OR. - (NARG.GE.3.AND.MODARG(3).NE.1).OR. - NARG.LT.2.OR.NARG.GT.3)THEN PRINT *,' !!!!!! HISCAL WARNING : Incorrect argument'// - ' list provided for GET_HISTOGRAM.' RETURN ENDIF * Fetch file name. CALL STRBUF('READ',NINT(ARG(2)),STRING,NC,IFAIL1) * Fetch the member name, if present. IF(NARG.GE.3)THEN CALL STRBUF('READ',NINT(ARG(3)),MEMBER,NCMEMB,IFAIL2) IF(NCMEMB.GT.8)PRINT *,' !!!!!! HISCAL WARNING :'// - ' Member name truncated to first 8 characters' NCMEMB=MIN(8,NCMEMB) ELSEIF(ARGREF(1,2).GE.1.AND.ARGREF(1,2).LE.NGLB)THEN MEMBER=GLBVAR(ARGREF(1,2)) NCMEMB=8 IFAIL2=0 ELSE MEMBER='*' NCMEMB=1 IFAIL2=0 ENDIF * Read the histogram. IF(IFAIL1.EQ.0.AND.IFAIL2.EQ.0)THEN CALL ALGREU(NINT(ARG(1)),MODARG(1),ARGREF(1,1)) CALL HISGET(IREF,STRING(1:NC),MEMBER(1:NCMEMB),IFAIL3) IF(IFAIL3.NE.0)THEN PRINT *,' !!!!!! HISCAL WARNING :'// - ' Reading histogram from disk failed.' ARG(1)=0 MODARG(1)=0 ELSE ARG(1)=IREF MODARG(1)=4 ENDIF ELSE PRINT *,' !!!!!! HISCAL WARNING :'// - ' Not able to obtain a name; histogram'// - ' not read from disk.' ENDIF *** Obtain information about an histogram. ELSEIF(IPROC.EQ.-610)THEN * Check number and type of arguments. IF(MODARG(1).NE.4.OR.NARG.LT.2.OR. - (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))THEN PRINT *,' !!!!!! HISCAL WARNING : Incorrect argument'// - ' list provided for INQUIRE_HISTOGRAM.' RETURN ENDIF * Obtain the information. CALL HISINQ(NINT(ARG(1)),HEXIST,HSET,NNCHA,XXMIN,XXMAX, - NNENTR,AVER,SIGMA) * Variables already in use ? DO 250 ISTR=2,NARG CALL ALGREU(NINT(ARG(ISTR)),MODARG(ISTR),ARGREF(ISTR,1)) 250 CONTINUE * Transfer information. IF(NARG.GE.2)THEN IF(HEXIST)THEN ARG(2)=1 ELSE ARG(2)=0 ENDIF ENDIF IF(NARG.GE.3)THEN MODARG(2)=3 IF(HSET)THEN ARG(3)=1 ELSE ARG(3)=0 ENDIF MODARG(3)=3 ENDIF IF(NARG.GE.4)THEN ARG(4)=REAL(NNCHA) MODARG(4)=2 ENDIF IF(NARG.GE.5)THEN ARG(5)=XXMIN MODARG(5)=2 ENDIF IF(NARG.GE.6)THEN ARG(6)=XXMAX MODARG(6)=2 ENDIF IF(NARG.GE.7)THEN ARG(7)=REAL(NNENTR) MODARG(7)=2 ENDIF IF(NARG.GE.8)THEN ARG(8)=AVER MODARG(8)=2 ENDIF IF(NARG.GE.9)THEN ARG(9)=SIGMA MODARG(9)=2 ENDIF *** Convolute 2 histograms. ELSEIF(IPROC.EQ.-611)THEN * Check argument list. IF(NARG.NE.3.OR.MODARG(1).NE.4.OR.MODARG(2).NE.4.OR. - ARGREF(3,1).GE.2)THEN PRINT *,' !!!!!! HISCAL WARNING : Incorrect set of'// - ' arguments given to CONVOLUTE; nothing done.' CALL LOGSAV(.FALSE.,'OK',IFAIL1) RETURN ENDIF * Free memory associated with the return argument. CALL ALGREU(NINT(ARG(3)),MODARG(3),ARGREF(3,1)) * Perform the convolution. CALL HISCNV(NINT(ARG(1)),NINT(ARG(2)),IREF,IFAIL1) * Check the return code. IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! HISCAL WARNING : Convolution'// - ' failed; no histogram returned.' CALL LOGSAV(.FALSE.,'OK',IFAIL1) ELSE CALL LOGSAV(.TRUE.,'OK',IFAIL1) ARG(3)=IREF MODARG(3)=4 ENDIF *** Compute the barycentre of a histogram. ELSEIF(IPROC.EQ.-612)THEN * Check the argument list. IF(NARG.LT.2.OR.MODARG(1).NE.4.OR.ARGREF(2,1).GE.2.OR. - (NARG.GE.3.AND.MODARG(3).NE.2).OR. - NARG.GT.3)THEN PRINT *,' !!!!!! HISCAL WARNING : Incorrect set of'// - ' arguments given to BARYCENTRE; nothing done.' CALL LOGSAV(.FALSE.,'OK',IFAIL1) RETURN ENDIF * Free memory associated with the return argument. CALL ALGREU(NINT(ARG(2)),MODARG(2),ARGREF(2,1)) * Pick up the number of bins. NBIN=3 IF(NARG.GE.3)NBIN=NINT(ARG(3)) * Compute the barycentre. CALL HISBAR(NINT(ARG(1)),NBIN,ARG(2),IFAIL1) * Check the return code. IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! HISCAL WARNING : Barycentre'// - ' calculation failed; no value returned.' CALL LOGSAV(.FALSE.,'OK',IFAIL1) ELSE CALL LOGSAV(.TRUE.,'OK',IFAIL1) MODARG(2)=2 ENDIF *** Copy a histogram to a matrix. ELSEIF(IPROC.EQ.-613)THEN * Check argument list. IF(NARG.LT.2.OR.NARG.GT.4.OR. - MODARG(1).NE.4.OR. - 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))THEN PRINT *,' !!!!!! HISCAL WARNING : Incorrect set of'// - ' arguments for HISTOGRAM_TO_MATRIX;'// - ' nothing done.' CALL LOGSAV(.FALSE.,'OK',IFAIL1) RETURN ENDIF * Check the histogram. IHISRF=NINT(ARG(1)) IF(IHISRF.LE.0.OR.IHISRF.GT.MXHIST)THEN PRINT *,' !!!!!! HISCAL WARNING : Invalid histogram'// - ' reference; no copied to a matrix.' CALL LOGSAV(.FALSE.,'OK',IFAIL1) RETURN ELSEIF((.NOT.HISUSE(IHISRF)).OR.(.NOT.SET(IHISRF)))THEN PRINT *,' !!!!!! HISCAL WARNING : Histogram not in'// - ' use or range not set; no copied to a matrix.' CALL LOGSAV(.FALSE.,'OK',IFAIL1) RETURN ENDIF * Free memory associated with the return argument. CALL ALGREU(NINT(ARG(2)),MODARG(2),ARGREF(2,1)) IF(NARG.GE.3)CALL ALGREU(NINT(ARG(3)),MODARG(3),ARGREF(3,1)) IF(NARG.GE.4)CALL ALGREU(NINT(ARG(4)),MODARG(4),ARGREF(4,1)) * Book a matrix for the contents. ISIZ(1)=NCHA(IHISRF) CALL MATADM('ALLOCATE',IMATRF,1,ISIZ,2,IFAIL1) * Locate the matrix. IMATSL=MATSLT(IMATRF) IF(IFAIL1.NE.0.OR.IMATSL.LE.0)THEN PRINT *,' !!!!!! HISCAL WARNING : Unable to obtain'// - ' matrix space ; histogram not copied.' CALL LOGSAV(.FALSE.,'OK',IFAIL1) RETURN ENDIF * Copy the histogram to a matrix. DO 50 I=1,NCHA(IHISRF) MVEC(MORG(IMATSL)+I)=CONTEN(IHISRF,I) 50 CONTINUE ARG(2)=IMATRF MODARG(2)=5 * And copy the ranges if requested. IF(NARG.GE.3)THEN ARG(3)=XMIN(IHISRF) MODARG(3)=2 ENDIF IF(NARG.GE.4)THEN ARG(4)=XMAX(IHISRF) MODARG(4)=2 ENDIF * Seems to have worked. CALL LOGSAV(.TRUE.,'OK',IFAIL1) *** Copy a matrix to a histogram. ELSEIF(IPROC.EQ.-614)THEN * Check argument list. IF(NARG.GT.4.OR. - MODARG(1).NE.5.OR.MODARG(2).NE.2.OR.MODARG(3).NE.2.OR. - ARGREF(4,1).GE.2)THEN PRINT *,' !!!!!! HISCAL WARNING : Incorrect set of'// - ' arguments for MATRIX_TO_HISTOGRAM;'// - ' nothing done.' CALL LOGSAV(.FALSE.,'OK',IFAIL1) RETURN ENDIF * Check the matrix. IMATRF=NINT(ARG(1)) IMATSL=MATSLT(IMATRF) IF(IMATSL.LE.0)THEN PRINT *,' !!!!!! HISCAL WARNING : Invalid matrix'// - ' reference; no copied to a histogram.' CALL LOGSAV(.FALSE.,'OK',IFAIL1) RETURN ELSEIF(MDIM(IMATSL).NE.1)THEN PRINT *,' ------ HISCAL MESSAGE : Matrix is not'// - ' 1-dimensional; unfolded.' ENDIF * Free memory associated with the return argument. CALL ALGREU(NINT(ARG(4)),MODARG(4),ARGREF(4,1)) * Book a histogram for the contents. CALL HISADM('ALLOCATE',IHISRF,MLEN(IMATSL),ARG(2),ARG(3), - .FALSE.,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! HISCAL WARNING : Unable to obtain'// - ' histogram space ; matrix not copied.' CALL LOGSAV(.FALSE.,'OK',IFAIL1) RETURN ENDIF * Copy the histogram to a matrix. SX0(IHISRF)=0 SX1(IHISRF)=0 SX2(IHISRF)=0 DO 60 I=1,NCHA(IHISRF) CONTEN(IHISRF,I)=MVEC(MORG(IMATSL)+I) XX=XMIN(IHISRF)+REAL(I-0.5)*(XMAX(IHISRF)-XMIN(IHISRF))/ - REAL(NCHA(IHISRF)) SX0(IHISRF)=SX0(IHISRF)+CONTEN(IHISRF,I) SX1(IHISRF)=SX1(IHISRF)+CONTEN(IHISRF,I)*XX SX2(IHISRF)=SX2(IHISRF)+CONTEN(IHISRF,I)*XX**2 60 CONTINUE NENTRY(IHISRF)=0 ARG(4)=IHISRF MODARG(4)=4 * Seems to have worked. CALL LOGSAV(.TRUE.,'OK',IFAIL1) +SELF,IF=HIGZ. *** RZ output of an histogram. ELSEIF(IPROC.EQ.-615)THEN * Check argument list. IF(NARG.GT.3.OR. - (NARG.GE.1.AND.MODARG(1).NE.4.AND.MODARG(1).NE.1).OR. - (NARG.GE.2.AND.MODARG(2).NE.1).OR. - (NARG.GE.3.AND.MODARG(3).NE.1))THEN PRINT *,' !!!!!! HISCAL WARNING : Incorrect argument'// - ' list for WRITE_HISTOGRAM_RZ; not written.' RETURN ENDIF * Check the histogram number. IF(NARG.LE.0)THEN IREF=0 ELSEIF(MODARG(1).EQ.1)THEN CALL STRBUF('READ',NINT(ARG(1)),XTXT,NCXTXT,IFAIL1) IF(NCXTXT.LE.0)NCXTXT=1 CALL CLTOU(XTXT(1:NCXTXT)) IF(XTXT(1:NCXTXT).EQ.'ALL')THEN IREF=0 ELSE PRINT *,' !!!!!! HISCAL WARNING : Invalid'// - ' histogram identifier; nothing written.' RETURN ENDIF ELSEIF(MODARG(1).EQ.4)THEN IREF=NINT(ARG(1)) ELSE PRINT *,' !!!!!! HISCAL WARNING : Invalid'// - ' histogram identifier; nothing written.' RETURN ENDIF * Fetch the file name. IF(NARG.GE.2)THEN CALL STRBUF('READ',NINT(ARG(2)),STRING,NC,IFAIL1) ELSE STRING='garfield.rz' NC=11 IFAIL1=0 ENDIF * Fetch the title. IF(NARG.GE.3)THEN CALL STRBUF('READ',NINT(ARG(3)),TITLE,NCTITL,IFAIL2) IF(NCTITL.LE.0)THEN TITLE=' ' NCTITL=1 ENDIF ELSE TITLE=' ' NCTITL=1 IFAIL2=0 ENDIF * Check fetches. IF(IFAIL1.NE.0.OR.IFAIL2.NE.0)THEN PRINT *,' !!!!!! HISCAL WARNING : Unable to fetch an'// - ' argument of WRITE_HISTOGRAM_RZ; no write.' RETURN ENDIF * Write all histograms. IF(IREF.EQ.0)THEN NHIST=0 DO 70 I=1,MXHIST IF(.NOT.HISUSE(I))GOTO 70 TITLE='Histogram ' CALL OUTFMT(REAL(I),2,TITLE(11:),NCTITL,'LEFT') NCTITL=NCTITL+11 DO 80 J=1,NGLB IF(GLBMOD(J).EQ.4.AND.NINT(GLBVAL(J)).EQ.I)THEN TITLE=GLBVAR(J) NCTITL=LEN(GLBVAR(J)) ENDIF 80 CONTINUE IF(.NOT.SET(I))THEN PRINT *,' !!!!!! HISCAL WARNING : '// - TITLE(1:NCTITL)//' not written to the RZ'// - ' file because the range is not set.' ELSE PRINT *,' ------ HISCAL MESSAGE : Writing '// - TITLE(1:NCTITL) CALL HISRZO(I,STRING(1:NC),TITLE(1:NCTITL), - IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! HISCAL WARNING : Writing '// - TITLE(1:NCTITL)//' failed.' ELSE NHIST=NHIST+1 ENDIF ENDIF 70 CONTINUE PRINT *,' ------ HISCAL MESSAGE : ',NHIST, - ' Histograms written to the RZ file.' * Write only 1 histogram. ELSE IF(NARG.LT.3.AND.ARGREF(1,2).GE.1.AND. - ARGREF(1,2).LE.NGLB)THEN TITLE=GLBVAR(ARGREF(1,2)) NCTITL=LEN(GLBVAR(ARGREF(1,2))) ENDIF CALL HISRZO(IREF,STRING(1:NC),TITLE(1:NCTITL),IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! HISCAL WARNING : Writing in RZ'// - ' format failed.' RETURN ENDIF ENDIF +SELF. *** Cut an histogram. ELSEIF(IPROC.EQ.-616)THEN * Check argument list. IF(NARG.NE.4.OR.MODARG(1).NE.4.OR. - MODARG(2).NE.2.OR.MODARG(3).NE.2.OR. - ARGREF(4,1).GE.2)THEN PRINT *,' !!!!!! HISCAL WARNING : Incorrect argument'// - ' list for CUT_HISTOGRAM; no sub-range.' RETURN ENDIF * Take the sub-range. CALL HISCUT(NINT(ARG(1)),ARG(2),ARG(3),IREF,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! HISCAL WARNING : Cutting the'// - ' histogram failed; no sub-range.' RETURN ENDIF * Free memory associated with the return argument. CALL ALGREU(NINT(ARG(4)),MODARG(4),ARGREF(4,1)) * Return the histogram. ARG(4)=REAL(IREF) MODARG(4)=4 *** Rebin an histogram. ELSEIF(IPROC.EQ.-617)THEN * Check argument list. IF(NARG.NE.3.OR.MODARG(1).NE.4.OR. - MODARG(2).NE.2.OR. - ARGREF(3,1).GE.2)THEN PRINT *,' !!!!!! HISCAL WARNING : Incorrect argument'// - ' list for REBIN_HISTOGRAM; not sub-range.' RETURN ENDIF * Take the sub-range. CALL HISREB(NINT(ARG(1)),NINT(ARG(2)),IREF,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! HISCAL WARNING : Rebinning the'// - ' histogram failed; no rebinned histogram.' RETURN ENDIF * Free memory associated with the return argument. CALL ALGREU(NINT(ARG(3)),MODARG(3),ARGREF(3,1)) * Return the histogram. ARG(3)=REAL(IREF) MODARG(3)=4 *** Reset the contents of an histogram. ELSEIF(IPROC.EQ.-618)THEN * Without arguments, reset all histograms. IF(NARG.LT.1)THEN DO 100 I=1,NGLB IF(GLBMOD(I).EQ.4)CALL HISRES(NINT(GLBVAL(I)),IFAIL1) IF(IFAIL1.NE.0)PRINT *,' !!!!!! HISCAL WARNING :'// - ' Failed to delete histogram '//GLBVAR(I) 100 CONTINUE ELSE DO 90 I=1,NARG IF(MODARG(I).NE.4)THEN PRINT *,' !!!!!! HISCAL WARNING : Argument ',I, - ' of RESET_HISTOGRAM is not an histogram;'// - ' not reset.' ELSEIF(ARGREF(I,1).GE.2)THEN PRINT *,' !!!!!! HISCAL WARNING : Argument ',I, - ' of RESET_HISTOGRAM is not modifiable;'// - ' not reset.' ELSE CALL HISRES(NINT(ARG(I)),IFAIL1) IF(IFAIL1.NE.0)PRINT *,' !!!!!! HISCAL'// - ' WARNING : Failed to delete histogram '// - ' for argument ',I ENDIF 90 CONTINUE ENDIF *** Cumulate an histogram. ELSEIF(IPROC.EQ.-619)THEN * Check argument list. IF(NARG.NE.2.OR.MODARG(1).NE.4)THEN PRINT *,' !!!!!! HISCAL WARNING : Incorrect argument'// - ' list for CUMULATE_HISTOGRAM; not output.' RETURN ENDIF * Take the sub-range. CALL HISCUM(NINT(ARG(1)),IREF,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! HISCAL WARNING : Unable to create'// - ' a cumulative histogram; no output.' RETURN ENDIF * Free memory associated with the return argument. CALL ALGREU(NINT(ARG(2)),MODARG(2),ARGREF(2,1)) * Return the histogram. ARG(2)=REAL(IREF) MODARG(2)=4 *** Unknown matrix operation. ELSE PRINT *,' !!!!!! HISCAL WARNING : Unknown procedure code'// - ' received; nothing done.' IFAIL=1 RETURN ENDIF *** Seems to have worked. IFAIL=0 END +DECK,HISCNV. SUBROUTINE HISCNV(IREF1,IREF2,IREF3,IFAIL) *----------------------------------------------------------------------- * HISCNV - Convolutes histograms IREF1 and IREF2 to yield IREF3. * (Last changed on 4/ 2/96.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,HISTDATA. INTEGER IREF1,IREF2,IREF3,IFAIL REAL BIN1,BIN2 *** Preset IREF3 to 0, i.e. non-existing. IREF3=0 IFAIL=1 *** Ensure that both IREF1 and IREF2 exist and have a range. IF(IREF1.LE.0.OR.IREF1.GT.MXHIST.OR. - IREF2.LE.0.OR.IREF2.GT.MXHIST)THEN PRINT *,' !!!!!! HISCNV WARNING : Histogram reference'// - ' not valid; no convolution.' RETURN ELSEIF((.NOT.SET(IREF1)).OR.(.NOT.SET(IREF2)))THEN PRINT *,' !!!!!! HISCNV WARNING : The scale of an'// - ' input histogram is not yet set; no convolution.' RETURN ELSEIF(NCHA(IREF1).LE.0.OR.NCHA(IREF2).LE.0)THEN PRINT *,' !!!!!! HISCNV WARNING : An input histogram'// - ' has no bins; no convolution.' RETURN ENDIF *** Check the compatibility between the histograms. BIN1=(XMAX(IREF1)-XMIN(IREF1))/NCHA(IREF1) BIN2=(XMAX(IREF2)-XMIN(IREF2))/NCHA(IREF2) IF(ABS(BIN1-BIN2).GT.1E-4*(ABS(BIN1)+ABS(BIN2)))THEN PRINT *,' !!!!!! HISCNV WARNING : Bin size of the'// - ' histograms differs, no convolution.' RETURN ENDIF *** Obtain a new histogram. CALL HISADM('ALLOCATE',IREF3,NCHA(IREF1)+NCHA(IREF2)-1, - XMIN(IREF1)+XMIN(IREF2)+(BIN1+BIN2)/4, - XMAX(IREF1)+XMAX(IREF2)-(BIN1+BIN2)/4, - .FALSE.,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! HISCNV WARNING : Unable to obtain an'// - ' output histogram; no convolution.' RETURN ENDIF *** Now perform the convolution. DO 10 I=1,NCHA(IREF3) CONTEN(IREF3,I)=0 DO 20 J=1,NCHA(IREF1) IF(I-J+1.LT.1.OR.I-J+1.GT.NCHA(IREF2))GOTO 20 CONTEN(IREF3,I)=CONTEN(IREF3,I)+ - CONTEN(IREF1,J)*CONTEN(IREF2,I-J+1) 20 CONTINUE 10 CONTINUE *** Seems to have worked. IFAIL=0 END +DECK,HISCUM. SUBROUTINE HISCUM(IREFI,IREFO,IFAIL) *----------------------------------------------------------------------- * HISCUM - Creates a cumulative version of a histogram. * (Last changed on 24/ 7/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,HISTDATA. +SEQ,PRINTPLOT. INTEGER IREFI,IREFO,IFAIL,IFAIL1,I *** Assume that things will work. IFAIL=0 *** Check reference number. IF(IREFI.LE.0)THEN PRINT *,' !!!!!! HISCUM WARNING : Histogram reference'// - ' not valid; no cumulative version returned.' IFAIL=1 RETURN * See whether the histogram is in use. ELSEIF(.NOT.HISUSE(IREFI))THEN PRINT *,' !!!!!! HISCUM WARNING : Histogram is not'// - ' currently in use; no cumulative version.' RETURN * See whether the range is set. ELSEIF(.NOT.SET(IREFI))THEN PRINT *,' !!!!!! HISCUM WARNING : Range not yet set;'// - ' no cumulative version.' RETURN ENDIF *** Book an histogram with the same dimensions. CALL HISADM('ALLOCATE',IREFO,NCHA(IREFI), - XMIN(IREFI),XMAX(IREFI),.FALSE.,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! HISCUM WARNING : Unable to create an'// - ' histogram; no cumulative version returned.' IFAIL=1 RETURN ENDIF *** Produce a cumulative histogram. CONTEN(IREFO,0)=CONTEN(IREFI,0) DO 40 I=1,NCHA(IREFI)+1 CONTEN(IREFO,I)=CONTEN(IREFO,I-1)+CONTEN(IREFI,I) 40 CONTINUE *** Copy entries and summing information. SX0(IREFO)=SX0(IREFI) SX1(IREFO)=SX1(IREFI) SX2(IREFO)=SX2(IREFI) NENTRY(IREFO)=NENTRY(IREFI) END +DECK,HISCUT. SUBROUTINE HISCUT(IREF1,X0,X1,IREF2,IFAIL) *----------------------------------------------------------------------- * HISCUT - Cuts a piece from a histogram. * (Last changed on 12/ 9/99.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,HISTDATA. +SEQ,PRINTPLOT. +SEQ,GLOBALS. INTEGER IREF1,IREF2,IFAIL,IFAIL1,I0,I1,I,IAUX REAL X0,X1,XX0,XX1 *** Assume this will fail. IFAIL=1 *** Check reference number. IF(IREF1.LE.0.OR.IREF1.GT.MXHIST)THEN PRINT *,' !!!!!! HISCUT WARNING : Invalid histogram'// - ' reference; no sub-range.' RETURN * See whether the histogram is in use. ELSEIF(.NOT.HISUSE(IREF1))THEN PRINT *,' !!!!!! HISCUT WARNING : Histogram is not'// - ' currently in use; no sub-range.' RETURN * See whether the range is set. ELSEIF(.NOT.SET(IREF1))THEN PRINT *,' !!!!!! HISCUT WARNING : Range not yet set;'// - ' no sub-range.' RETURN * Ensure that the range at least partially overlaps. ELSEIF(MAX(X0,X1).LT.XMIN(IREF1).OR. - MIN(X0,X1).GT.XMAX(IREF1))THEN PRINT *,' !!!!!! HISCUT WARNING : Sub-range does not'// - ' overlap with histogram range ; no sub-range.' RETURN * Warn if there is only a partial overlap. ELSEIF((XMIN(IREF1)-X0)*(X0-XMAX(IREF1)).LT.0.OR. - (XMIN(IREF1)-X1)*(X1-XMAX(IREF1)).LT.0)THEN PRINT *,' ------ HISCUT MESSAGE : Sub-range overlaps'// - ' only partially with histogram range.' ENDIF *** Compute the parameters of the new histogram. I0=1+INT(REAL(NCHA(IREF1))*(X0-XMIN(IREF1))/ - (XMAX(IREF1)-XMIN(IREF1))) I1=1+INT(REAL(NCHA(IREF1))*(X1-XMIN(IREF1))/ - (XMAX(IREF1)-XMIN(IREF1))) * Reorder if needed. IF(I1.LT.I0)THEN IAUX=I1 I1=I0 I0=I1 ENDIF * Verify boundaries. IF(I0.LT.1)I0=1 IF(I1.GT.NCHA(IREF1))I1=NCHA(IREF1) IF(I0.GT.NCHA(IREF1).OR.I1.LT.1)THEN PRINT *,' !!!!!! HISCUT WARNING : Sub-range does not'// - ' overlap with histogram range ; no sub-range.' RETURN ENDIF * Ensure that there is at least 1 bin left. IF(I0.GE.I1)THEN PRINT *,' !!!!!! HISCUT WARNING : Sub-range overlaps'// - ' with less than 1 bin with histogram ; no sub-range.' RETURN ENDIF * Range. XX0=XMIN(IREF1)+(I0-1)*(XMAX(IREF1)-XMIN(IREF1))/ - REAL(NCHA(IREF1)) XX1=XMIN(IREF1)+I1*(XMAX(IREF1)-XMIN(IREF1))/REAL(NCHA(IREF1)) *** Allocate a new histogram. CALL HISADM('ALLOCATE',IREF2,I1-I0+1,XX0,XX1,.FALSE.,IFAIL1) * Ensure that this has worked. IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! HISCUT WARNING : Unable to allocate'// - ' space for the sub-range histogram.' RETURN ENDIF *** Fill the new histogram. CONTEN(IREF2,0)=CONTEN(IREF1,0) CONTEN(IREF2,NCHA(IREF2)+1)=CONTEN(IREF1,NCHA(IREF1)+1) DO 10 I=1,NCHA(IREF1) IF(I.LT.I0)THEN CONTEN(IREF2,0)=CONTEN(IREF2,0)+CONTEN(IREF1,I) ELSEIF(I.GE.I0.AND.I.LE.I1)THEN CONTEN(IREF2,I-I0+1)=CONTEN(IREF1,I) ELSE CONTEN(IREF2,NCHA(IREF2)+1)=CONTEN(IREF2,NCHA(IREF2)+1)+ - CONTEN(IREF1,I) ENDIF 10 CONTINUE *** Copy entries and summing information. SX0(IREF2)=SX0(IREF1) SX1(IREF2)=SX1(IREF1) SX2(IREF2)=SX2(IREF1) NENTRY(IREF2)=NENTRY(IREF1) *** Seems to have worked. IFAIL=0 END +DECK,HISENT. SUBROUTINE HISENT(IREF,X,W) *----------------------------------------------------------------------- * HISENT - Routine storing entries in a histogram, taking care of the * range setting if requested. * (Last changed on 20/ 3/97.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,HISTDATA. +SEQ,PRINTPLOT. REAL AUX(MXCHA),X,AVER,SIGMA,W,STEP INTEGER I,IREF,IND,NBIN,NADD1,NADD2 *** Check reference number. IF(IREF.LE.0.OR.IREF.GT.MXHIST)THEN IF(LDEBUG)PRINT *,' ++++++ HISENT DEBUG : Entry ignored'// - ' because IREF=',IREF,' is not valid.' RETURN ENDIF *** Keep track of sum of entries and their squares. SX0(IREF)=SX0(IREF)+W SX1(IREF)=SX1(IREF)+W*X SX2(IREF)=SX2(IREF)+W*X**2 NENTRY(IREF)=NENTRY(IREF)+1 *** Histogram range has been set. IF(SET(IREF))THEN IND=1+INT(REAL(NCHA(IREF))*(X-XMIN(IREF))/ - (XMAX(IREF)-XMIN(IREF))) IF(IND.LT.0)THEN IND=0 ELSEIF(IND.GT.NCHA(IREF))THEN IND=NCHA(IREF)+1 ENDIF CONTEN(IREF,IND)=CONTEN(IREF,IND)+W *** Histogram range has not yet been set. ELSE ** Not yet enough entries to normalise. IF(NENTRY(IREF).LE.NCHA(IREF)/2)THEN CONTEN(IREF,2*NENTRY(IREF)-1)=X CONTEN(IREF,2*NENTRY(IREF))=W ** There are enough entries, but the total weight is near zero. ELSEIF(SX0(IREF).EQ.0)THEN PRINT *,' !!!!!! HISENT WARNING : Not yet able to'// - ' autoscale since the integrated weight is 0.' NENTRY(IREF)=0 SX0(IREF)=0 SX1(IREF)=0 SX2(IREF)=0 ** Normalise. ELSE * Compute average and width. AVER=REAL(SX1(IREF)/SX0(IREF)) SIGMA=REAL(SQRT(MAX(0.0D0,(SX2(IREF)-SX1(IREF)**2/ - SX0(IREF))/SX0(IREF)))) * If width is zero, then take either mean or arbitrarily 1. IF(SIGMA.LE.0)SIGMA=ABS(AVER) IF(SIGMA.LE.0)SIGMA=1 * Determine a reasonable range for the histogram. XMIN(IREF)=AVER-3*SIGMA XMAX(IREF)=AVER+3*SIGMA IF(HISLIN(IREF))THEN CALL ROUND(XMIN(IREF),XMAX(IREF),NCHA(IREF), - 'LARGER,COARSER,INTEGER',STEP) XMIN(IREF)=XMIN(IREF)-0.5 XMAX(IREF)=XMAX(IREF)-0.5 ELSE CALL ROUND(XMIN(IREF),XMAX(IREF),NCHA(IREF), - 'LARGER,COARSER',STEP) ENDIF IF(STEP.LE.0)STEP=1 NBIN=0.1+(XMAX(IREF)-XMIN(IREF))/STEP NADD1=(NBIN-NCHA(IREF))/2 NADD2=NBIN-NCHA(IREF)-NADD1 XMIN(IREF)=XMIN(IREF)+NADD1*STEP XMAX(IREF)=XMAX(IREF)-NADD2*STEP * Debugging output. IF(LDEBUG)PRINT *,' ++++++ HISENT DEBUG :'// - ' Range of histogram ',IREF,' has been set.' * Remember the range has been set. SET(IREF)=.TRUE. * Save the entries collected so far and reset the histogram. DO 10 I=1,NCHA(IREF) AUX(I)=CONTEN(IREF,I) CONTEN(IREF,I)=0.0 10 CONTINUE CONTEN(IREF,0)=0 CONTEN(IREF,NCHA(IREF)+1)=0 * Fill the histogram. DO 20 I=1,NCHA(IREF)/2-1,2 IND=1+INT(REAL(NCHA(IREF))*(AUX(I)-XMIN(IREF))/ - (XMAX(IREF)-XMIN(IREF))) IF(IND.LT.0)THEN IND=0 ELSEIF(IND.GT.NCHA(IREF))THEN IND=NCHA(IREF)+1 ENDIF CONTEN(IREF,IND)=CONTEN(IREF,IND)+AUX(I+1) 20 CONTINUE ENDIF ENDIF END +DECK,HISFEX. SUBROUTINE HISFEX(IREF,OPTION,PAR,ERR,NPAR,IFAIL) *----------------------------------------------------------------------- * HISFEX - Fits an exponential of a polynomial to a histogram. * (Last changed on 27/ 6/96.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,HISTDATA. +SEQ,PRINTPLOT. LOGICAL LSQRT,LPRINT,LPLOT CHARACTER*(*) OPTION REAL PAR(*),ERR(*), - X(MXCHA),Y(MXCHA),EY(MXCHA),XPL(MXLIST),YPL(MXLIST) DOUBLE PRECISION AA(MXFPAR),EA(MXFPAR),XX,YY INTEGER IFAIL,IFAIL1,NPAR *** Assume the fit will fail. IFAIL=1 *** Check reference number. IF(IREF.LE.0.OR.IREF.GT.MXHIST)THEN PRINT *,' !!!!!! HISFEX WARNING : Histogram reference'// - ' not valid; histogram not fitted.' RETURN *** No entries yet. ELSEIF(NENTRY(IREF).EQ.0.OR.SX0(IREF).EQ.0)THEN PRINT *,' !!!!!! HISFEX WARNING : Histogram has no'// - ' entries yet; histogram not fitted.' RETURN *** Range not yet set. ELSEIF(.NOT.SET(IREF))THEN PRINT *,' !!!!!! HISFEX WARNING : Range of this auto'// - 'range histogram not yet set; histogram not fitted.' RETURN ENDIF *** Decode the option string. LSQRT=.TRUE. LPRINT=.FALSE. LPLOT=.FALSE. IF(INDEX(OPTION,'NOPLOT').NE.0)THEN LPLOT=.FALSE. ELSEIF(INDEX(OPTION,'PLOT').NE.0)THEN LPLOT=.TRUE. ENDIF IF(INDEX(OPTION,'NOPRINT').NE.0)THEN LPRINT=.FALSE. ELSEIF(INDEX(OPTION,'PRINT').NE.0)THEN LPRINT=.TRUE. ENDIF IF(INDEX(OPTION,'EQUAL').NE.0)THEN LSQRT=.FALSE. ELSEIF(INDEX(OPTION,'POISSON').NE.0)THEN LSQRT=.TRUE. ENDIF *** Prepare the arrays. DO 10 I=1,NCHA(IREF) X(I)=XMIN(IREF)+(I-0.5)*(XMAX(IREF)-XMIN(IREF))/REAL(NCHA(IREF)) Y(I)=CONTEN(IREF,I) IF(LSQRT)THEN EY(I)=SQRT(Y(I)+1) ELSE EY(I)=1 ENDIF 10 CONTINUE *** Call the fitting routine. CALL EXPFIT(X,Y,EY,NCHA(IREF),LPRINT,AA,EA,NPAR,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! HISFEX WARNING : The exponential fit'// - ' failed.' RETURN ENDIF DO 15 I=1,NPAR PAR(I)=REAL(AA(I)) ERR(I)=REAL(EA(I)) 15 CONTINUE *** Make a plot of the fit, start plotting the frame. IF(LPLOT)THEN * Switch to logarithmic scale. CALL GRAOPT('LIN-X, LOG-Y') * Make the plot. CALL HISPLT(IREF,'Coordinate','Histogram',.TRUE.) * Plot the error bars. CALL GRATTS('FUNCTION-1','POLYLINE') IF(LSQRT)THEN DO 20 I=1,NCHA(IREF) XPL(1)=XMIN(IREF)+(I-0.5)*(XMAX(IREF)-XMIN(IREF))/ - REAL(NCHA(IREF)) YPL(1)=Y(I)+EY(I) XPL(2)=XPL(1) YPL(2)=Y(I)-EY(I) CALL GRLINE(2,XPL,YPL) 20 CONTINUE ENDIF * Prepare the plot vector. DO 30 I=1,MXLIST XPL(I)=XMIN(IREF)+REAL(I-1)*(XMAX(IREF)-XMIN(IREF))/ - REAL(MXLIST-1) XX=XPL(I) CALL EXPFUN(XX,AA,YY) YPL(I)=YY 30 CONTINUE * Set the attributes. CALL GRATTS('FUNCTION-2','POLYLINE') * Plot the line itself. CALL GRLINE(MXLIST,XPL,YPL) * Close the plot. CALL GRNEXT * Switch to normal mode. CALL GRAOPT('LIN-X, LIN-Y') * Register the plot. CALL GRALOG('Exponential fit to a histogram') ENDIF *** Seems to have worked. IFAIL=0 END +DECK,HISFPR. SUBROUTINE HISFPR(IREF,OPTION,FACT,OFF,SLOPE,THETA, - EFACT,EOFF,ESLOPE,ETHETA,IFAIL) *----------------------------------------------------------------------- * HISFPR - Fits a Polya distribution to a histogram. * (Last changed on 19/ 8/96.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,HISTDATA. +SEQ,PRINTPLOT. LOGICAL LSQRT,LAUTO,LSCALE,LPRINT,LPLOT CHARACTER*(*) OPTION REAL FACT,OFF,SLOPE,THETA,EFACT,EOFF,ESLOPE,ETHETA, - X(MXCHA),Y(MXCHA),EY(MXCHA),XPL(MXLIST),YPL(MXLIST) DOUBLE PRECISION AA(4),EA(4),XX,YY INTEGER IFAIL,IFAIL1 *** Assume the fit will fail. IFAIL=1 *** Check reference number. IF(IREF.LE.0.OR.IREF.GT.MXHIST)THEN PRINT *,' !!!!!! HISFPR WARNING : Histogram reference'// - ' not valid; histogram not fitted.' RETURN *** No entries yet. ELSEIF(NENTRY(IREF).EQ.0.OR.SX0(IREF).EQ.0)THEN PRINT *,' !!!!!! HISFPR WARNING : Histogram has no'// - ' entries yet; histogram not fitted.' RETURN *** Range not yet set. ELSEIF(.NOT.SET(IREF))THEN PRINT *,' !!!!!! HISFPR WARNING : Range of this auto'// - 'range histogram not yet set; histogram not fitted.' RETURN ENDIF *** Decode the option string. LSQRT=.TRUE. LPRINT=.FALSE. LPLOT=.FALSE. LAUTO=.TRUE. LSCALE=.TRUE. IF(INDEX(OPTION,'NOPLOT').NE.0)THEN LPLOT=.FALSE. ELSEIF(INDEX(OPTION,'PLOT').NE.0)THEN LPLOT=.TRUE. ENDIF IF(INDEX(OPTION,'NOPRINT').NE.0)THEN LPRINT=.FALSE. ELSEIF(INDEX(OPTION,'PRINT').NE.0)THEN LPRINT=.TRUE. ENDIF IF(INDEX(OPTION,'EQUAL').NE.0)THEN LSQRT=.FALSE. ELSEIF(INDEX(OPTION,'POISSON').NE.0)THEN LSQRT=.TRUE. ENDIF IF(INDEX(OPTION,'FIT').NE.0)THEN LSCALE=.TRUE. ELSEIF(INDEX(OPTION,'FIX').NE.0)THEN LSCALE=.FALSE. ENDIF IF(INDEX(OPTION,'AUTO').NE.0)THEN LAUTO=.TRUE. ELSEIF(INDEX(OPTION,'MANUAL').NE.0)THEN LAUTO=.FALSE. ENDIF *** Prepare the arrays. DO 10 I=1,NCHA(IREF) X(I)=XMIN(IREF)+(I-0.5)*(XMAX(IREF)-XMIN(IREF))/REAL(NCHA(IREF)) Y(I)=CONTEN(IREF,I) IF(LSQRT)THEN EY(I)=SQRT(Y(I)+1) ELSE EY(I)=1 ENDIF 10 CONTINUE *** Call the fitting routine. AA(1)=FACT AA(2)=THETA AA(3)=OFF AA(4)=SLOPE CALL PYAFIT(X,Y,EY,NCHA(IREF), - LPRINT,LSQRT,LSCALE,LAUTO,AA,EA,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! HISFPL WARNING : The Polya fit'// - ' failed.' RETURN ENDIF FACT=AA(1) THETA=AA(2) OFF=AA(3) SLOPE=AA(4) EFACT=EA(1) ETHETA=EA(2) EOFF=EA(3) ESLOPE=EA(4) *** Make a plot of the fit, start plotting the frame. IF(LPLOT)THEN * Switch to logarithmic scale. CALL GRAOPT('LIN-X, LOG-Y') * Make the plot. CALL HISPLT(IREF,'Coordinate','Histogram',.TRUE.) * Plot the error bars. CALL GRATTS('FUNCTION-1','POLYLINE') IF(LSQRT)THEN DO 20 I=1,NCHA(IREF) XPL(1)=XMIN(IREF)+(I-0.5)*(XMAX(IREF)-XMIN(IREF))/ - REAL(NCHA(IREF)) YPL(1)=Y(I)+EY(I) XPL(2)=XPL(1) YPL(2)=Y(I)-EY(I) CALL GRLINE(2,XPL,YPL) 20 CONTINUE ENDIF * Prepare the plot vector. DO 30 I=1,MXLIST XPL(I)=XMIN(IREF)+REAL(I-1)*(XMAX(IREF)-XMIN(IREF))/ - REAL(MXLIST-1) XX=XPL(I) CALL PYAFUN(XX,AA,YY) YPL(I)=YY 30 CONTINUE * Set the attributes. CALL GRATTS('FUNCTION-2','POLYLINE') * Plot the line itself. CALL GRLINE(MXLIST,XPL,YPL) * Close the plot. CALL GRNEXT * Switch to normal mode. CALL GRAOPT('LIN-X, LIN-Y') * Register the plot. CALL GRALOG('Polya fit to a histogram') ENDIF *** Seems to have worked. IFAIL=0 END +DECK,HISFNR. SUBROUTINE HISFNR(IREF,OPTION,FACT,AVER,SIGMA, - EFACT,EAVER,ESIGMA,IFAIL) *----------------------------------------------------------------------- * HISFNR - Fits a Gaussian to a histogram. * (Last changed on 29/10/95.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,HISTDATA. +SEQ,PRINTPLOT. LOGICAL LSQRT,LPRINT,LPLOT CHARACTER*(*) OPTION REAL FACT,AVER,SIGMA,EFACT,EAVER,ESIGMA, - X(MXCHA),Y(MXCHA),EY(MXCHA),XPL(MXLIST),YPL(MXLIST) DOUBLE PRECISION AA(3),EA(3),XX,YY INTEGER IFAIL,IFAIL1 *** Assume the fit will fail. IFAIL=1 *** Check reference number. IF(IREF.LE.0.OR.IREF.GT.MXHIST)THEN PRINT *,' !!!!!! HISFNR WARNING : Histogram reference'// - ' not valid; histogram not fitted.' RETURN *** No entries yet. ELSEIF(NENTRY(IREF).EQ.0.OR.SX0(IREF).EQ.0)THEN PRINT *,' !!!!!! HISFNR WARNING : Histogram has no'// - ' entries yet; histogram not fitted.' RETURN *** Range not yet set. ELSEIF(.NOT.SET(IREF))THEN PRINT *,' !!!!!! HISFNR WARNING : Range of this auto'// - 'range histogram not yet set; histogram not fitted.' RETURN ENDIF *** Decode the option string. LSQRT=.TRUE. LPRINT=.FALSE. LPLOT=.FALSE. IF(INDEX(OPTION,'NOPLOT').NE.0)THEN LPLOT=.FALSE. ELSEIF(INDEX(OPTION,'PLOT').NE.0)THEN LPLOT=.TRUE. ENDIF IF(INDEX(OPTION,'NOPRINT').NE.0)THEN LPRINT=.FALSE. ELSEIF(INDEX(OPTION,'PRINT').NE.0)THEN LPRINT=.TRUE. ENDIF IF(INDEX(OPTION,'EQUAL').NE.0)THEN LSQRT=.FALSE. ELSEIF(INDEX(OPTION,'POISSON').NE.0)THEN LSQRT=.TRUE. ENDIF *** Prepare the arrays. DO 10 I=1,NCHA(IREF) X(I)=XMIN(IREF)+(I-0.5)*(XMAX(IREF)-XMIN(IREF))/REAL(NCHA(IREF)) Y(I)=CONTEN(IREF,I) IF(LSQRT)THEN EY(I)=SQRT(Y(I)+1) ELSE EY(I)=1 ENDIF 10 CONTINUE *** Call the fitting routine. CALL NORFIT(X,Y,EY,NCHA(IREF),LPRINT,AA,EA,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! HISFNR WARNING : The Gaussian fit'// - ' failed.' RETURN ENDIF FACT=REAL(AA(1)) AVER=REAL(AA(2)) SIGMA=REAL(AA(3)) EFACT=REAL(EA(1)) EAVER=REAL(EA(2)) ESIGMA=REAL(EA(3)) *** Make a plot of the fit, start plotting the frame. IF(LPLOT)THEN CALL HISPLT(IREF,'Coordinate','Histogram',.TRUE.) * Plot the error bars. CALL GRATTS('FUNCTION-1','POLYLINE') IF(LSQRT)THEN DO 20 I=1,NCHA(IREF) XPL(1)=XMIN(IREF)+(I-0.5)*(XMAX(IREF)-XMIN(IREF))/ - REAL(NCHA(IREF)) YPL(1)=Y(I)+EY(I) XPL(2)=XPL(1) YPL(2)=Y(I)-EY(I) CALL GRLINE(2,XPL,YPL) 20 CONTINUE ENDIF * Prepare the plot vector. DO 30 I=1,MXLIST XPL(I)=XMIN(IREF)+REAL(I-1)*(XMAX(IREF)-XMIN(IREF))/ - REAL(MXLIST-1) XX=XPL(I) CALL NORFUN(XX,AA,YY) YPL(I)=YY 30 CONTINUE * Set the attributes. CALL GRATTS('FUNCTION-2','POLYLINE') * Plot the line itself. CALL GRLINE(MXLIST,XPL,YPL) * Close the plot. CALL GRNEXT * Register the plot. CALL GRALOG('Gaussian fit to a histogram.') ENDIF *** Seems to have worked. IFAIL=0 END +DECK,HISFPL. SUBROUTINE HISFPL(IREF,OPTION,PAR,ERR,NPAR,IFAIL) *----------------------------------------------------------------------- * HISFPL - Fits a polynomial to a histogram. * (Last changed on 12/ 6/96.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,HISTDATA. +SEQ,PRINTPLOT. LOGICAL LSQRT,LPRINT,LPLOT CHARACTER*(*) OPTION REAL PAR(*),ERR(*), - X(MXCHA),Y(MXCHA),EY(MXCHA),XPL(MXLIST),YPL(MXLIST) DOUBLE PRECISION AA(MXFPAR),EA(MXFPAR),XX,YY INTEGER IFAIL,IFAIL1,NPAR *** Assume the fit will fail. IFAIL=1 *** Check reference number. IF(IREF.LE.0.OR.IREF.GT.MXHIST)THEN PRINT *,' !!!!!! HISFPL WARNING : Histogram reference'// - ' not valid; histogram not fitted.' RETURN *** No entries yet. ELSEIF(NENTRY(IREF).EQ.0.OR.SX0(IREF).EQ.0)THEN PRINT *,' !!!!!! HISFPL WARNING : Histogram has no'// - ' entries yet; histogram not fitted.' RETURN *** Range not yet set. ELSEIF(.NOT.SET(IREF))THEN PRINT *,' !!!!!! HISFPL WARNING : Range of this auto'// - 'range histogram not yet set; histogram not fitted.' RETURN ENDIF *** Decode the option string. LSQRT=.TRUE. LPRINT=.FALSE. LPLOT=.FALSE. IF(INDEX(OPTION,'NOPLOT').NE.0)THEN LPLOT=.FALSE. ELSEIF(INDEX(OPTION,'PLOT').NE.0)THEN LPLOT=.TRUE. ENDIF IF(INDEX(OPTION,'NOPRINT').NE.0)THEN LPRINT=.FALSE. ELSEIF(INDEX(OPTION,'PRINT').NE.0)THEN LPRINT=.TRUE. ENDIF IF(INDEX(OPTION,'EQUAL').NE.0)THEN LSQRT=.FALSE. ELSEIF(INDEX(OPTION,'POISSON').NE.0)THEN LSQRT=.TRUE. ENDIF *** Prepare the arrays. DO 10 I=1,NCHA(IREF) X(I)=XMIN(IREF)+(I-0.5)*(XMAX(IREF)-XMIN(IREF))/REAL(NCHA(IREF)) Y(I)=CONTEN(IREF,I) IF(LSQRT)THEN EY(I)=SQRT(Y(I)+1) ELSE EY(I)=1 ENDIF 10 CONTINUE *** Call the fitting routine. CALL POLFIT(X,Y,EY,NCHA(IREF),LPRINT,AA,EA,NPAR,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! HISFPL WARNING : The polynomial fit'// - ' failed.' RETURN ENDIF DO 15 I=1,NPAR PAR(I)=REAL(AA(I)) ERR(I)=REAL(EA(I)) 15 CONTINUE *** Make a plot of the fit, start plotting the frame. IF(LPLOT)THEN CALL HISPLT(IREF,'Coordinate','Histogram',.TRUE.) * Plot the error bars. CALL GRATTS('FUNCTION-1','POLYLINE') IF(LSQRT)THEN DO 20 I=1,NCHA(IREF) XPL(1)=XMIN(IREF)+(I-0.5)*(XMAX(IREF)-XMIN(IREF))/ - REAL(NCHA(IREF)) YPL(1)=Y(I)+EY(I) XPL(2)=XPL(1) YPL(2)=Y(I)-EY(I) CALL GRLINE(2,XPL,YPL) 20 CONTINUE ENDIF * Prepare the plot vector. DO 30 I=1,MXLIST XPL(I)=XMIN(IREF)+REAL(I-1)*(XMAX(IREF)-XMIN(IREF))/ - REAL(MXLIST-1) XX=XPL(I) CALL POLFUN(XX,AA,YY) YPL(I)=YY 30 CONTINUE * Set the attributes. CALL GRATTS('FUNCTION-2','POLYLINE') * Plot the line itself. CALL GRLINE(MXLIST,XPL,YPL) * Close the plot. CALL GRNEXT * Register the plot. CALL GRALOG('Polynomial fit to a histogram.') ENDIF *** Seems to have worked. IFAIL=0 END +DECK,HISFFU. SUBROUTINE HISFFU(IREF,FUN,OPTION,IA,IE,NPAR,IFAIL) *----------------------------------------------------------------------- * HISFFU - Fits an arbitrary function to an histogram. * (Last changed on 19/ 2/97.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,HISTDATA. +SEQ,PRINTPLOT. +SEQ,GLOBALS. LOGICAL LSQRT,LPRINT,LPLOT CHARACTER*(*) OPTION,FUN REAL X(MXCHA),Y(MXCHA),EY(MXCHA),XPL(MXLIST),YPL(MXLIST) DOUBLE PRECISION AA(MXFPAR),XX,YY INTEGER IFAIL,IFAIL1,NPAR,NNA,IIA,IA(*),IE(*),IREF,I,IENTRY COMMON /FFUDAT/ NNA,IENTRY,IIA(MXVAR) *** Assume the fit will fail. IFAIL=1 *** Check reference number. IF(IREF.LE.0.OR.IREF.GT.MXHIST)THEN PRINT *,' !!!!!! HISFFU WARNING : Histogram reference'// - ' not valid; histogram not fitted.' RETURN *** No entries yet. ELSEIF(NENTRY(IREF).EQ.0.OR.SX0(IREF).EQ.0)THEN PRINT *,' !!!!!! HISFFU WARNING : Histogram has no'// - ' entries yet; histogram not fitted.' RETURN *** Range not yet set. ELSEIF(.NOT.SET(IREF))THEN PRINT *,' !!!!!! HISFFU WARNING : Range of this auto'// - 'range histogram not yet set; histogram not fitted.' RETURN ENDIF *** Decode the option string. LSQRT=.TRUE. LPRINT=.FALSE. LPLOT=.FALSE. IF(INDEX(OPTION,'NOPLOT').NE.0)THEN LPLOT=.FALSE. ELSEIF(INDEX(OPTION,'PLOT').NE.0)THEN LPLOT=.TRUE. ENDIF IF(INDEX(OPTION,'NOPRINT').NE.0)THEN LPRINT=.FALSE. ELSEIF(INDEX(OPTION,'PRINT').NE.0)THEN LPRINT=.TRUE. ENDIF IF(INDEX(OPTION,'EQUAL').NE.0)THEN LSQRT=.FALSE. ELSEIF(INDEX(OPTION,'POISSON').NE.0)THEN LSQRT=.TRUE. ENDIF *** Prepare the arrays. DO 10 I=1,NCHA(IREF) X(I)=XMIN(IREF)+(I-0.5)*(XMAX(IREF)-XMIN(IREF))/REAL(NCHA(IREF)) Y(I)=CONTEN(IREF,I) IF(LSQRT)THEN EY(I)=SQRT(Y(I)+1) ELSE EY(I)=1 ENDIF 10 CONTINUE *** Call the fitting routine. CALL FUNFIT(FUN,X,Y,EY,NCHA(IREF),LPRINT,IA,IE,NPAR,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! HISFFU WARNING : The fit to ',FUN, - ' failed.' CALL ALGCLR(IENTRY) RETURN ENDIF *** Make a plot of the fit, start plotting the frame. IF(LPLOT)THEN * Make the plot. CALL HISPLT(IREF,'Coordinate','Histogram',.TRUE.) * Plot the error bars. CALL GRATTS('FUNCTION-1','POLYLINE') IF(LSQRT)THEN DO 20 I=1,NCHA(IREF) XPL(1)=XMIN(IREF)+(I-0.5)*(XMAX(IREF)-XMIN(IREF))/ - REAL(NCHA(IREF)) YPL(1)=Y(I)+EY(I) XPL(2)=XPL(1) YPL(2)=Y(I)-EY(I) CALL GRLINE(2,XPL,YPL) 20 CONTINUE ENDIF * Prepare the parameter list. DO 40 I=1,NPAR AA(I)=GLBVAL(IIA(I)) 40 CONTINUE * Prepare the plot vector. DO 30 I=1,MXLIST XPL(I)=XMIN(IREF)+REAL(I-1)*(XMAX(IREF)-XMIN(IREF))/ - REAL(MXLIST-1) XX=XPL(I) CALL FUNFUN(XX,AA,YY) YPL(I)=YY 30 CONTINUE * Set the attributes. CALL GRATTS('FUNCTION-2','POLYLINE') * Plot the line itself. CALL GRLINE(MXLIST,XPL,YPL) * Close the plot. CALL GRNEXT * Register the plot. CALL GRALOG('Function fit to a histogram') ENDIF *** We're now done with the function, so can delete the entry point. CALL ALGCLR(IENTRY) *** Seems to have worked. IFAIL=0 END +DECK,HISFMS. SUBROUTINE HISFMS(IREF,OPTION,S,XC,FACT,K3,EXC,EFACT,EK3,IFAIL) *----------------------------------------------------------------------- * HISFMS - Fits a Mathieson distribution to an histogram. * (Last changed on 17/ 4/97.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,HISTDATA. +SEQ,PRINTPLOT. LOGICAL LSQRT,LPRINT,LPLOT,LFITK3 CHARACTER*(*) OPTION REAL S,FACT,XC,K3,EFACT,EXC,EK3,X(MXCHA),Y(MXCHA),EY(MXCHA), - XPL(MXLIST),YPL(MXLIST) DOUBLE PRECISION XX,YY,AA(6),EA(6) INTEGER IFAIL,IFAIL1,IREF,I *** Assume the fit will fail. IFAIL=1 *** Check reference number. IF(IREF.LE.0.OR.IREF.GT.MXHIST)THEN PRINT *,' !!!!!! HISFMS WARNING : Histogram reference'// - ' not valid; histogram not fitted.' RETURN *** No entries yet. ELSEIF(SX0(IREF).EQ.0)THEN PRINT *,' !!!!!! HISFMS WARNING : Histogram has no'// - ' entries yet; histogram not fitted.' RETURN *** Range not yet set. ELSEIF(.NOT.SET(IREF))THEN PRINT *,' !!!!!! HISFMS WARNING : Range of this auto'// - 'range histogram not yet set; histogram not fitted.' RETURN ENDIF *** Decode the option string. LSQRT=.FALSE. LPRINT=.FALSE. LPLOT=.FALSE. LFITK3=.TRUE. IF(INDEX(OPTION,'NOPLOT').NE.0)THEN LPLOT=.FALSE. ELSEIF(INDEX(OPTION,'PLOT').NE.0)THEN LPLOT=.TRUE. ENDIF IF(INDEX(OPTION,'NOPRINT').NE.0)THEN LPRINT=.FALSE. ELSEIF(INDEX(OPTION,'PRINT').NE.0)THEN LPRINT=.TRUE. ENDIF IF(INDEX(OPTION,'EQUAL').NE.0)THEN LSQRT=.FALSE. ELSEIF(INDEX(OPTION,'POISSON').NE.0)THEN LSQRT=.TRUE. ENDIF IF(INDEX(OPTION,'NOFITK3').NE.0)THEN LFITK3=.FALSE. ELSEIF(INDEX(OPTION,'FITK3').NE.0)THEN LFITK3=.TRUE. ENDIF *** Prepare the arrays. DO 10 I=1,NCHA(IREF) X(I)=XMIN(IREF)+(I-0.5)*(XMAX(IREF)-XMIN(IREF))/REAL(NCHA(IREF)) Y(I)=CONTEN(IREF,I) IF(LSQRT)THEN EY(I)=SQRT(Y(I)+1) ELSE EY(I)=1 ENDIF 10 CONTINUE *** Transfer the parameters that can be used for initialisation. AA(1)=XC AA(2)=FACT AA(3)=K3 AA(6)=S *** Call the fitting routine. CALL MSNFIT(X,Y,EY,NCHA(IREF),LPRINT,LFITK3,AA,EA,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! HISFMS WARNING : The Mathieson fit'// - ' failed.' RETURN ENDIF *** Transfer the parameters back. XC=AA(1) EXC=EA(1) FACT=AA(2) EFACT=EA(2) K3=AA(3) EK3=EA(3) *** Make a plot of the fit, start plotting the frame. IF(LPLOT)THEN CALL HISPLT(IREF,'Coordinate','Histogram',.TRUE.) * Plot the error bars. CALL GRATTS('FUNCTION-1','POLYLINE') IF(LSQRT)THEN DO 20 I=1,NCHA(IREF) XPL(1)=XMIN(IREF)+(I-0.5)*(XMAX(IREF)-XMIN(IREF))/ - REAL(NCHA(IREF)) YPL(1)=Y(I)+EY(I) XPL(2)=XPL(1) YPL(2)=Y(I)-EY(I) CALL GRLINE(2,XPL,YPL) 20 CONTINUE ENDIF * Prepare the plot vector. DO 30 I=1,NCHA(IREF) XPL(I)=XMIN(IREF)+(I-0.5)*(XMAX(IREF)-XMIN(IREF))/ - REAL(NCHA(IREF)) XX=XPL(I) CALL MSNFUN(XX,AA,YY) YPL(I)=YY 30 CONTINUE * Set the attributes. CALL GRATTS('FUNCTION-2','POLYMARKER') * Plot the line itself. CALL GRMARK(NCHA(IREF),XPL,YPL) * Close the plot. CALL GRNEXT * Register the plot. CALL GRALOG('Mathieson fit to a histogram.') ENDIF *** Seems to have worked. IFAIL=0 END +DECK,HISGET. SUBROUTINE HISGET(IREF,FILE,MEMB,IFAIL) *----------------------------------------------------------------------- * HISGET - This routine reads an histogram from a file. * VARIABLES : STRING : Character string that should contain a * description of the dataset being read. * (Last changed on 20/ 3/97.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,HISTDATA. +SEQ,PRINTPLOT. CHARACTER*(MXINCH) STRING CHARACTER*(*) FILE,MEMB CHARACTER*8 MEMBER CHARACTER*1 DUMMY LOGICAL DSNCMP,EXIS EXTERNAL DSNCMP *** Identify the routine, if requested. IF(LIDENT)PRINT *,' /// ROUTINE HISGET ///' *** Initialise IFAIL on 1 (i.e. fail). IFAIL=1 *** Transfer variables. MEMBER=MEMB *** Initialise IREF so that HISADM always gets a valid argument. IREF=-1 *** Open the dataset and inform DSNLOG. CALL DSNOPN(FILE,LEN(FILE),12,'READ-LIBRARY',IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! HISGET WARNING : Opening ',FILE, - ' failed ; histogram not read.' IFAIL=1 RETURN ENDIF CALL DSNLOG(FILE,'Histogram ','Sequential','Read only ') IF(LDEBUG)PRINT *,' ++++++ HISGET DEBUG : Dataset ', - FILE,' opened on unit 12 for seq read.' * Locate the pointer on the header of the requested member. CALL DSNLOC(MEMBER,LEN(MEMBER),'HIST ',12,EXIS,'RESPECT') IF(.NOT.EXIS)THEN CALL DSNLOC(MEMBER,LEN(MEMBER),'HIST ',12,EXIS,'IGNORE') IF(EXIS)THEN PRINT *,' ###### HISGET ERROR : Histogram ',MEMBER, - ' has been deleted from ',FILE,'; not read.' ELSE PRINT *,' ###### HISGET ERROR : Histogram ',MEMBER, - ' not found on ',FILE,'.' ENDIF CLOSE(UNIT=12,IOSTAT=IOS,ERR=2030) IFAIL=1 RETURN ENDIF *** Check that the member is acceptable. READ(12,'(A80)',END=2000,IOSTAT=IOS,ERR=2010) STRING IF(DSNCMP('20- 3-97',STRING(11:18)))THEN PRINT *,' !!!!!! HISGET WARNING : Member ',STRING(32:39), - ' can not be read because of a change in format.' CLOSE(UNIT=12,IOSTAT=IOS,ERR=2030) IFAIL=1 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) *** Find a free histogram. CALL HISADM('ALLOCATE',IREF,1,0.0,0.0,.TRUE.,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! HISGET WARNING : Unable to obtain space'// - ' to store the histogram to be read; not read.' IFAIL=1 CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) RETURN ENDIF *** Execute read operations if a valid name is available. READ(12,'(/12X,E15.8/12X,E15.8/12X,I10/12X,L1/12X,L1/ - 12X,3E15.8/12X,I10)',IOSTAT=IOS,ERR=2010,END=2000) - XMIN(IREF),XMAX(IREF),NCHA(IREF),SET(IREF),HISLIN(IREF), - SX0(IREF),SX1(IREF),SX2(IREF),NENTRY(IREF) READ(12,'(A1)',IOSTAT=IOS,ERR=2010,END=2000) DUMMY DO 210 I=0,NCHA(IREF)+1 READ(12,'(10X,E15.8)',IOSTAT=IOS,ERR=2010,END=2000) - CONTEN(IREF,I) 210 CONTINUE * Close the file after the operation. CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) *** Register the amount of CPU time used for reading. CALL TIMLOG('Reading an histogram from a dataset: ') *** Things worked, reset the error flag. IFAIL=0 RETURN *** Handle the I/O error conditions. 2000 CONTINUE PRINT *,' ###### HISGET ERROR : EOF encountered while', - ' reading ',FILE,' from unit 12 ; no histogram read.' CALL INPIOS(IOS) IF(IREF.NE.-1)CALL HISADM('DELETE',IREF,1,0.0,0.0,.TRUE.,IFAIL1) CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) RETURN 2010 CONTINUE PRINT *,' ###### HISGET ERROR : Error while reading ', - FILE,' from unit 12 ; no histogram read.' CALL INPIOS(IOS) IF(IREF.NE.-1)CALL HISADM('DELETE',IREF,1,0.0,0.0,.TRUE.,IFAIL1) CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) RETURN 2030 CONTINUE PRINT *,' ###### HISGET ERROR : Dataset ',FILE, - ' on unit 12 cannot be closed ; results not predictable.' CALL INPIOS(IOS) END +DECK,HISINT. SUBROUTINE HISINT *----------------------------------------------------------------------- * HISINT - Initialises the histogram system. * (Last changed on 9/10/93.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. +SEQ,HISTDATA. DO 10 I=1,MXHIST DO 20 J=0,MXCHA+1 CONTEN(I,J)=0.0 20 CONTINUE HISUSE(I)=.FALSE. HISLIN(I)=.FALSE. XMIN(I)=0.0 XMAX(I)=1.0 NCHA(I)=0 SET(I)=.FALSE. SX0(I)=0.0D0 SX1(I)=0.0D0 SX2(I)=0.0D0 NENTRY(I)=0 10 CONTINUE END +DECK,HISINV. SUBROUTINE HISINV(IREF,EPS,XEPS,IORDER,IFAIL) *----------------------------------------------------------------------- * HISINV - Inverse interpolation to find XEPS such that P(X 0).'')') RETURN *** Straight dump for auto range histogram without set range. ELSEIF(.NOT.SET(IREF))THEN WRITE(LUNOUT,'(''1''/'' Title: '',A/'' Axis: '',A//, - '' This is an auto-range histogram for which the'', - '' range has not yet been set.''// - '' Entry Value'')') - TITLE,XTXT SUM0=0.0 SUM1=0.0 SUM2=0.0 DO 10 I=1,NENTRY(IREF) CALL OUTFMT(CONTEN(IREF,I),2,AUX1,NCAUX1,'RIGHT') WRITE(LUNOUT,'(2X,I5,2X,A15)') I,AUX1 SUM1=SUM1+CONTEN(IREF,I) 10 CONTINUE ELSE *** Determine maximum and minimum. HISMIN=CONTEN(IREF,1) HISMAX=CONTEN(IREF,1) DO 20 I=2,NCHA(IREF) HISMIN=MIN(HISMIN,CONTEN(IREF,I)) HISMAX=MAX(HISMAX,CONTEN(IREF,I)) 20 CONTINUE *** Set the scale of the printing axes. IF(HISMAX.LE.HISMIN)THEN DIV=0.0 ELSE DIV=LEN(LINE)/(HISMAX-HISMIN) ENDIF *** Print the header for the histogram. WRITE(LUNOUT,'(''1''/'' Title: '',A/ - '' Axis: '',A/'' Reference: '',I4// - '' Bin Bin centre Contents'', - '' Histogram''/)') TITLE,XTXT,IREF *** Print the histogram. SUM0=CONTEN(IREF,0) SUM1=0.0 SUM2=CONTEN(IREF,NCHA(IREF)+1) DO 30 I=1,NCHA(IREF) LINE='*****************************************'// - '*****************************************' IND=NINT(DIV*(CONTEN(IREF,I)-HISMIN)) IND=MIN(LEN(LINE),MAX(1,IND)) LINE(IND:)=' ' CALL OUTFMT(XMIN(IREF)+(I-0.5)*(XMAX(IREF)-XMIN(IREF))/ - REAL(NCHA(IREF)),2,AUX1,NCAUX1,'RIGHT') CALL OUTFMT(CONTEN(IREF,I),2,AUX2,NCAUX2,'RIGHT') WRITE(LUNOUT,'(2X,I3,2X,A15,2X,A15,2X,A)') - I,AUX1,AUX2,LINE(1:MAX(1,IND-1)) SUM1=SUM1+CONTEN(IREF,I) 30 CONTINUE SUM0=SUM0*(XMAX(IREF)-XMIN(IREF))/REAL(NCHA(IREF)) SUM1=SUM1*(XMAX(IREF)-XMIN(IREF))/REAL(NCHA(IREF)) SUM2=SUM2*(XMAX(IREF)-XMIN(IREF))/REAL(NCHA(IREF)) ENDIF *** Print histogram statistics. WRITE(LUNOUT,'(/'' STATISTICS:''// - '' Entries : '',I8,'' (including under and overflow),''// - '' Underflow : '',E15.8, - '' (coordinates below '',E15.8,''),''/ - '' Contents : '',E15.8/ - '' Overflow : '',E15.8, - '' (coordinates above '',E15.8,''),''// - '' Average : '',E15.8/ - '' RMS : '',E15.8/)') - NENTRY(IREF),SUM0,XMIN(IREF),SUM1,SUM2,XMAX(IREF), - SX1(IREF)/SX0(IREF), - SQRT((SX2(IREF)-SX1(IREF)**2/SX0(IREF))/SX0(IREF)) END +DECK,HISPLT. SUBROUTINE HISPLT(IREF,XTXT,TITLE,FRAME) *----------------------------------------------------------------------- * HISPLT - Plots a histogram via GRHIST. * (Last changed on 17/ 5/99.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,HISTDATA. +SEQ,PRINTPLOT. CHARACTER*(*) XTXT,TITLE CHARACTER*20 AUX1,AUX2,AUX3 REAL AUX(0:MXCHA+1) INTEGER IREF,I,NC1,NC2,NC3 LOGICAL FRAME *** Check reference number and scale setting. IF(IREF.LE.0.OR.IREF.GT.MXHIST)THEN PRINT *,' !!!!!! HISPLT WARNING : Histogram reference'// - ' not valid; plotting empty box.' IF(FRAME)CALL GRCART(-1.0,-1.0,1.0,1.0,' ',' ', - 'Invalid histogram reference') RETURN ENDIF IF(.NOT.SET(IREF))THEN PRINT *,' !!!!!! HISPLT WARNING : The scale of this'// - ' auto-range histogram is not yet set; no plot.' IF(FRAME)CALL GRCART(-1.0,-1.0,1.0,1.0,' ',' ', - 'Range not yet set') RETURN ENDIF *** Call GRHIST. DO 10 I=0,MXCHA+1 AUX(I)=CONTEN(IREF,I) 10 CONTINUE CALL GRHIST(AUX,NCHA(IREF),XMIN(IREF),XMAX(IREF),XTXT,TITLE, - FRAME) *** Show contents, mean and RMS. IF(FRAME)THEN IF(SX0(IREF).EQ.0)THEN CALL GRCOMM(4,'Sum: 0, Mean and RMS undefined.') ELSE CALL OUTFMT(REAL(SX0(IREF)),2,AUX1,NC1,'LEFT') CALL OUTFMT(REAL(SX1(IREF)/SX0(IREF)), - 2,AUX2,NC2,'LEFT') CALL OUTFMT(REAL(SQRT(MAX(0.0D0, - (SX2(IREF)-SX1(IREF)**2/SX0(IREF))/SX0(IREF)))),2, - AUX3,NC3,'LEFT') CALL GRCOMM(4,'Sum: '//AUX1(1:NC1)//', Mean: '// - AUX2(1:NC2)//', RMS: '//AUX3(1:NC3)) ENDIF ENDIF END +DECK,HISREB. SUBROUTINE HISREB(IREF1,NGROUP,IREF2,IFAIL) *----------------------------------------------------------------------- * HISREB - Rebins a histogram. * (Last changed on 12/ 9/99.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,HISTDATA. +SEQ,PRINTPLOT. +SEQ,GLOBALS. INTEGER IREF1,IREF2,IFAIL,IFAIL1,NGROUP,I,II,NBIN REAL X0,X1 *** Assume this will fail. IFAIL=1 *** Check reference number. IF(IREF1.LE.0.OR.IREF1.GT.MXHIST)THEN PRINT *,' !!!!!! HISREB WARNING : Invalid histogram'// - ' reference; no rebinning.' RETURN * See whether the histogram is in use. ELSEIF(.NOT.HISUSE(IREF1))THEN PRINT *,' !!!!!! HISREB WARNING : Histogram is not'// - ' currently in use; no rebinning.' RETURN * See whether the range is set. ELSEIF(.NOT.SET(IREF1))THEN PRINT *,' !!!!!! HISREB WARNING : Range not yet set;'// - ' no rebinning.' RETURN * Make sure that the grouping makes sense. ELSEIF(NGROUP.LE.1.OR.NGROUP.GT.NCHA(IREF1))THEN PRINT *,' !!!!!! HISREB WARNING : Number of bins to'// - ' be grouped out of range; no rebinning.' RETURN ELSEIF(NCHA(IREF1).NE.NGROUP*(NCHA(IREF1)/NGROUP))THEN PRINT *,' ------ HISREB MESSAGE : Grouping does not'// - ' divide number of bins; binned data will be lost.' ENDIF *** Compute the parameters of the new histogram. NBIN=NCHA(IREF1)/NGROUP X0=XMIN(IREF1) X1=X0+NBIN*NGROUP*(XMAX(IREF1)-XMIN(IREF1))/REAL(NCHA(IREF1)) *** Allocate a new histogram. CALL HISADM('ALLOCATE',IREF2,NBIN,X0,X1,.FALSE.,IFAIL1) * Ensure that this has worked. IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! HISREB WARNING : Unable to allocate'// - ' space for the rebinned histogram.' RETURN ENDIF *** Fill the new histogram. CONTEN(IREF2,0)=CONTEN(IREF1,0) CONTEN(IREF2,NCHA(IREF2)+1)=CONTEN(IREF1,NCHA(IREF1)+1) DO 10 I=1,NCHA(IREF1) II=1+(I-1)/NGROUP IF(II.LE.NBIN)THEN CONTEN(IREF2,II)=CONTEN(IREF2,II)+CONTEN(IREF1,I) ELSE CONTEN(IREF2,NCHA(IREF2)+1)=CONTEN(IREF1,NCHA(IREF1)+1)+ - CONTEN(IREF1,I) ENDIF 10 CONTINUE *** Copy entries and summing information. SX0(IREF2)=SX0(IREF1) SX1(IREF2)=SX1(IREF1) SX2(IREF2)=SX2(IREF1) NENTRY(IREF2)=NENTRY(IREF1) *** Seems to have worked. IFAIL=0 END +DECK,HISRES. SUBROUTINE HISRES(IREF,IFAIL) *----------------------------------------------------------------------- * HISRES - Resets the contents of a histogram to 0. * (Last changed on 13/11/99.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,HISTDATA. +SEQ,PRINTPLOT. +SEQ,GLOBALS. INTEGER IREF,IFAIL,I *** Assume this will fail. IFAIL=1 *** Check reference number. IF(IREF.LE.0.OR.IREF.GT.MXHIST)THEN PRINT *,' !!!!!! HISRES WARNING : Invalid histogram'// - ' reference; not reset.' RETURN * See whether the histogram is in use. ELSEIF(.NOT.HISUSE(IREF))THEN PRINT *,' !!!!!! HISRES WARNING : Histogram is not'// - ' currently in use; not reset.' RETURN ENDIF *** Reset the contents. DO 10 I=0,MXCHA+1 CONTEN(IREF,I)=0.0 10 CONTINUE SX0(IREF)=0.0D0 SX1(IREF)=0.0D0 SX2(IREF)=0.0D0 NENTRY(IREF)=0 *** Seems to have worked. IFAIL=0 END +DECK,HISRZO,IF=HIGZ. SUBROUTINE HISRZO(IREF,FILE,TITLE,IFAIL) *----------------------------------------------------------------------- * HISRZO - Writes an histogram to an RZ file. *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,HISTDATA. LOGICAL EXIST INTEGER LREC,ISTAT,IFAIL,IREF,ICYCLE,I REAL AUX(MXCHA) CHARACTER*(*) FILE,TITLE CHARACTER*10 CHOPT *** Assume the call will work. IFAIL=0 *** Check reference number and scale setting. IF(IREF.LE.0.OR.IREF.GT.MXHIST)THEN PRINT *,' !!!!!! HISRZO WARNING : Histogram reference'// - ' not valid; histogram not written.' IFAIL=1 RETURN ENDIF IF(.NOT.SET(IREF))THEN PRINT *,' !!!!!! HISRZO WARNING : The scale of this'// - ' auto-range histogram is not yet set; not written.' IFAIL=1 RETURN ENDIF *** Book the histogram. CALL HBOOK1(IREF,TITLE,NCHA(IREF),XMIN(IREF),XMAX(IREF),0.0) *** Copy the histogram to HBOOK. DO 10 I=1,NCHA(IREF) AUX(I)=CONTEN(IREF,I) 10 CONTINUE CALL HPAK(IREF,AUX) *** Open the RZ file. INQUIRE(FILE=FILE,EXIST=EXIST) IF(EXIST)THEN CHOPT='U' ELSE CHOPT='N' ENDIF LREC=1024 CALL HROPEN(12,'Garfield',FILE,CHOPT,LREC,ISTAT) IF(ISTAT.NE.0)THEN PRINT *,' !!!!!! HISRZO WARNING : Error while opening'// - ' the RZ file.' IFAIL=1 RETURN ENDIF *** Write the histogram. ICYCLE=0 CALL HROUT(IREF,ICYCLE,' ') PRINT *,' ------ HISRZO MESSAGE : Histogram written to ',FILE, - ' with identifier ',IREF,', cycle ',ICYCLE,'.' *** Close the file. CALL HREND('Garfield') CLOSE(UNIT=12,STATUS='KEEP') *** Delete the histogram from memory. CALL HDELET(IREF) END +DECK,HISSAV. SUBROUTINE HISSAV(IREF,NAME,IFAIL) *----------------------------------------------------------------------- * HISSAV - Assigns a histogram to a global variable. * (Last changed on 5/ 9/95.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,HISTDATA. +SEQ,GLOBALS. +SEQ,PRINTPLOT. CHARACTER*(*) NAME INTEGER IREF,IFAIL *** Initial failure flag setting. IFAIL=1 *** Check reference number. IF(IREF.LE.0.OR.IREF.GT.MXHIST)THEN PRINT *,' !!!!!! HISSAV WARNING : Histogram reference'// - ' not valid; not saved.' RETURN ENDIF IF(.NOT.HISUSE(IREF))THEN PRINT *,' !!!!!! HISSAV WARNING : Histogram to be'// - ' saved does not exist; not saved.' IFAIL=1 RETURN ENDIF *** 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 *,' !!!!!! HISSAV WARNING : No global variable'// - ' space left for ',NAME,'; histogram not saved.' RETURN ENDIF *** Otherwise re-use an existing global. ELSE CALL ALGREU(NINT(GLBVAL(JVAR)),GLBMOD(JVAR),0) ENDIF *** Assign the histogram to the global. GLBVAL(JVAR)=IREF GLBMOD(JVAR)=4 *** Things seem to have worked. IFAIL=0 END +DECK,HISSCL. SUBROUTINE HISSCL(IREF,SCALE) *----------------------------------------------------------------------- * HISSCL - Scales an histogram by some factor. * (Last changed on 4/ 8/90.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,HISTDATA. +SEQ,PRINTPLOT. *** Check reference number and scale setting. IF(IREF.LE.0.OR.IREF.GT.MXHIST)THEN PRINT *,' !!!!!! HISSCL WARNING : Histogram reference'// - ' not valid; no histogram scaled.' RETURN ENDIF IF(.NOT.SET(IREF))THEN PRINT *,' !!!!!! HISSCL WARNING : The range of this'// - ' auto-range histogram is not yet set; no scaling.' RETURN ENDIF *** Multiply the histogram by some factor. DO 10 I=0,MXCHA+1 CONTEN(IREF,I)=CONTEN(IREF,I)*SCALE 10 CONTINUE END +DECK,HISWRT. SUBROUTINE HISWRT(IREF,FILE,MEMB,REM,IFAIL) *----------------------------------------------------------------------- * HISWRT - This routine writes a histogram to a dataset. * VARIABLES : * (Last changed on 30/ 8/97.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,HISTDATA. +SEQ,PRINTPLOT. CHARACTER*(MXINCH) STRING CHARACTER*(*) FILE,MEMB,REM CHARACTER*29 REMARK CHARACTER*8 TIME,DATE,MEMBER LOGICAL EXMEMB *** Identify the routine. IF(LIDENT)PRINT *,' /// ROUTINE HISWRT ///' *** Preset IFAIL to 1: failure. IFAIL=1 *** Transfer variables. REMARK=REM MEMBER=MEMB *** Print some debugging output if requested. IF(LDEBUG)PRINT *,' ++++++ HISWRT DEBUG : Ref=',IREF, - ', File=',FILE,', member=',MEMBER,', Remark=',REMARK,'.' *** Check whether the member already exists. CALL DSNREM(FILE,MEMB,'HIST',EXMEMB) IF(JEXMEM.EQ.2.AND.EXMEMB)THEN PRINT *,' ------ HISWRT MESSAGE : A copy of the member'// - ' exists; new member will be appended.' ELSEIF(JEXMEM.EQ.3.AND.EXMEMB)THEN PRINT *,' !!!!!! HISWRT WARNING : A copy of the member'// - ' exists already; member will not be written.' RETURN ENDIF *** Verify the histogram reference. IF(IREF.LE.0.OR.IREF.GT.MXHIST)THEN PRINT *,' !!!!!! HISWRT WARNING : Invalid histogram'// - ' reference received; histogram not written.' IFAIL=1 RETURN ENDIF IF(.NOT.HISUSE(IREF))THEN PRINT *,' !!!!!! HISWRT WARNING : Histogram to be'// - ' written does not exist; histogram not written.' IFAIL=1 RETURN ENDIF *** Open the dataset for sequential write and inform DSNLOG. CALL DSNOPN(FILE,LEN(FILE),12,'WRITE-LIBRARY',IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! HISWRT WARNING : Opening ',FILE, - ' failed ; histogram will not be written.' IFAIL=1 RETURN ENDIF CALL DSNLOG(FILE,'Histogram ','Sequential','Write ') IF(LDEBUG)PRINT *,' ++++++ HISWRT DEBUG : Dataset ', - FILE,' 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,'' HIST '', - 1X,''"'',A29,''"'')') DATE,TIME,MEMBER,REMARK WRITE(12,'(A80)',IOSTAT=IOS,ERR=2010) STRING * Write the histogram. WRITE(12,'('' HISTOGRAM INFORMATION:'')',IOSTAT=IOS,ERR=2010) WRITE(12,'('' Minimum: '',E15.8/'' Maximum: '',E15.8/ - '' Bins: '',I10/'' Range set: '',L1/ - '' Integer: '',L1)',IOSTAT=IOS,ERR=2010) XMIN(IREF), - XMAX(IREF),NCHA(IREF),SET(IREF),HISLIN(IREF) WRITE(12,'('' Sums: '',3E15.8/'' Entries: '',I10)', - IOSTAT=IOS,ERR=2010) SX0(IREF),SX1(IREF),SX2(IREF), - NENTRY(IREF) WRITE(12,'('' CONTENTS'')',IOSTAT=IOS,ERR=2010) DO 210 I=0,NCHA(IREF)+1 WRITE(12,'(I10,E15.8)',IOSTAT=IOS,ERR=2010) I,CONTEN(IREF,I) 210 CONTINUE * Close the file after the operation. CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) CALL TIMLOG('Writing an histogram to a dataset: ') *** Things worked, reset error flag. IFAIL=0 RETURN *** Handle the error conditions. 2010 CONTINUE PRINT *,' ###### HISWRT ERROR : Error while writing'// - ' to ',FILE,' via unit 12 ; histogram not written.' CALL INPIOS(IOS) CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) RETURN 2030 CONTINUE PRINT *,' ###### HISWRT ERROR : Dataset ',FILE, - ' unit 12 cannot be closed ; results not predictable' CALL INPIOS(IOS) END +PATCH,MATRIX. +DECK,MATADJ. SUBROUTINE MATADJ(IREF,NDIM,ISIZ,PAD,IFAIL) *----------------------------------------------------------------------- * MATADJ - Changes the dimensions of a matrix, keeping shape. * Variables: IREF : Reference of matrix * ISIZ : Dimension sizes * PAD : Value for new elements in matrix * (Last changed on 12/ 4/96.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,MATDATA. +SEQ,PRINTPLOT. INTEGER IREF,IMOD,NDIM,ISIZ(*),IFAIL,ISLOT,ISLOTN,IA(MXMDIM), - MATADR,MATSLT,IADDR,IADDRN REAL PAD EXTERNAL MATADR,MATSLT *** Identify the routine if requested. IF(LIDENT)PRINT *,' /// ROUTINE MATADJ ///' *** Initial value of the failure flag. IFAIL=1 *** Locate the current matrix. ISLOT=MATSLT(IREF) IF(ISLOT.LE.0)THEN PRINT *,' !!!!!! MATADJ WARNING : Matrix to be re-sized'// - ' has not been found.' RETURN ENDIF *** Check array dimensions. IF(NDIM.NE.MDIM(ISLOT))THEN PRINT *,' !!!!!! MATADJ WARNING : Existing matrix has a'// - ' different number of dimensions; not adjusted.' RETURN ENDIF *** Allocate space for the new matrix. IMOD=MMOD(ISLOT) CALL MATADM('ALLOCATE',IREFN,NDIM,ISIZ,IMOD,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! MATADJ WARNING : Unable to allocate'// - ' space for the re-sized matrix ; not re-sized.' RETURN ENDIF *** Re-locate the current matrix. ISLOT=MATSLT(IREF) IF(ISLOT.LE.0)THEN PRINT *,' !!!!!! MATADJ WARNING : Matrix to be re-sized'// - ' has not been found.' RETURN ENDIF *** Find where the new matrix sits. ISLOTN=MATSLT(IREFN) IF(ISLOTN.LE.0)THEN PRINT *,' !!!!!! MATADJ WARNING : New matrix not found;'// - ' program bug - please report.' RETURN ENDIF *** Initialise the new matrix. DO 50 I=1,MLEN(ISLOTN) MVEC(MORG(ISLOTN)+I)=PAD 50 CONTINUE *** Initial address vector. DO 60 I=1,MDIM(ISLOT) IA(I)=1 60 CONTINUE * Return here for the next element. 70 CONTINUE * Compute addresses in old and new matrix. IADDR=MATADR(ISLOT,IA) IADDRN=MATADR(ISLOTN,IA) * Assign. IF(IADDR.GT.0.AND.IADDRN.GT.0)MVEC(IADDRN)=MVEC(IADDR) * Increment the address vector. DO 80 I=1,MDIM(ISLOT) IF(IA(I).LT.MSIZ(ISLOT,I))THEN IA(I)=IA(I)+1 DO 90 J=1,I-1 IA(J)=1 90 CONTINUE GOTO 70 ENDIF 80 CONTINUE *** Modify the pointer information. MREF(ISLOTN)=MREF(ISLOT) *** Delete the old matrix. MREF(ISLOT)=0 *** Things seem to have worked. IFAIL=0 END +DECK,MATADM. SUBROUTINE MATADM(ACTION,IREF,NDIM,IDIM,IMOD,IFAIL) *----------------------------------------------------------------------- * MATADM - Takes care of matrix booking. * (Last changed on 24/10/95.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,MATDATA. +SEQ,GLOBALS. +SEQ,PRINTPLOT. CHARACTER*(*) ACTION CHARACTER*78 STRING CHARACTER*20 STRAUX CHARACTER*10 TYPE,NAME INTEGER IREF,NDIM,IDIM(*),IMOD,IFAIL,NLEN,ISLOT,ILAST,ISTART, - IFREE,NFREE,INEW,IORG,NUSED,I,J,NC,NCAUX *** Allocate a new matrix. IF(ACTION.EQ.'ALLOCATE')THEN ** Assign a provision reference in case of error. IREF=0 ** Set a provisional error flag. IFAIL=1 ** Check the number of dimensions. IF(NDIM.GT.MXMDIM)THEN PRINT *,' !!!!!! MATADM WARNING : Matrix has more'// - ' than MXMDIM dimensions; matrix not booked.' RETURN ENDIF ** See how large the new matrix is. NLEN=1 DO 10 I=1,NDIM IF(IDIM(I).LE.0)THEN PRINT *,' !!!!!! MATADM WARNING : Dimension ',I,' of', - ' the matrix is non-positive; matrix not booked.' RETURN ENDIF NLEN=NLEN*IDIM(I) 10 CONTINUE ** Debugging output. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MATADM DEBUG :'', - '' Booking matrix, length '',I5,'', dimension '',I5, - '', mode '',I1,''.'')') NLEN,NDIM,IMOD ** See whether we've space without garbage collect. ILAST=0 IFREE=0 DO 20 I=1,MXMAT+1 * If slot free, register and find next free slot. IF(MREF(I).EQ.0)THEN IF(IFREE.EQ.0)IFREE=I * Sufficient space ? Try to get a slot with it. ELSEIF(MORG(I)-ILAST.GE.NLEN)THEN IF(IFREE.NE.0)THEN ISLOT=IFREE ISTART=ILAST IF(LDEBUG)WRITE(LUNOUT,'(26X,''Fits in slot '', - I5,'' with origin '',I5,''.'')') - ISLOT,ISTART GOTO 300 ELSE ISLOT=I-1 ISTART=ILAST IF(LDEBUG)WRITE(LUNOUT,'(26X,''Trying to put'', - '' in slot '',I5,'' at origin '',I5,''.'')') - ISLOT,ISTART GOTO 100 ENDIF * Not enough space ? Re-start searching from here. ELSE ILAST=MORG(I)+MLEN(I) IFREE=0 ENDIF 20 CONTINUE ** If we get here, there is no free space without garbage collect. GOTO 200 ** Resume here is there is free space, but no slot in the right place. 100 CONTINUE * Eliminate empty entries below the slot to be assigned. IF(LDEBUG)WRITE(LUNOUT,'(26X, - ''Removing empty slots below target slot.'')') INEW=0 DO 30 I=1,ISLOT IF(MREF(I).NE.0)THEN INEW=INEW+1 MREF(INEW)=MREF(I) MORG(INEW)=MORG(I) DO 40 J=1,MXMDIM MSIZ(INEW,J)=MSIZ(I,J) 40 CONTINUE MDIM(INEW)=MDIM(I) MLEN(INEW)=MLEN(I) MMOD(INEW)=MMOD(I) IF(I.NE.INEW)MREF(I)=0 ENDIF 30 CONTINUE * Is there a free slot now ? IF(INEW.LT.ISLOT)THEN IF(LDEBUG)WRITE(LUNOUT,'(26X,''Fits in slot '', - I5,'' with origin '',I5,''.'')') - ISLOT,ISTART GOTO 300 ENDIF * Still no free slot, try to get the next higher slot. IF(ISLOT+1.LE.MXMAT)THEN ISLOT=ISLOT+1 ELSE IF(LDEBUG)WRITE(LUNOUT,'(26X,''Unable to get place'', - '' by shifting, trying garbage collect.'')') GOTO 200 ENDIF * And move the pointers ahead of the slot up. INEW=MXMAT+1 IF(LDEBUG)WRITE(LUNOUT,'(26X, - ''Removing empty slots above target slot.'')') DO 50 I=MXMAT,ISLOT,-1 IF(MREF(I).NE.0)THEN INEW=INEW-1 MREF(INEW)=MREF(I) MORG(INEW)=MORG(I) DO 60 J=1,MXMDIM MSIZ(INEW,J)=MSIZ(I,J) 60 CONTINUE MDIM(INEW)=MDIM(I) MLEN(INEW)=MLEN(I) MMOD(INEW)=MMOD(I) IF(I.NE.INEW)MREF(I)=0 ENDIF 50 CONTINUE * Is there a free slot now ? IF(ISLOT.LT.INEW)THEN IF(LDEBUG)WRITE(LUNOUT,'(26X,''Fits in slot '', - I5,'' with origin '',I5,''.'')') - ISLOT,ISTART GOTO 300 ENDIF ** If all failed, try a garbage collect. 200 CONTINUE INEW=0 IORG=0 IF(LDEBUG)WRITE(LUNOUT,'(26X,''Garbage collection.'')') DO 70 I=1,MXMAT * Skip empty matrices. IF(MREF(I).EQ.0)GOTO 70 * Copy the matrix itself. DO 90 J=1,MLEN(I) MVEC(IORG+J)=MVEC(MORG(I)+J) 90 CONTINUE * Increment matrix counter. INEW=INEW+1 * Copy the reference information. MREF(INEW)=MREF(I) MORG(INEW)=IORG IORG=IORG+MLEN(I) DO 80 J=1,MXMDIM MSIZ(INEW,J)=MSIZ(I,J) 80 CONTINUE MDIM(INEW)=MDIM(I) MLEN(INEW)=MLEN(I) MMOD(INEW)=MMOD(I) 70 CONTINUE * Reset the pointers for the rest of the list. DO 110 I=INEW+1,MXMAT MREF(I)=0 MORG(I)=0 MLEN(I)=0 MDIM(I)=0 MMOD(I)=0 DO 120 J=1,MXMDIM MSIZ(I,J)=0 120 CONTINUE 110 CONTINUE * Is there a free slot ? IF(INEW.GE.MXMAT)THEN PRINT *,' !!!!!! MATADM WARNING : No free slot'// - ' found; matrix not booked.' RETURN ENDIF * Is there enough space now ? IF(MORG(INEW)+MLEN(INEW)+NLEN.LE.MXEMAT)THEN ISLOT=INEW+1 ISTART=MORG(INEW)+MLEN(INEW) IF(LDEBUG)WRITE(LUNOUT,'(26X,''Fits in slot '', - I5,'' with origin '',I5,''.'')') - ISLOT,ISTART GOTO 300 ENDIF * Not enough room. PRINT *,' !!!!!! MATADM WARNING : Not enough matrix'// - ' space; matrix not booked.' RETURN ** We got a slot with enough space, save matrix information. 300 CONTINUE NREFL=NREFL+1 MREF(ISLOT)=NREFL IREF=NREFL IF(LDEBUG)WRITE(LUNOUT,'(26X,''Assigning reference '',I5)') - IREF MDIM(ISLOT)=NDIM MORG(ISLOT)=ISTART MMOD(ISLOT)=IMOD MLEN(ISLOT)=NLEN DO 130 I=1,NDIM MSIZ(ISLOT,I)=IDIM(I) 130 CONTINUE *** Initialise the matrix. DO 140 I=1,MLEN(ISLOT) MVEC(MORG(ISLOT)+I)=REAL(I) 140 CONTINUE ** Debugging output. IF(LDEBUG)WRITE(LUNOUT,'(26X,''Matrix allocation done.'')') ** Remember that this worked. IFAIL=0 *** Release an allocated matrix. ELSEIF(ACTION.EQ.'DELETE')THEN * Check whether there is a global associated with this matrix. DO 505 J=1,NGLB IF(GLBMOD(J).EQ.5.AND.NINT(GLBVAL(J)).EQ.IREF) - GLBMOD(J)=0 505 CONTINUE * Locate the matrix. DO 500 I=1,MXMAT IF(MREF(I).EQ.IREF)THEN MREF(I)=0 IF(LDEBUG)WRITE(LUNOUT,'(26X,''Matrix with'', - '' reference '',I5,'' cleared.'')') IREF IFAIL=0 RETURN ENDIF 500 CONTINUE * Warn if the matrix is not found. PRINT *,' !!!!!! MATADM WARNING : Matrix to be deleted'// - ' has not been found.' IF(LDEBUG)WRITE(LUNOUT,'(26X,''Reference: '',I5)') IREF IFAIL=1 *** List of matrices. ELSEIF(ACTION.EQ.'LIST')THEN * Print a header. WRITE(LUNOUT,'(/'' OVERVIEW OF EXISTING MATRICES''// - '' Reference n-Dim Type Global '', - '' Dimensions ... ''/)') * Keep track of free space and number of matrices in use. NFREE=0 ILAST=0 NUSED=0 * Loop over the matrices. DO 700 I=1,MXMAT IF(MREF(I).EQ.0)THEN NFREE=NFREE+1 ELSE NUSED=NUSED+1 IF(NFREE.GT.0.OR.MORG(I).NE.ILAST)THEN STRING(1:1)='(' NC=1 CALL OUTFMT(REAL(NFREE),2,STRAUX,NCAUX,'LEFT') STRING(NC+1:NC+NCAUX)=STRAUX(1:NCAUX) NC=NC+NCAUX STRING(NC+1:NC+16)=' free slots for ' NC=NC+16 CALL OUTFMT(REAL(MORG(I)-ILAST),2, - STRAUX,NCAUX,'LEFT') STRING(NC+1:NC+NCAUX)=STRAUX(1:NCAUX) NC=NC+NCAUX STRING(NC+1:NC+13)=' free words.)' NC=NC+13 WRITE(LUNOUT,'(2X,A)') STRING(1:NC) ENDIF NFREE=0 ILAST=MORG(I)+MLEN(I) IF(MMOD(I).EQ.0)THEN TYPE='Undefined' ELSEIF(MMOD(I).EQ.1)THEN TYPE='String' ELSEIF(MMOD(I).EQ.2)THEN TYPE='Number' ELSEIF(MMOD(I).EQ.3)THEN TYPE='Logical' ELSEIF(MMOD(I).EQ.4)THEN TYPE='Histogram' ENDIF NAME='< none >' DO 710 J=1,NGLB IF(GLBMOD(J).EQ.5.AND.NINT(GLBVAL(J)).EQ.MREF(I)) - NAME=GLBVAR(J) 710 CONTINUE WRITE(LUNOUT,'(2X,I9,1X,I5,1X,A10,1X,A10,1X, - (10(I4,1X,:)/40X))') - MREF(I),MDIM(I),TYPE,NAME,(MSIZ(I,J),J=1,MDIM(I)) ENDIF 700 CONTINUE IF(NFREE.GT.0.OR.MXEMAT.GT.ILAST)THEN STRING(1:1)='(' NC=1 CALL OUTFMT(REAL(NFREE),2,STRAUX,NCAUX,'LEFT') STRING(NC+1:NC+NCAUX)=STRAUX(1:NCAUX) NC=NC+NCAUX STRING(NC+1:NC+16)=' free slots for ' NC=NC+16 CALL OUTFMT(REAL(MXEMAT-ILAST),2, - STRAUX,NCAUX,'LEFT') STRING(NC+1:NC+NCAUX)=STRAUX(1:NCAUX) NC=NC+NCAUX STRING(NC+1:NC+13)=' free words.)' NC=NC+13 WRITE(LUNOUT,'(2X,A)') STRING(1:NC) ENDIF * Print number of matrices in use. WRITE(LUNOUT,'(/'' Number of matrices booked: '',I5/)') - NUSED *** Unknown action. ELSE PRINT *,' !!!!!! MATADM WARNING : Invalid action requested.' IFAIL=1 ENDIF END +DECK,MATADR. INTEGER FUNCTION MATADR(ISLOT,IA) *----------------------------------------------------------------------- * MATADR - Returns an address of a matrix element. * (Last changed on 25/10/95.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,MATDATA. INTEGER ISLOT,IA(*),I *** Verify address. IF(ISLOT.LE.0.OR.ISLOT.GT.MXMAT)THEN MATADR=-1 RETURN ENDIF *** Loop over the dimensions. DO 10 I=MDIM(ISLOT),1,-1 * Don't go beyond array bounds. IF(IA(I).LE.0.OR.IA(I).GT.MSIZ(ISLOT,I))THEN MATADR=-1 RETURN * First round. ELSEIF(I.EQ.MDIM(ISLOT))THEN MATADR=IA(I)-1 * All other terms. ELSE MATADR=MATADR*MSIZ(ISLOT,I)+IA(I)-1 ENDIF 10 CONTINUE *** Offset by the matrix starting point. MATADR=MATADR+MORG(ISLOT)+1 END +DECK,MATBND. SUBROUTINE MATBND(IREF1,IREF2,IREF3) *----------------------------------------------------------------------- * MATBND - Plots an error band. * (Last changed on 19/ 7/96.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,MATDATA. +SEQ,PRINTPLOT. REAL XPL(MXLIST),YPL(MXLIST) INTEGER MATSLT,IREF1,IREF2,IREF3,ISLOT1,ISLOT2,ISLOT3,I EXTERNAL MATSLT *** Indentify the routine if requested. IF(LIDENT)PRINT *,' /// ROUTINE MATBND ///' *** Debugging output. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MATBND DEBUG : Plotting'', - '' error band for '',3I5)') IREF1,IREF2,IREF3 *** Locate the 3 vectors. ISLOT1=MATSLT(IREF1) ISLOT2=MATSLT(IREF2) ISLOT3=MATSLT(IREF3) IF(ISLOT1.LE.0.OR.ISLOT2.LE.0.OR.ISLOT3.LE.0)THEN PRINT *,' !!!!!! MATBND WARNING : Didn''t find all'// - ' matrices forming the error band; not plotted.' RETURN ENDIF *** Verify that the 3 have the same length. IF(MLEN(ISLOT1).NE.MLEN(ISLOT2).OR. - MLEN(ISLOT2).NE.MLEN(ISLOT3))THEN PRINT *,' !!!!!! MATBND WARNING : The 3 vectors do not'// - ' have the same length; error band not plotted.' RETURN ENDIF *** Verify that the length is at least 2. IF(MLEN(ISLOT1).LT.2.OR.2*MLEN(ISLOT1)+1.GT.MXLIST)THEN PRINT *,' !!!!!! MATBND WARNING : The vectors have a'// - ' length outside [2,(MXLIST-1)/2]; not plotted.' RETURN ENDIF *** Set the appropriate representations. CALL GRATTS('ERROR-BAND','POLYLINE') CALL GRATTS('ERROR-BAND','AREA') *** Plot the line. DO 10 I=1,MLEN(ISLOT1) XPL(I)=MVEC(MORG(ISLOT1)+I) YPL(I)=MVEC(MORG(ISLOT2)+I) XPL(2*MLEN(ISLOT1)-I+1)=MVEC(MORG(ISLOT1)+I) YPL(2*MLEN(ISLOT1)-I+1)=MVEC(MORG(ISLOT3)+I) 10 CONTINUE XPL(2*MLEN(ISLOT1)+1)=MVEC(MORG(ISLOT1)+1) YPL(2*MLEN(ISLOT1)+1)=MVEC(MORG(ISLOT2)+1) CALL GRAREA(2*MLEN(ISLOT1)+1,XPL,YPL) CALL GRLINE(2*MLEN(ISLOT1)+1,XPL,YPL) END +DECK,MATCAL. SUBROUTINE MATCAL(INSTR,IFAIL) *----------------------------------------------------------------------- * MATCAL - Handles matrix procedure calls. * (Last changed on 14/11/99.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,ALGDATA. +SEQ,GLOBALS. +SEQ,MATDATA. +SEQ,PRINTPLOT. CHARACTER*80 XTXT,YTXT,TITLE,FILE,OPTION CHARACTER*30 NAME CHARACTER*29 REMARK CHARACTER*8 MEMBER REAL AUX,ZERO(MXLIST),PAD,THETA,PHI INTEGER ISIZ(MXMDIM),ISEL(MXLIST),NSEL,MATSLT,NCXTXT,NCYTXT, - NCTIT,IREFX,IREFY,ISDUM1,ISDUM2,NARG,IPROC,INSTR,IFAIL, - IFAIL1,IFAIL2,IFAIL3,IFAIL4,NCOPT,NCONT,NZERO,I,J,K,NIN, - ISLOT,IRMAT,ISMAT,NDIM,NDUM,NCFILE,NCMEMB,NCREM,LORD,NORD, - ISORD,ISORDI,IROUT,IWRONG,IDUM,IREF,IREFD,ISLOTD,ISDIM,IRORD EXTERNAL MATSLT *** Assume that this will fail. IFAIL=1 *** Some easy reference variables. NARG=INS(INSTR,3) IPROC=INS(INSTR,1) *** Extract a sub-matrix. IF(IPROC.EQ.-80)THEN * Check the format of the argument list. IF(NARG.LT.3.OR.ARGREF(NARG,1).GE.2.OR. - MODARG(NARG-1).NE.5.OR.MODARG(1).NE.2.OR. - NINT(ARG(1)).LT.1)THEN PRINT *,' !!!!!! MATCAL WARNING : EXTRACT_SUBMATRIX'// - ' received an invalid argument list.' RETURN ENDIF * Copy the selection vector, expanding any vectors used as address. IF(1+NINT(ARG(1)).GT.MXLIST)GOTO 69 ISEL(1)=NINT(ARG(1)) NSEL=1+NINT(ARG(1)) NIN=1+NINT(ARG(1)) DO 60 I=2,1+NINT(ARG(1)) IF(MODARG(I).NE.2)THEN PRINT *,' !!!!!! MATCAL WARNING : Incorrectly'// - ' specified selection size; no sub-matrix.' RETURN ENDIF ISEL(I)=0 DO 61 J=1,NINT(ARG(I)) IF(MODARG(NIN+J).EQ.2)THEN IF(NSEL+1.GT.MXLIST)GOTO 69 NSEL=NSEL+1 ISEL(NSEL)=NINT(ARG(NIN+J)) ISEL(I)=ISEL(I)+1 ELSEIF(MODARG(NIN+J).EQ.5)THEN DO 62 K=1,MXMAT IF(MREF(K).EQ.NINT(ARG(NIN+J)))THEN ISLOT=K GOTO 63 ENDIF 62 CONTINUE PRINT *,' !!!!!! MATCAL WARNING : Matrix not found;'// - ' program bug - please report.' RETURN 63 CONTINUE DO 64 K=1,MLEN(ISLOT) IF(NSEL+1.GT.MXLIST)GOTO 69 NSEL=NSEL+1 ISEL(NSEL)=NINT(MVEC(MORG(ISLOT)+K)) ISEL(I)=ISEL(I)+1 64 CONTINUE ELSE PRINT *,' !!!!!! MATCAL WARNING : Incorrectly'// - ' specified selection item; no sub-matrix.' RETURN ENDIF 61 CONTINUE NIN=NIN+NINT(ARG(I)) 60 CONTINUE * Store the sub-matrix in the matrix. CALL MATSUB('EXTRACT',ISEL,NINT(ARG(NARG-1)),IRMAT,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! MATCAL WARNING : Extracting the'// - ' submatrix failed.' RETURN ENDIF * Free the receiving argument. CALL ALGREU(NINT(ARG(NARG)),MODARG(NARG),ARGREF(NARG,1)) * Update the argument list. ARG(NARG)=IRMAT MODARG(NARG)=5 * In case of failure. GOTO 68 69 CONTINUE PRINT *,' !!!!!! MATCAL WARNING : Insufficient memory'// - ' to expand matrix selection vector; no sub-matrix.' RETURN 68 CONTINUE *** Store a sub-matrix. ELSEIF(IPROC.EQ.-81)THEN * Check the format of the argument list. IF(NARG.LT.3.OR.ARGREF(NARG-1,1).GE.2.OR. - MODARG(NARG-1).NE.5.OR. - (MODARG(NARG).NE.2.AND.MODARG(NARG).NE.5))THEN PRINT *,' !!!!!! MATCAL WARNING : STORE_SUBMATRIX'// - ' received an invalid argument list.' RETURN ENDIF * Process the case that we've to store a scalar in a matrix. IF(MODARG(NARG).EQ.2)THEN ISIZ(1)=1 CALL MATADM('ALLOCATE',IRMAT,1,ISIZ,2,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! MATCAL WARNING : Unable to'// - ' allocate a temporary matrix for a scalar.' RETURN ENDIF DO 80 I=1,MXMAT IF(MREF(I).EQ.IRMAT)THEN ISMAT=I GOTO 90 ENDIF 80 CONTINUE PRINT *,' !!!!!! MATCAL WARNING : Scalar not found;'// - ' program bug - please report.' RETURN 90 CONTINUE MVEC(MORG(ISMAT)+1)=ARG(NARG) ELSE IRMAT=NINT(ARG(NARG)) ENDIF * Copy the selection vector, expanding any vectors used as address. IF(1+NINT(ARG(1)).GT.MXLIST)GOTO 79 ISEL(1)=NINT(ARG(1)) NSEL=1+NINT(ARG(1)) NIN=1+NINT(ARG(1)) DO 70 I=2,1+NINT(ARG(1)) IF(MODARG(I).NE.2)THEN PRINT *,' !!!!!! MATCAL WARNING : Incorrectly'// - ' specified selection size; no sub-matrix.' IF(MODARG(NARG).EQ.2) - CALL MATADM('DELETE',IRMAT,1,ISIZ,2,IFAIL2) RETURN ENDIF ISEL(I)=0 DO 71 J=1,NINT(ARG(I)) IF(MODARG(NIN+J).EQ.2)THEN IF(NSEL+1.GT.MXLIST)GOTO 79 NSEL=NSEL+1 ISEL(NSEL)=NINT(ARG(NIN+J)) ISEL(I)=ISEL(I)+1 ELSEIF(MODARG(NIN+J).EQ.5)THEN DO 72 K=1,MXMAT IF(MREF(K).EQ.NINT(ARG(NIN+J)))THEN ISLOT=K GOTO 73 ENDIF 72 CONTINUE PRINT *,' !!!!!! MATCAL WARNING : Matrix not found;'// - ' program bug - please report.' RETURN 73 CONTINUE DO 74 K=1,MLEN(ISLOT) IF(NSEL+1.GT.MXLIST)GOTO 79 NSEL=NSEL+1 ISEL(NSEL)=NINT(MVEC(MORG(ISLOT)+K)) ISEL(I)=ISEL(I)+1 74 CONTINUE ELSE PRINT *,' !!!!!! MATCAL WARNING : Incorrectly'// - ' specified selection item; no sub-matrix.' IF(MODARG(NARG).EQ.2) - CALL MATADM('DELETE',IRMAT,1,ISIZ,2,IFAIL2) RETURN ENDIF 71 CONTINUE NIN=NIN+NINT(ARG(I)) 70 CONTINUE * Store the matrix in the sub-matrix. CALL MATSUB('STORE',ISEL,NINT(ARG(NARG-1)),IRMAT,IFAIL1) * Remove the temporary matrix if we assigned a scalar. IF(MODARG(NARG).EQ.2) - CALL MATADM('DELETE',IRMAT,1,ISIZ,2,IFAIL2) * Check error flags. IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! MATCAL WARNING : Storing in the'// - ' submatrix failed.' RETURN ENDIF * Failure. GOTO 78 79 CONTINUE PRINT *,' !!!!!! MATCAL WARNING : Insufficient memory'// - ' to expand matrix selection vector; no sub-matrix.' RETURN 78 CONTINUE *** Print a matrix. ELSEIF(IPROC.EQ.-82)THEN * There should be at least 1 argument. IF(NARG.LE.0)THEN PRINT *,' !!!!!! MATCAL WARNING : Incorrect number'// - ' arguments received by PRINT_MATRIX.' * Print all matrices provided as arguments, find their names. ELSE DO 10 I=1,NARG IF(MODARG(I).NE.5)THEN PRINT *,' !!!!!! MATCAL WARNING : An argument'// - ' is not of type matrix ; ignored.' GOTO 10 ENDIF NAME='(temporary matrix)' DO 20 J=1,NGLB IF(GLBMOD(J).EQ.5.AND.NINT(GLBVAL(J)).EQ.NINT(ARG(I))) - NAME=GLBVAR(J) 20 CONTINUE WRITE(LUNOUT,'(2X,A)') NAME CALL MATPRT(NINT(ARG(I))) 10 CONTINUE ENDIF *** Create a matrix. ELSEIF(IPROC.EQ.-83)THEN * Check number of arguments. IF(NARG.LE.1.OR.ARGREF(1,1).GE.2)THEN PRINT *,' !!!!!! MATCAL WARNING : Incorrect argument'// - ' list received by BOOK_MATRIX.' ELSE * Get the matrix dimensions. NDIM=0 DO 30 I=2,NARG IF(MODARG(I).EQ.2)THEN IF(NDIM+1.GT.MXMDIM)THEN PRINT *,' !!!!!! MATCAL WARNING : Too'// - ' many dimensions; matrix not booked.' RETURN ENDIF NDIM=NDIM+1 ISIZ(NDIM)=NINT(ARG(I)) ELSEIF(MODARG(I).EQ.5)THEN ISDIM=MATSLT(NINT(ARG(I))) IF(ISDIM.LE.0)THEN PRINT *,' !!!!!! MATCAL WARNING : Size'// - ' not found; matrix not booked.' RETURN ENDIF DO 35 J=1,MLEN(ISDIM) IF(NDIM+1.GT.MXMDIM)THEN PRINT *,' !!!!!! MATCAL WARNING : Too'// - ' many dimensions; matrix not booked.' RETURN ENDIF NDIM=NDIM+1 ISIZ(NDIM)=NINT(MVEC(MORG(ISDIM)+J)) 35 CONTINUE ELSE PRINT *,' !!!!!! MATCAL WARNING : Incorrect'// - ' data type in array dimensions.' RETURN ENDIF 30 CONTINUE * Create the matrix. CALL MATADM('ALLOCATE',IREF,NDIM,ISIZ,2,IFAIL1) * See whether this worked. IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! MATCAL WARNING : Unable to'// - ' create the requested matrix.' RETURN ENDIF * Clear the variable. CALL ALGREU(NINT(ARG(1)),MODARG(1),ARGREF(1,1)) * Assign the result to the variable. ARG(1)=REAL(IREF) MODARG(1)=5 ENDIF *** Resize a matrix. ELSEIF(IPROC.EQ.-84)THEN * Check number of arguments. IF(NARG.LE.2.OR.NARG.GT.MXMDIM+2.OR. - ARGREF(1,1).GE.2.OR.MODARG(1).NE.5.OR. - MODARG(NARG).NE.2)THEN PRINT *,' !!!!!! MATCAL WARNING : Incorrect argument'// - ' list received by RESHAPE_MATRIX.' ELSE * Get padding. PAD=ARG(NARG) * Get the matrix dimensions. NDIM=NARG-2 DO 40 I=1,NDIM IF(MODARG(I+1).NE.2)THEN PRINT *,' !!!!!! MATCAL WARNING : Incorrect'// - ' data type in array dimensions.' RETURN ENDIF ISIZ(I)=NINT(ARG(I+1)) 40 CONTINUE * Resize the matrix. CALL MATCHS(NINT(ARG(1)),NDIM,ISIZ,PAD,IFAIL1) * See whether this worked. IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! MATCAL WARNING : Unable to'// - ' re-shape the matrix.' RETURN ENDIF ENDIF *** Adjust a matrix. ELSEIF(IPROC.EQ.-85)THEN * Check number of arguments. IF(NARG.LE.2.OR.NARG.GT.MXMDIM+2.OR. - ARGREF(1,1).GE.2.OR.MODARG(1).NE.5.OR. - MODARG(NARG).NE.2)THEN PRINT *,' !!!!!! MATCAL WARNING : Incorrect argument'// - ' list received by ADJUST_MATRIX.' ELSE * Get padding. PAD=ARG(NARG) * Get the matrix dimensions. NDIM=NARG-2 DO 45 I=1,NDIM IF(MODARG(I+1).NE.2)THEN PRINT *,' !!!!!! MATCAL WARNING : Incorrect'// - ' data type in array dimensions.' RETURN ENDIF ISIZ(I)=NINT(ARG(I+1)) 45 CONTINUE * Resize the matrix. CALL MATADJ(NINT(ARG(1)),NDIM,ISIZ,PAD,IFAIL1) * See whether this worked. IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! MATCAL WARNING : Unable to'// - ' adjust the matrix.' RETURN ENDIF ENDIF *** Delete a matrix. ELSEIF(IPROC.EQ.-86)THEN * Check number of arguments. IF(NARG.LT.1)THEN DO 55 I=1,NGLB IF(GLBMOD(I).EQ.5)THEN CALL MATADM('DELETE',NINT(GLBVAL(I)), - 0,ISIZ,2,IFAIL1) GLBVAL(I)=0 GLBMOD(I)=0 ENDIF 55 CONTINUE CALL MATINT C PRINT *,' !!!!!! MATCAL WARNING : DELETE_MATRIX'// C - ' needs at least 1 argument.' * Delete all the matrices in the arguments. ELSE DO 50 I=1,NARG IF(MODARG(I).NE.5)THEN C PRINT *,' !!!!!! MATCAL WARNING : Incorrect'// C - ' data type in DELETE_MATRIX call.' GOTO 50 ENDIF CALL MATADM('DELETE',NINT(ARG(I)),0,ISIZ,2,IFAIL1) ARG(I)=0 MODARG(I)=0 IF(IFAIL1.NE.0)PRINT *,' !!!!!! MATCAL WARNING :'// - ' Deleting a matrix failed.' 50 CONTINUE ENDIF *** List matrices in memory. ELSEIF(IPROC.EQ.-87)THEN * Check number and type of arguments. IF(NARG.NE.0)THEN PRINT *,' !!!!!! MATCAL WARNING : Incorrect argument'// - ' list provided for LIST_MATRICES.' RETURN ENDIF * List. CALL MATADM('LIST',IDUM,NDUM,ISIZ,NDUM,IFAIL1) *** Write a matrix to a library. ELSEIF(IPROC.EQ.-88)THEN * Check number and type of arguments. IF(MODARG(1).NE.5.OR.MODARG(2).NE.1.OR. - (NARG.GE.3.AND.MODARG(3).NE.1).OR. - (NARG.GE.4.AND.MODARG(4).NE.1).OR. - NARG.LT.2.OR.NARG.GT.4)THEN PRINT *,' !!!!!! MATCAL WARNING : Incorrect argument'// - ' list provided for WRITE_MATRIX.' RETURN ENDIF * Fetch file name. CALL STRBUF('READ',NINT(ARG(2)),FILE,NCFILE,IFAIL1) * Member name. IF(NARG.GE.3)THEN CALL STRBUF('READ',NINT(ARG(3)),MEMBER,NCMEMB,IFAIL2) IF(NCMEMB.GT.8)PRINT *,' !!!!!! MATCAL WARNING :'// - ' Member name truncated to first 8 characters' NCMEMB=MIN(8,NCMEMB) ELSE DO 120 J=1,NGLB IF(GLBMOD(J).NE.5)GOTO 120 IF(NINT(GLBVAL(J)).EQ.NINT(ARG(1)))THEN MEMBER=GLBVAR(J) NCMEMB=8 GOTO 130 ENDIF 120 CONTINUE MEMBER='< none >' NCMEMB=8 130 CONTINUE IFAIL2=0 ENDIF * Remark. IF(NARG.GE.4)THEN CALL STRBUF('READ',NINT(ARG(4)),REMARK,NCREM,IFAIL3) IF(NCREM.GT.29)PRINT *,' !!!!!! MATCAL WARNING :'// - ' Remark truncated to first 29 characters' NCREM=MIN(29,NCREM) ELSE REMARK='none' NCREM=4 IFAIL3=0 ENDIF * Write the matrix. IF(IFAIL1.EQ.0.AND.IFAIL2.EQ.0.AND.IFAIL3.EQ.0)THEN CALL MATWRT(NINT(ARG(1)),FILE(1:NCFILE), - MEMBER(1:NCMEMB),REMARK(1:NCREM),IFAIL2) IF(IFAIL2.NE.0)PRINT *,' !!!!!! MATCAL WARNING :'// - ' Writing matrix to disk failed.' ELSE PRINT *,' !!!!!! MATCAL WARNING :'// - ' Not able to obtain a name; matrix'// - ' not written to disk.' ENDIF *** Get a matrix from a library. ELSEIF(IPROC.EQ.-89)THEN * Check number and type of arguments. IF(ARGREF(1,1).GE.2.OR. - MODARG(2).NE.1.OR. - (NARG.GE.3.AND.MODARG(3).NE.1).OR. - NARG.LT.2.OR.NARG.GT.3)THEN PRINT *,' !!!!!! MATCAL WARNING : Incorrect argument'// - ' list provided for GET_MATRIX.' RETURN ENDIF * Fetch file name. CALL STRBUF('READ',NINT(ARG(2)),FILE,NCFILE,IFAIL1) * Fetch member name, if any. IF(NARG.GE.3)THEN CALL STRBUF('READ',NINT(ARG(3)),MEMBER,NCMEMB,IFAIL2) IF(NCMEMB.GT.8)PRINT *,' !!!!!! MATCAL WARNING :'// - ' Member name truncated to first 8 characters' NCMEMB=MIN(8,NCMEMB) ELSEIF(ARGREF(1,2).GE.1.AND.ARGREF(1,2).LE.NGLB)THEN MEMBER=GLBVAR(ARGREF(1,2)) NCMEMB=8 IFAIL2=0 ELSE MEMBER='*' NCMEMB=1 IFAIL2=0 ENDIF * Read the matrix. IF(IFAIL1.EQ.0.AND.IFAIL2.EQ.0)THEN CALL ALGREU(NINT(ARG(1)),MODARG(1),ARGREF(1,1)) CALL MATGET(IREF,FILE(1:NCFILE), - MEMBER(1:NCMEMB),IFAIL3) IF(IFAIL3.NE.0)THEN PRINT *,' !!!!!! MATCAL WARNING :'// - ' Reading matrix from disk failed.' ARG(1)=0 MODARG(1)=0 ELSE ARG(1)=IREF MODARG(1)=5 ENDIF ELSE PRINT *,' !!!!!! MATCAL WARNING :'// - ' Not able to obtain a name; matrix'// - ' not read from disk.' ENDIF *** Matrix multiplication. ELSEIF(IPROC.EQ.-90)THEN *** Solve linear equation. ELSEIF(IPROC.EQ.-91)THEN *** Return matrix dimensions. ELSEIF(IPROC.EQ.-92)THEN * Check number and type of arguments. IF(NARG.NE.3.OR. - ARGREF(2,1).GE.2.OR.ARGREF(3,1).GE.2.OR. - MODARG(1).NE.5)THEN PRINT *,' !!!!!! MATCAL WARNING : Incorrect argument'// - ' list provided for DIMENSIONS.' RETURN ENDIF * Locate the matrix. DO 180 I=1,MXMAT IF(MREF(I).EQ.NINT(ARG(1)))THEN ISLOT=I NDIM=MDIM(I) GOTO 140 ENDIF 180 CONTINUE PRINT *,' !!!!!! MATCAL WARNING : Matrix not found;'// - ' no dimensions returned.' RETURN 140 CONTINUE * Clear the output arguments. CALL ALGREU(NINT(ARG(2)),MODARG(2),ARGREF(2,1)) CALL ALGREU(NINT(ARG(3)),MODARG(3),ARGREF(3,1)) * Store the dimension. ARG(2)=NDIM MODARG(2)=2 * Get a matrix for the dimensions. ISIZ(1)=NDIM CALL MATADM('ALLOCATE',IREFD,1,ISIZ,2,IFAIL1) IF(IFAIL1.NE.0)RETURN ISLOT=-1 ISLOTD=-1 DO 150 I=1,MXMAT IF(MREF(I).EQ.NINT(ARG(1)))THEN ISLOT=I ELSEIF(MREF(I).EQ.IREFD)THEN ISLOTD=I ENDIF IF(ISLOT.GT.0.AND.ISLOTD.GT.0)GOTO 160 150 CONTINUE PRINT *,' !!!!!! MATCAL WARNING : Matrix not found;'// - ' no dimensions returned.' RETURN 160 CONTINUE * Store the dimensions. DO 170 J=1,NDIM MVEC(MORG(ISLOTD)+J)=MSIZ(ISLOT,J) 170 CONTINUE * Save the output. ARG(3)=IREFD MODARG(3)=5 *** Matrix interpolation. ELSEIF(IPROC.EQ.-93)THEN * Check the format of the argument list. IF(NARG.LT.4.OR.ARGREF(NARG,1).GE.2.OR. - MODARG(1).NE.5.OR.MODARG(NARG-1).NE.5)THEN PRINT *,' !!!!!! MATCAL WARNING : INTERPOLATE'// - ' received an invalid argument list.' RETURN ENDIF * Locate the matrix. ISMAT=MATSLT(NINT(ARG(1))) IF(ISMAT.LE.0)THEN PRINT *,' !!!!!! MATCAL WARNING : Matrix to be'// - ' interpolated has not been found.' RETURN ENDIF * Determine the size of the combined ordinate vector. LORD=0 DO 203 I=1,MDIM(ISMAT) LORD=LORD+MSIZ(ISMAT,I) 203 CONTINUE * Allocate a matrix for the combined ordinate vector. ISIZ(1)=LORD CALL MATADM('ALLOCATE',IRORD,1,ISIZ,2,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! MATCAL WARNING : Unable to allocate'// - ' an ordinate vector.' RETURN ENDIF * And find this matrix. ISORD=MATSLT(IRORD) IF(ISORD.LE.0)THEN PRINT *,' !!!!!! MATCAL WARNING : Combined ordinate'// - ' vector not found.' RETURN ENDIF * Find the matrix again. ISMAT=MATSLT(NINT(ARG(1))) IF(ISMAT.LE.0)THEN PRINT *,' !!!!!! MATCAL WARNING : Matrix to be'// - ' interpolated has not been found.' RETURN ENDIF * Loop over the ordinate vectors. NORD=0 DO 200 I=2,NARG-2 IF(MODARG(I).NE.5)THEN PRINT *,' !!!!!! MATCAL WARNING : An'// - ' ordinate vector is not a declared matrix.' CALL MATADM('DELETE',IRORD,1,ISIZ,2,IFAIL1) RETURN ENDIF * Locate the vector. ISORDI=MATSLT(NINT(ARG(I))) IF(ISORDI.LE.0)THEN PRINT *,' !!!!!! MATCAL WARNING : An ordinate'// - ' vector has not been found.' CALL MATADM('DELETE',IRORD,1,ISIZ,2,IFAIL1) RETURN ENDIF * Ensure it is a 1-dimensional vector and the right size. IF(MDIM(ISORDI).NE.1.OR. - MSIZ(ISORDI,1).NE.MSIZ(ISMAT,I-1))THEN PRINT *,' !!!!!! MATCAL WARNING : An'// - ' ordinate vector is not of the right size.' CALL MATADM('DELETE',IRORD,1,ISIZ,2,IFAIL1) RETURN ENDIF * Copy this vector to the large ordinate vector, checking ordering. DO 230 J=1,MSIZ(ISORDI,1) NORD=NORD+1 MVEC(MORG(ISORD)+NORD)=MVEC(MORG(ISORDI)+J) IF(J.GT.1)THEN IF(MVEC(MORG(ISORDI)+J).LE.MVEC(MORG(ISORDI)+J-1))THEN PRINT *,' !!!!!! MATCAL WARNING : An ordinate'// - ' vector is not well ordered.' CALL MATADM('DELETE',IRORD,1,ISIZ,2,IFAIL1) RETURN ENDIF ENDIF 230 CONTINUE * Next dimension. 200 CONTINUE * Output argument. IF(MODARG(NARG).EQ.5)THEN IROUT=NINT(ARG(NARG)) ELSE IROUT=-1 ENDIF * Call the interpolation routine. CALL MATINN(NINT(ARG(1)),IRORD,NINT(ARG(NARG-1)), - IROUT,IFAIL2) IF(IFAIL2.NE.0)PRINT *,' !!!!!! MATCAL WARNING :'// - ' Matrix interpolation failed.' * Assign the output. ARG(NARG)=IROUT MODARG(NARG)=5 * Remove the ordinate vector. CALL MATADM('DELETE',IRORD,1,ISIZ,2,IFAIL1) IF(IFAIL2.NE.0)RETURN *** Surface plots. ELSEIF(IPROC.EQ.-94)THEN * Check argument list. IF(NARG.LT.1.OR.NARG.GT.8.OR. - MODARG(1).NE.5.OR. - (NARG.GE.2.AND.MODARG(2).NE.2).OR. - (NARG.GE.3.AND.MODARG(3).NE.2).OR. - (NARG.GE.4.AND.MODARG(4).NE.5).OR. - (NARG.GE.5.AND.MODARG(5).NE.5).OR. - (NARG.GE.6.AND.MODARG(6).NE.1).OR. - (NARG.GE.7.AND.MODARG(7).NE.1).OR. - (NARG.GE.8.AND.MODARG(8).NE.1))THEN PRINT *,' !!!!!! MATCAL WARNING : Some arguments of'// - ' PLOT_SURFACE are of incorrect type.' RETURN ENDIF * Plotting angles. IF(NARG.GE.2)THEN THETA=ARG(2) ELSE THETA=60 ENDIF IF(NARG.GE.3)THEN PHI=ARG(3) ELSE PHI=60 ENDIF * Axis ranges. IF(NARG.GE.4)THEN IREFX=NINT(ARG(4)) ELSE IREFX=-1 ENDIF IF(NARG.GE.5)THEN IREFY=NINT(ARG(5)) ELSE IREFY=-1 ENDIF * Fetch the x-axis label. IF(NARG.GE.6)THEN CALL STRBUF('READ',NINT(ARG(6)),XTXT,NCXTXT,IFAIL1) ELSEIF(NARG.GE.4)THEN DO 171 J=1,NGLB IF(GLBMOD(J).NE.5)GOTO 171 IF(NINT(GLBVAL(J)).EQ.IREFX)THEN XTXT=GLBVAR(J) NCXTXT=10 GOTO 172 ENDIF 171 CONTINUE XTXT='x-axis' NCXTXT=6 172 CONTINUE IFAIL1=0 ELSE XTXT='x-axis' NCXTXT=6 IFAIL1=0 ENDIF * Fetch the y-axis label. IF(NARG.GE.7)THEN CALL STRBUF('READ',NINT(ARG(7)),YTXT,NCYTXT,IFAIL2) ELSEIF(NARG.GE.5)THEN DO 173 J=1,NGLB IF(GLBMOD(J).NE.5)GOTO 173 IF(NINT(GLBVAL(J)).EQ.IREFY)THEN YTXT=GLBVAR(J) NCYTXT=10 GOTO 174 ENDIF 173 CONTINUE YTXT='y-axis' NCYTXT=6 174 CONTINUE IFAIL2=0 ELSE YTXT='y-axis' NCYTXT=6 IFAIL2=0 ENDIF * Fetch the global title. IF(NARG.GE.8)THEN CALL STRBUF('READ',NINT(ARG(8)),TITLE,NCTIT,IFAIL3) ELSE DO 175 J=1,NGLB IF(GLBMOD(J).NE.5)GOTO 175 IF(NINT(GLBVAL(J)).EQ.NINT(ARG(1)))THEN TITLE=GLBVAR(J) NCTIT=10 GOTO 176 ENDIF 175 CONTINUE TITLE=' ' NCTIT=1 176 CONTINUE IFAIL3=0 ENDIF * Plot the surface. CALL MATSUR(NINT(ARG(1)),IREFX,IREFY,XTXT(1:NCXTXT), - YTXT(1:NCYTXT),TITLE(1:NCTIT),PHI,THETA) * Switch back to normal screen. CALL GRALPH * Error processing. IF(IFAIL1.NE.0.OR.IFAIL2.NE.0.OR.IFAIL3.NE.0) - PRINT *,' !!!!!! MATCAL WARNING : Error'// - ' retrieving a string for PLOT_SURFACE.' *** Contour plots. ELSEIF(IPROC.EQ.-100)THEN * Check argument list. IF(NARG.LT.1.OR.NARG.GT.8.OR. - MODARG(1).NE.5.OR. - (NARG.GE.2.AND.MODARG(2).NE.2).OR. - (NARG.GE.3.AND.MODARG(3).NE.1).OR. - (NARG.GE.4.AND.MODARG(4).NE.5).OR. - (NARG.GE.5.AND.MODARG(5).NE.5).OR. - (NARG.GE.6.AND.MODARG(6).NE.1).OR. - (NARG.GE.7.AND.MODARG(7).NE.1).OR. - (NARG.GE.8.AND.MODARG(8).NE.1))THEN PRINT *,' !!!!!! MATCAL WARNING : Some arguments of'// - ' PLOT_CONTOURS are of incorrect type.' RETURN ENDIF * Fetch the options, if present. IF(NARG.GE.2)THEN NCONT=NINT(ARG(2)) ELSE NCONT=20 ENDIF IF(NARG.GE.3)THEN CALL STRBUF('READ',NINT(ARG(3)),OPTION,NCOPT,IFAIL4) CALL CLTOU(OPTION(1:NCOPT)) ELSE OPTION=' ' NCOPT=1 IFAIL4=0 ENDIF * Axis ranges. IF(NARG.GE.4)THEN IREFX=NINT(ARG(4)) ELSE IREFX=-1 ENDIF IF(NARG.GE.5)THEN IREFY=NINT(ARG(5)) ELSE IREFY=-1 ENDIF * Fetch the x-axis label. IF(NARG.GE.6)THEN CALL STRBUF('READ',NINT(ARG(6)),XTXT,NCXTXT,IFAIL1) ELSEIF(NARG.GE.4.AND. - ARGREF(4,2).GE.1.AND.ARGREF(4,2).LE.NGLB)THEN XTXT=GLBVAR(ARGREF(4,2)) NCXTXT=LEN(GLBVAR(ARGREF(4,2))) IFAIL1=0 ELSE XTXT='x-axis' NCXTXT=6 IFAIL1=0 ENDIF * Fetch the y-axis label. IF(NARG.GE.7)THEN CALL STRBUF('READ',NINT(ARG(7)),YTXT,NCYTXT,IFAIL2) ELSEIF(NARG.GE.5.AND. - ARGREF(5,2).GE.1.AND.ARGREF(5,2).LE.NGLB)THEN YTXT=GLBVAR(ARGREF(5,2)) NCYTXT=LEN(GLBVAR(ARGREF(5,2))) IFAIL2=0 ELSE YTXT='y-axis' NCYTXT=6 IFAIL2=0 ENDIF * Fetch the global title. IF(NARG.GE.8)THEN CALL STRBUF('READ',NINT(ARG(8)),TITLE,NCTIT,IFAIL3) ELSEIF(NARG.GE.1.AND. - ARGREF(1,2).GE.1.AND.ARGREF(1,2).LE.NGLB)THEN TITLE=GLBVAR(ARGREF(1,2)) NCTIT=LEN(GLBVAR(ARGREF(1,2))) IFAIL3=0 ELSE TITLE='Matrix contours' NCTIT=15 IFAIL3=0 ENDIF * Plot the surface. CALL MATCON(NINT(ARG(1)),IREFX,IREFY,XTXT(1:NCXTXT), - YTXT(1:NCYTXT),TITLE(1:NCTIT),NCONT,OPTION(1:NCOPT)) * Switch back to normal screen. CALL GRALPH * Error processing. IF(IFAIL1.NE.0.OR.IFAIL2.NE.0.OR.IFAIL3.NE.0.OR.IFAIL4.NE.0) - PRINT *,' !!!!!! MATCAL WARNING : Error'// - ' retrieving a string for PLOT_CONTOURS.' *** Derivative. ELSEIF(IPROC.EQ.-95)THEN * Check argument list. IF(NARG.LT.4.OR.NARG.GT.5.OR. - MODARG(1).NE.5.OR.MODARG(2).NE.5.OR.MODARG(3).NE.2.OR. - ARGREF(4,1).GE.2.OR. - (NARG.GE.5.AND.MODARG(5).NE.1))THEN PRINT *,' !!!!!! MATCAL WARNING : Some arguments of'// - ' DERIVATIVE are of incorrect type.' RETURN ENDIF * Get hold of the option string. IF(NARG.GE.5)THEN CALL STRBUF('READ',NINT(ARG(5)),TITLE,NCTIT,IFAIL1) CALL CLTOU(TITLE(1:NCTIT)) ELSE TITLE=' ' NCTIT=1 IFAIL1=0 ENDIF * Calculate the derivative. CALL MATDER(NINT(ARG(1)),NINT(ARG(2)),ARG(3),AUX, - TITLE(1:NCTIT),IFAIL2) * Clear the memory associated with the return argument. CALL ALGREU(NINT(ARG(4)),MODARG(4),ARGREF(4,1)) * Return the result. ARG(4)=AUX MODARG(4)=2 * Error processing. IF(IFAIL1.NE.0.OR.IFAIL2.NE.0) - PRINT *,' !!!!!! MATCAL WARNING : Error'// - ' processing a DERIVATIVE call.' *** Interpolation of various orders. ELSEIF(IPROC.EQ.-96.OR.IPROC.EQ.-97.OR.IPROC.EQ.-98.OR. - IPROC.EQ.-99)THEN * Check argument list. IF(NARG.NE.4.OR. - MODARG(1).NE.5.OR.MODARG(2).NE.5.OR.MODARG(3).NE.2.OR. - ARGREF(4,1).GE.2)THEN PRINT *,' !!!!!! MATCAL WARNING : Some arguments of'// - ' INTERPOLATE_i are of incorrect type.' RETURN ENDIF * Clear the output argument. CALL ALGREU(NINT(ARG(4)),MODARG(4),ARGREF(4,1)) * Call the procedure. ISDUM1=-1 ISDUM2=-1 IF(IPROC.EQ.-96)THEN CALL MATIN1(NINT(ARG(1)),NINT(ARG(2)),1,ARG(3),ARG(4), - ISDUM1,ISDUM2,1,IFAIL1) ELSEIF(IPROC.EQ.-97)THEN CALL MATIN1(NINT(ARG(1)),NINT(ARG(2)),1,ARG(3),ARG(4), - ISDUM1,ISDUM2,2,IFAIL1) ELSEIF(IPROC.EQ.-98)THEN CALL MATIN1(NINT(ARG(1)),NINT(ARG(2)),1,ARG(3),ARG(4), - ISDUM1,ISDUM2,3,IFAIL1) ELSEIF(IPROC.EQ.-99)THEN CALL MATIN1(NINT(ARG(1)),NINT(ARG(2)),1,ARG(3),ARG(4), - ISDUM1,ISDUM2,4,IFAIL1) ENDIF MODARG(4)=2 * Check the error condition. IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! MATCAL WARNING : INTERPOLATE_n did'// - ' not work correctly; no interpolation.' RETURN ENDIF *** Plot an error band. ELSEIF(IPROC.EQ.-101)THEN * Check number of arguments. IF(NARG.NE.3.OR.MODARG(1).NE.5.OR.MODARG(2).NE.5.OR. - MODARG(3).NE.5)THEN PRINT *,' !!!!!! MATCAL WARNING : Incorrect set of'// - ' arguments for ERROR_BAND.' RETURN ENDIF * Switch to graphics screen. CALL GRGRAF(.FALSE.) * Plot the error band. CALL MATBND(NINT(ARG(1)),NINT(ARG(2)),NINT(ARG(3))) * Switch back to alphanumeric screen. CALL GRALPH *** Find zeroes of a matrix vs another matrix. ELSEIF(IPROC.EQ.-102)THEN * Check the arguments. IWRONG=0 DO 240 I=4,NARG IF(ARGREF(I,1).GE.2)IWRONG=IWRONG+1 240 CONTINUE IF(NARG.LT.3.OR.MODARG(1).NE.5.OR.MODARG(2).NE.5.OR. - ARGREF(3,1).GE.2.OR.IWRONG.GT.0)THEN PRINT *,' !!!!!! MATCAL WARNING : Incorrect set of'// - ' arguments for ZEROES; no zero search.' RETURN ENDIF * Get the zero crossings. CALL MATZRO(NINT(ARG(1)),NINT(ARG(2)),NZERO,ZERO,IFAIL1) ARG(3)=REAL(NZERO) MODARG(3)=2 DO 190 I=4,MXARG CALL ALGREU(NINT(ARG(I)),MODARG(I),ARGREF(I,1)) IF(I-3.LE.NZERO)THEN ARG(I)=ZERO(I-3) MODARG(I)=2 ELSE ARG(I)=0 MODARG(I)=0 ENDIF 190 CONTINUE *** Unknown matrix operation. ELSE PRINT *,' !!!!!! MATCAL WARNING : Unknown procedure code'// - ' received; nothing done.' IFAIL=1 RETURN ENDIF *** Seems to have worked. IFAIL=0 END +DECK,MATCHS. SUBROUTINE MATCHS(IREF,NDIM,IDIM,PAD,IFAIL) *----------------------------------------------------------------------- * MATCHS - Changes the format of a matrix. * (Last changed on 10/ 4/96.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,MATDATA. +SEQ,PRINTPLOT. INTEGER IREF,IREFN,NDIM,IDIM(*),IFAIL,ISLOT,ISLOTN,MATSLT,IMOD REAL PAD EXTERNAL MATSLT *** Identify the routine if requested. IF(LIDENT)PRINT *,' /// ROUTINE MATCHS ///' *** Debugging information. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MATCHS DEBUG : Changing '', - I5,'' to '',I5,'' dimensions, pad='',E12.5)') - IREF,NDIM,PAD *** Initial value of the failure flag. IFAIL=1 *** Check validity of reference. IF(IREF.LE.0)THEN PRINT *,' !!!!!! MATCHS WARNING : Non-positive reference'// - ' given; matrix not re-shaped.' RETURN ENDIF *** Find the mode of the current matrix. ISLOT=MATSLT(IREF) IF(ISLOT.LE.0)THEN PRINT *,' !!!!!! MATCHS WARNING : Matrix to be re-shaped'// - ' has not been found.' RETURN ENDIF IMOD=MMOD(ISLOT) *** Allocate space for the new matrix. CALL MATADM('ALLOCATE',IREFN,NDIM,IDIM,IMOD,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! MATCHS WARNING : Unable to allocate'// - ' space for the re-shaped matrix ; not re-shaped.' RETURN ENDIF *** Locate the current matrix. ISLOT=MATSLT(IREF) IF(ISLOT.LE.0)THEN PRINT *,' !!!!!! MATCHS WARNING : Matrix to be re-shaped'// - ' has not been found.' RETURN ENDIF *** Find where the new matrix sits. ISLOTN=MATSLT(IREFN) IF(ISLOTN.LE.0)THEN PRINT *,' !!!!!! MATCHS WARNING : New matrix not found;'// - ' program bug - please report.' RETURN ENDIF *** Copy the old matrix to the new one. DO 60 I=1,MIN(MLEN(ISLOT),MLEN(ISLOTN)) MVEC(MORG(ISLOTN)+I)=MVEC(MORG(ISLOT)+I) 60 CONTINUE DO 70 I=MLEN(ISLOT)+1,MLEN(ISLOTN) MVEC(MORG(ISLOTN)+I)=PAD 70 CONTINUE *** Modify the pointer information. MREF(ISLOTN)=MREF(ISLOT) *** Delete the old matrix. MREF(ISLOT)=0 *** Things seem to have worked. IFAIL=0 END +DECK,MATDER. SUBROUTINE MATDER(IRX,IRY,XINT,DERIV,OPTION,IFAIL) *----------------------------------------------------------------------- * MATDER - Computes a numerical derivative of one vector interpolated * vs another vector. * (Last changed on 8/ 5/96.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,MATDATA. +SEQ,PRINTPLOT. REAL F1,F2,FM,EPS,EPSMAX,DELTA,XINT,DERIV,DIVDIF INTEGER I,N,ITER,NITMAX,INIT,IORD,IRX,IRY,MATSLT,MATADR,IFAIL CHARACTER*(*) OPTION EXTERNAL DIVDIF,MATSLT,MATADR +SELF,IF=SAVE. SAVE INIT,NITMAX,DELTA +SELF. *** Identify the routine if requested. IF(LIDENT)PRINT *,' /// ROUTINE MATDER ///' *** Preset the IFAIL flag. IFAIL=1 *** Decode the option string. IORD=2 IF(INDEX(OPTION,'LINEAR').NE.0)THEN IORD=1 ELSEIF(INDEX(OPTION,'PARABOLIC')+ - INDEX(OPTION,'QUADRATIC').NE.0)THEN IORD=2 ELSEIF(INDEX(OPTION,'CUBIC').NE.0)THEN IORD=3 ENDIF *** Locate the matrices. ISX=MATSLT(IRX) ISY=MATSLT(IRY) IF(ISX.LE.0.OR.ISY.LE.0)THEN PRINT *,' !!!!!! MATDER WARNING : Unable to find an'// - ' input vector; no derivative.' RETURN ENDIF IF(MDIM(ISX).NE.1.OR.MDIM(ISY).NE.1.OR. - MLEN(ISX).NE.MLEN(ISY).OR. - MLEN(ISX).LT.IORD+1.OR. - MLEN(ISY).LT.IORD+1)THEN PRINT *,' !!!!!! MATDER WARNING : Input matrices not'// - ' 1D, not same length or too short; no derivative.' RETURN ENDIF N=MIN(MLEN(ISX),MLEN(ISY)) *** Debugging output. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MATDER DEBUG : x='',I5, - '', y='',I5,'' length='',I5,'' order='',I5)') IRX,IRY,N,IORD *** Check proper sequence. DO 100 I=1,N-1 IF(MVEC(MORG(ISX)+I).GE.MVEC(MORG(ISX)+I+1))THEN PRINT *,' !!!!!! MATDER WARNING : Ordinates not ordered'// - ' ; no derivative calculated.' RETURN ENDIF 100 CONTINUE *** Initialise delta. DATA INIT/0/ IF(INIT.EQ.0)THEN * Set number of iterations. NITMAX=50 * Compute DELTA. DELTA=1 ITER=0 10 CONTINUE ITER=ITER+1 IF(1+DELTA.GT.1)THEN DELTA=DELTA/2 IF(ITER.LE.NITMAX)GOTO 10 DELTA=1E-8 ENDIF DELTA=SQRT(DELTA) * Initialisation done. INIT=1 * Debugging output. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MATDER DEBUG :'', - '' Delta='',E12.5,'', Iter max='',I5)') DELTA,NITMAX ENDIF *** Find minimum and maximum value for EPS. DO 20 I=1,N-1 * Intermediate points. IF((MVEC(MORG(ISX)+I)-XINT)*(XINT-MVEC(MORG(ISX)+I+1)).GE.0)THEN EPSMAX=MAX(DELTA,ABS(XINT-MVEC(MORG(ISX)+I)), - ABS(XINT-MVEC(MORG(ISX)+I+1))) GOTO 30 ENDIF 20 CONTINUE * External points. IF(XINT.LT.MVEC(MORG(ISX)+1))THEN EPSMAX=MAX(DELTA,2*ABS(XINT-MVEC(MORG(ISX)+1))) ELSE EPSMAX=MAX(DELTA,2*ABS(XINT-MVEC(MORG(ISX)+N))) ENDIF 30 CONTINUE *** Iterate to find the proper value for EPS, starting values. FM=DIVDIF(MVEC(MORG(ISY)+1),MVEC(MORG(ISX)+1),N,XINT,IORD) EPS=DELTA*(1+ABS(XINT)) ITER=0 * Loop. 40 CONTINUE * Increment iteration counter to avoid endless loops. ITER=ITER+1 * Compute function values at x +/- eps. F1=DIVDIF(MVEC(MORG(ISY)+1),MVEC(MORG(ISX)+1),N,XINT+EPS,IORD) F2=DIVDIF(MVEC(MORG(ISY)+1),MVEC(MORG(ISX)+1),N,XINT-EPS,IORD) * Update EPS accordingly. IF(ITER.GT.NITMAX)THEN GOTO 50 ELSEIF(ABS(F1-F2).GT.5*DELTA*MAX(ABS(F1),ABS(FM),ABS(F2)))THEN EPS=EPS/2 IF(EPS.GT.EPSMAX)GOTO 50 ELSEIF(ABS(F1-F2).LT.DELTA*MAX(ABS(F1),ABS(FM),ABS(F2))/5)THEN EPS=2*EPS ELSE GOTO 50 ENDIF GOTO 40 50 CONTINUE *** Set the derivative. DERIV=(F1-F2)/(2*EPS) *** Debugging output. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MATDER DEBUG : For x='', - E12.5,'' found dy='',E12.5)') XINT,DERIV *** Seems to have worked. IFAIL=0 END +DECK,MATERR. SUBROUTINE MATERR(IRX,IRY,IREX1,IREY1,IREX2,IREY2,TYPE,SIZE) *----------------------------------------------------------------------- * MATERR - Plots error bars. * (Last changed on 19/ 7/97.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,MATDATA. +SEQ,PRINTPLOT. +SEQ,CONSTANTS. REAL X0,X1,X2,Y0,Y1,Y2,SIZE,XPL(80),YPL(80),STFACT,XC,YC, - EX1,EY1,EX2,EY2 INTEGER IRX,IRY,IREX1,IREY1,IREX2,IREY2,I,J,NPOINT, - ISX,ISY,ISEX1,ISEY1,ISEX2,ISEY2,MATSLT,IERR,NT CHARACTER*(*) TYPE EXTERNAL MATSLT *** Locate the matrices. ISX=MATSLT(IRX) ISY=MATSLT(IRY) ISEX1=MATSLT(IREX1) ISEY1=MATSLT(IREY1) ISEX2=MATSLT(IREX2) ISEY2=MATSLT(IREY2) *** Determine current NT. CALL GQCNTN(IERR,NT) IF(IERR.NE.0)THEN PRINT *,' !!!!!! MATERR WARNING : Error from'// - ' GQCNTN, code=',IERR,'; no error bars plotted.' RETURN ENDIF *** Make sure that the marker type makes sense. IF(INDEX(TYPE,'CIRCLE')+INDEX(TYPE,'SQUARE')+ - INDEX(TYPE,'CROSS')+INDEX(TYPE,'PLUS')+ - INDEX(TYPE,'ELLIPSE')+INDEX(TYPE,'TRIANGLE')+ - INDEX(TYPE,'STAR')+INDEX(TYPE,'DAVID')+ - INDEX(TYPE,'HEXAGON').EQ.0)THEN PRINT *,' !!!!!! MATERR WARNING : Error bar model ', - TYPE,' not known ; no error bars plotted.' RETURN ENDIF *** Check the size of the markers. IF(SIZE.LE.0.OR.SIZE.GT.1.0)THEN PRINT *,' !!!!!! MATERR WARNING : Error bar size is'// - ' out of range [0,1] ; no error bars plotted.' RETURN ENDIF *** Set the appropriate representations. CALL GRATTS('ERROR-BAR','POLYLINE') CALL GRATTS('ERROR-BAR','AREA') *** Loop over the points. DO 10 I=1,MLEN(ISX) ** Translate the various reference points into NDC. XC=0 YC=0 EX1=0 EY1=0 EX2=0 EY2=0 IF(ISX.GT.0)XC=MVEC(MORG(ISX)+I) IF(ISY.GT.0)YC=MVEC(MORG(ISY)+I) IF(ISEX1.GT.0)EX1=MVEC(MORG(ISEX1)+I) IF(ISEY1.GT.0)EY1=MVEC(MORG(ISEY1)+I) IF(ISEX2.GT.0)EX2=MVEC(MORG(ISEX2)+I) IF(ISEY2.GT.0)EY2=MVEC(MORG(ISEY2)+I) CALL GRWCNC(XC,YC,X0,Y0) CALL GRWCNC(XC-ABS(EX1),YC-ABS(EY1),X1,Y1) CALL GRWCNC(XC+ABS(EX2),YC+ABS(EY2),X2,Y2) ** Move to NDC coordinates. CALL GSELNT(0) ** Error bar type CIRCLE and SQUARE. IF(INDEX(TYPE,'CIRCLE')+INDEX(TYPE,'SQUARE').NE.0)THEN * Plot the marker. IF(INDEX(TYPE,'CIRCLE').NE.0)THEN DO 20 J=1,20 XPL(J)=X0+COS(2*PI*REAL(J-1)/19.0)*SIZE YPL(J)=Y0+SIN(2*PI*REAL(J-1)/19.0)*SIZE 20 CONTINUE CALL GFA(20,XPL,YPL) CALL GPL(20,XPL,YPL) ELSE XPL(1)=X0-SIZE YPL(1)=Y0-SIZE XPL(2)=X0+SIZE YPL(2)=Y0-SIZE XPL(3)=X0+SIZE YPL(3)=Y0+SIZE XPL(4)=X0-SIZE YPL(4)=Y0+SIZE XPL(5)=X0-SIZE YPL(5)=Y0-SIZE CALL GFA(5,XPL,YPL) CALL GPL(5,XPL,YPL) ENDIF * Plot the error bars. IF(X1.LE.X0-SIZE)THEN XPL(1)=X1 XPL(2)=X0-SIZE YPL(1)=Y0 YPL(2)=Y0 CALL GPL(2,XPL,YPL) XPL(1)=X1 XPL(2)=X1 YPL(1)=Y0-SIZE YPL(2)=Y0+SIZE CALL GPL(2,XPL,YPL) ENDIF IF(X2.GE.X0+SIZE)THEN XPL(1)=X2 XPL(2)=X0+SIZE YPL(1)=Y0 YPL(2)=Y0 CALL GPL(2,XPL,YPL) XPL(1)=X2 XPL(2)=X2 YPL(1)=Y0-SIZE YPL(2)=Y0+SIZE CALL GPL(2,XPL,YPL) ENDIF IF(Y1.LE.Y0-SIZE)THEN XPL(1)=X0 XPL(2)=X0 YPL(1)=Y1 YPL(2)=Y0-SIZE CALL GPL(2,XPL,YPL) XPL(1)=X0-SIZE XPL(2)=X0+SIZE YPL(1)=Y1 YPL(2)=Y1 CALL GPL(2,XPL,YPL) ENDIF IF(Y2.GE.Y0+SIZE)THEN XPL(1)=X0 XPL(2)=X0 YPL(1)=Y2 YPL(2)=Y0+SIZE CALL GPL(2,XPL,YPL) XPL(1)=X0-SIZE XPL(2)=X0+SIZE YPL(1)=Y2 YPL(2)=Y2 CALL GPL(2,XPL,YPL) ENDIF ** ELLIPSE shaped error bars. ELSEIF(INDEX(TYPE,'ELLIPSE').NE.0)THEN DO 30 J=1,20 XPL(J)=X0+(X2-X0)*COS(PI*REAL(J-1)/38.0) YPL(J)=Y0+(Y2-Y0)*SIN(PI*REAL(J-1)/38.0) 30 CONTINUE DO 40 J=1,20 XPL(20+J)=X0-(X1-X0)*COS(PI/2+PI*REAL(J-1)/38.0) YPL(20+J)=Y0+(Y2-Y0)*SIN(PI/2+PI*REAL(J-1)/38.0) 40 CONTINUE DO 50 J=1,20 XPL(40+J)=X0-(X1-X0)*COS(PI+PI*REAL(J-1)/38.0) YPL(40+J)=Y0-(Y1-Y0)*SIN(PI+PI*REAL(J-1)/38.0) 50 CONTINUE DO 60 J=1,20 XPL(60+J)=X0+(X2-X0)*COS(3*PI/2+PI*REAL(J-1)/38.0) YPL(60+J)=Y0-(Y1-Y0)*SIN(3*PI/2+PI*REAL(J-1)/38.0) 60 CONTINUE CALL GFA(80,XPL,YPL) CALL GPL(80,XPL,YPL) ** CROSS and PLUS shaped error bars. ELSEIF(INDEX(TYPE,'CROSS')+INDEX(TYPE,'PLUS').NE.0)THEN * Plot the marker. IF(INDEX(TYPE,'CROSS').NE.0)THEN XPL(1)=X0-SIZE YPL(1)=Y0-SIZE XPL(2)=X0+SIZE YPL(2)=Y0+SIZE CALL GPL(2,XPL,YPL) XPL(1)=X0-SIZE YPL(1)=Y0+SIZE XPL(2)=X0+SIZE YPL(2)=Y0-SIZE CALL GPL(2,XPL,YPL) ENDIF * Plot the error bars. XPL(1)=X1 YPL(1)=Y0 XPL(2)=X2 YPL(2)=Y0 CALL GPL(2,XPL,YPL) XPL(1)=X0-SIZE YPL(1)=Y1 XPL(2)=X0+SIZE YPL(2)=Y1 CALL GPL(2,XPL,YPL) XPL(1)=X0-SIZE YPL(1)=Y2 XPL(2)=X0+SIZE YPL(2)=Y2 CALL GPL(2,XPL,YPL) XPL(1)=X0 YPL(1)=Y1 XPL(2)=X0 YPL(2)=Y2 CALL GPL(2,XPL,YPL) XPL(1)=X1 YPL(1)=Y0-SIZE XPL(2)=X1 YPL(2)=Y0+SIZE CALL GPL(2,XPL,YPL) XPL(1)=X2 YPL(1)=Y0-SIZE XPL(2)=X2 YPL(2)=Y0+SIZE CALL GPL(2,XPL,YPL) ** Error bar of type HEXAGON. ELSEIF(INDEX(TYPE,'HEXAGON').NE.0)THEN * Plot the marker. XPL(1)=X0+SIZE*0.5*SQRT(3.0) YPL(1)=Y0+SIZE*0.5 XPL(2)=X0 YPL(2)=Y0+SIZE XPL(3)=X0-SIZE*0.5*SQRT(3.0) YPL(3)=Y0+SIZE*0.5 XPL(4)=X0-SIZE*0.5*SQRT(3.0) YPL(4)=Y0-SIZE*0.5 XPL(5)=X0 YPL(5)=Y0-SIZE XPL(6)=X0+SIZE*0.5*SQRT(3.0) YPL(6)=Y0-SIZE*0.5 XPL(7)=XPL(1) YPL(7)=YPL(1) CALL GFA(7,XPL,YPL) CALL GPL(7,XPL,YPL) * Plot the error bars. IF(X1.LE.X0-0.5*SQRT(3.0)*SIZE)THEN XPL(1)=X1 XPL(2)=X0-0.5*SQRT(3.0)*SIZE YPL(1)=Y0 YPL(2)=Y0 CALL GPL(2,XPL,YPL) XPL(1)=X1 XPL(2)=X1 YPL(1)=Y0-SIZE YPL(2)=Y0+SIZE CALL GPL(2,XPL,YPL) ENDIF IF(X2.GE.X0+0.5*SQRT(3.0)*SIZE)THEN XPL(1)=X2 XPL(2)=X0+0.5*SQRT(3.0)*SIZE YPL(1)=Y0 YPL(2)=Y0 CALL GPL(2,XPL,YPL) XPL(1)=X2 XPL(2)=X2 YPL(1)=Y0-SIZE YPL(2)=Y0+SIZE CALL GPL(2,XPL,YPL) ENDIF IF(Y1.LE.Y0-SIZE)THEN XPL(1)=X0 XPL(2)=X0 YPL(1)=Y1 YPL(2)=Y0-SIZE CALL GPL(2,XPL,YPL) XPL(1)=X0-SIZE XPL(2)=X0+SIZE YPL(1)=Y1 YPL(2)=Y1 CALL GPL(2,XPL,YPL) ENDIF IF(Y2.GE.Y0+SIZE)THEN XPL(1)=X0 XPL(2)=X0 YPL(1)=Y2 YPL(2)=Y0+SIZE CALL GPL(2,XPL,YPL) XPL(1)=X0-SIZE XPL(2)=X0+SIZE YPL(1)=Y2 YPL(2)=Y2 CALL GPL(2,XPL,YPL) ENDIF ** Error bar type RIGHT-TRIANGLE. ELSEIF(INDEX(TYPE,'RIGHT-TRIANGLE')+ - INDEX(TYPE,'TRIANGLE-RIGHT')+ - INDEX(TYPE,'EAST-TRIANGLE')+ - INDEX(TYPE,'TRIANGLE-EAST')+ - INDEX(TYPE,'E-TRIANGLE')+ - INDEX(TYPE,'TRIANGLE-E').NE.0)THEN * Plot the marker. XPL(1)=X0+SIZE YPL(1)=Y0 XPL(2)=X0-0.5*SIZE YPL(2)=Y0+0.5*SQRT(3.0)*SIZE XPL(3)=X0-0.5*SIZE YPL(3)=Y0-0.5*SQRT(3.0)*SIZE XPL(4)=XPL(1) YPL(4)=YPL(1) CALL GFA(4,XPL,YPL) CALL GPL(4,XPL,YPL) * Plot the error bars. IF(X1.LE.X0-0.5*SIZE)THEN XPL(1)=X1 XPL(2)=X0-0.5*SIZE YPL(1)=Y0 YPL(2)=Y0 CALL GPL(2,XPL,YPL) XPL(1)=X1 XPL(2)=X1 YPL(1)=Y0-SIZE YPL(2)=Y0+SIZE CALL GPL(2,XPL,YPL) ENDIF IF(X2.GE.X0+SIZE)THEN XPL(1)=X2 XPL(2)=X0+SIZE YPL(1)=Y0 YPL(2)=Y0 CALL GPL(2,XPL,YPL) XPL(1)=X2 XPL(2)=X2 YPL(1)=Y0-SIZE YPL(2)=Y0+SIZE CALL GPL(2,XPL,YPL) ENDIF IF(Y1.LE.Y0-SIZE)THEN XPL(1)=X0 XPL(2)=X0 YPL(1)=Y1 YPL(2)=Y0-SIZE/SQRT(3.0) CALL GPL(2,XPL,YPL) XPL(1)=X0-SIZE XPL(2)=X0+SIZE YPL(1)=Y1 YPL(2)=Y1 CALL GPL(2,XPL,YPL) ENDIF IF(Y2.GE.Y0+SIZE)THEN XPL(1)=X0 XPL(2)=X0 YPL(1)=Y2 YPL(2)=Y0+SIZE/SQRT(3.0) CALL GPL(2,XPL,YPL) XPL(1)=X0-SIZE XPL(2)=X0+SIZE YPL(1)=Y2 YPL(2)=Y2 CALL GPL(2,XPL,YPL) ENDIF ** Error bar type LEFT-TRIANGLE. ELSEIF(INDEX(TYPE,'LEFT-TRIANGLE')+ - INDEX(TYPE,'TRIANGLE-LEFT')+ - INDEX(TYPE,'WEST-TRIANGLE')+ - INDEX(TYPE,'TRIANGLE-WEST')+ - INDEX(TYPE,'W-TRIANGLE')+ - INDEX(TYPE,'TRIANGLE-W').NE.0)THEN * Plot the marker. XPL(1)=X0-SIZE YPL(1)=Y0 XPL(2)=X0+0.5*SIZE YPL(2)=Y0+0.5*SQRT(3.0)*SIZE XPL(3)=X0+0.5*SIZE YPL(3)=Y0-0.5*SQRT(3.0)*SIZE XPL(4)=XPL(1) YPL(4)=YPL(1) CALL GFA(4,XPL,YPL) CALL GPL(4,XPL,YPL) * Plot the error bars. IF(X1.LE.X0-SIZE)THEN XPL(1)=X1 XPL(2)=X0-SIZE YPL(1)=Y0 YPL(2)=Y0 CALL GPL(2,XPL,YPL) XPL(1)=X1 XPL(2)=X1 YPL(1)=Y0-SIZE YPL(2)=Y0+SIZE CALL GPL(2,XPL,YPL) ENDIF IF(X2.GE.X0+0.5*SIZE)THEN XPL(1)=X2 XPL(2)=X0+0.5*SIZE YPL(1)=Y0 YPL(2)=Y0 CALL GPL(2,XPL,YPL) XPL(1)=X2 XPL(2)=X2 YPL(1)=Y0-SIZE YPL(2)=Y0+SIZE CALL GPL(2,XPL,YPL) ENDIF IF(Y1.LE.Y0-SIZE)THEN XPL(1)=X0 XPL(2)=X0 YPL(1)=Y1 YPL(2)=Y0-SIZE/SQRT(3.0) CALL GPL(2,XPL,YPL) XPL(1)=X0-SIZE XPL(2)=X0+SIZE YPL(1)=Y1 YPL(2)=Y1 CALL GPL(2,XPL,YPL) ENDIF IF(Y2.GE.Y0+SIZE)THEN XPL(1)=X0 XPL(2)=X0 YPL(1)=Y2 YPL(2)=Y0+SIZE/SQRT(3.0) CALL GPL(2,XPL,YPL) XPL(1)=X0-SIZE XPL(2)=X0+SIZE YPL(1)=Y2 YPL(2)=Y2 CALL GPL(2,XPL,YPL) ENDIF ** Error bar type DOWN-TRIANGLE. ELSEIF(INDEX(TYPE,'DOWN-TRIANGLE')+ - INDEX(TYPE,'TRIANGLE-DOWN')+ - INDEX(TYPE,'SOUTH-TRIANGLE')+ - INDEX(TYPE,'TRIANGLE-SOUTH')+ - INDEX(TYPE,'S-TRIANGLE')+ - INDEX(TYPE,'TRIANGLE-S').NE.0)THEN * Plot the marker. XPL(1)=X0 YPL(1)=Y0-SIZE XPL(2)=X0+0.5*SQRT(3.0)*SIZE YPL(2)=Y0+0.5*SIZE XPL(3)=X0-0.5*SQRT(3.0)*SIZE YPL(3)=Y0+0.5*SIZE XPL(4)=XPL(1) YPL(4)=YPL(1) CALL GFA(4,XPL,YPL) CALL GPL(4,XPL,YPL) * Plot the error bars. IF(X1.LE.X0-SIZE)THEN XPL(1)=X1 XPL(2)=X0-SIZE/SQRT(3.0) YPL(1)=Y0 YPL(2)=Y0 CALL GPL(2,XPL,YPL) XPL(1)=X1 XPL(2)=X1 YPL(1)=Y0-SIZE YPL(2)=Y0+SIZE CALL GPL(2,XPL,YPL) ENDIF IF(X2.GE.X0+SIZE)THEN XPL(1)=X2 XPL(2)=X0+SIZE/SQRT(3.0) YPL(1)=Y0 YPL(2)=Y0 CALL GPL(2,XPL,YPL) XPL(1)=X2 XPL(2)=X2 YPL(1)=Y0-SIZE YPL(2)=Y0+SIZE CALL GPL(2,XPL,YPL) ENDIF IF(Y1.LE.Y0-SIZE)THEN XPL(1)=X0 XPL(2)=X0 YPL(1)=Y1 YPL(2)=Y0-SIZE CALL GPL(2,XPL,YPL) XPL(1)=X0-SIZE XPL(2)=X0+SIZE YPL(1)=Y1 YPL(2)=Y1 CALL GPL(2,XPL,YPL) ENDIF IF(Y2.GE.Y0+0.5*SIZE)THEN XPL(1)=X0 XPL(2)=X0 YPL(1)=Y2 YPL(2)=Y0+0.5*SIZE CALL GPL(2,XPL,YPL) XPL(1)=X0-SIZE XPL(2)=X0+SIZE YPL(1)=Y2 YPL(2)=Y2 CALL GPL(2,XPL,YPL) ENDIF ** Error bar type UP-TRIANGLE. ELSEIF(INDEX(TYPE,'TRIANGLE').NE.0)THEN * Plot the marker. XPL(1)=X0 YPL(1)=Y0+SIZE XPL(2)=X0+0.5*SQRT(3.0)*SIZE YPL(2)=Y0-0.5*SIZE XPL(3)=X0-0.5*SQRT(3.0)*SIZE YPL(3)=Y0-0.5*SIZE XPL(4)=XPL(1) YPL(4)=YPL(1) CALL GFA(4,XPL,YPL) CALL GPL(4,XPL,YPL) * Plot the error bars. IF(X1.LE.X0-SIZE)THEN XPL(1)=X1 XPL(2)=X0-SIZE/SQRT(3.0) YPL(1)=Y0 YPL(2)=Y0 CALL GPL(2,XPL,YPL) XPL(1)=X1 XPL(2)=X1 YPL(1)=Y0-SIZE YPL(2)=Y0+SIZE CALL GPL(2,XPL,YPL) ENDIF IF(X2.GE.X0+SIZE)THEN XPL(1)=X2 XPL(2)=X0+SIZE/SQRT(3.0) YPL(1)=Y0 YPL(2)=Y0 CALL GPL(2,XPL,YPL) XPL(1)=X2 XPL(2)=X2 YPL(1)=Y0-SIZE YPL(2)=Y0+SIZE CALL GPL(2,XPL,YPL) ENDIF IF(Y1.LE.Y0-SIZE)THEN XPL(1)=X0 XPL(2)=X0 YPL(1)=Y1 YPL(2)=Y0-0.5*SIZE CALL GPL(2,XPL,YPL) XPL(1)=X0-SIZE XPL(2)=X0+SIZE YPL(1)=Y1 YPL(2)=Y1 CALL GPL(2,XPL,YPL) ENDIF IF(Y2.GE.Y0+0.5*SIZE)THEN XPL(1)=X0 XPL(2)=X0 YPL(1)=Y2 YPL(2)=Y0+SIZE CALL GPL(2,XPL,YPL) XPL(1)=X0-SIZE XPL(2)=X0+SIZE YPL(1)=Y2 YPL(2)=Y2 CALL GPL(2,XPL,YPL) ENDIF ** Error bar of type STAR. ELSEIF(INDEX(TYPE,'STAR')+INDEX(TYPE,'DAVID').NE.0)THEN * Plot the marker. IF(INDEX(TYPE,'4-STAR').NE.0)THEN NPOINT=8 STFACT=0.3 ELSEIF(INDEX(TYPE,'6-STAR').NE.0)THEN NPOINT=12 STFACT=0.3 ELSEIF(INDEX(TYPE,'DAVID').NE.0)THEN NPOINT=12 STFACT=0.5/COS(PI/6) ELSEIF(INDEX(TYPE,'8-STAR').NE.0)THEN NPOINT=16 STFACT=0.3 ELSEIF(INDEX(TYPE,'10-STAR').NE.0)THEN NPOINT=20 STFACT=0.3 ELSE NPOINT=12 STFACT=0.3 ENDIF DO 70 J=1,NPOINT IF(J.EQ.2*(J/2))THEN XPL(J)=X0+SIZE*COS(2*PI*J/REAL(NPOINT)) YPL(J)=Y0+SIZE*SIN(2*PI*J/REAL(NPOINT)) ELSE XPL(J)=X0+STFACT*SIZE*COS(2*PI*J/REAL(NPOINT)) YPL(J)=Y0+STFACT*SIZE*SIN(2*PI*J/REAL(NPOINT)) ENDIF 70 CONTINUE XPL(NPOINT+1)=XPL(1) YPL(NPOINT+1)=YPL(1) CALL GFA(NPOINT+1,XPL,YPL) CALL GPL(NPOINT+1,XPL,YPL) * Plot the error bars. IF(X1.LE.X0-SIZE)THEN XPL(1)=X1 XPL(2)=X0-SIZE YPL(1)=Y0 YPL(2)=Y0 CALL GPL(2,XPL,YPL) XPL(1)=X1 XPL(2)=X1 YPL(1)=Y0-SIZE YPL(2)=Y0+SIZE CALL GPL(2,XPL,YPL) ENDIF IF(X2.GE.X0+SIZE)THEN XPL(1)=X2 XPL(2)=X0+SIZE YPL(1)=Y0 YPL(2)=Y0 CALL GPL(2,XPL,YPL) XPL(1)=X2 XPL(2)=X2 YPL(1)=Y0-SIZE YPL(2)=Y0+SIZE CALL GPL(2,XPL,YPL) ENDIF IF(Y1.LE.Y0-SIZE)THEN XPL(1)=X0 XPL(2)=X0 YPL(1)=Y1 IF(NPOINT.EQ.8*(NPOINT/8))THEN YPL(2)=Y0-SIZE ELSE YPL(2)=Y0-STFACT*SIZE ENDIF CALL GPL(2,XPL,YPL) XPL(1)=X0-SIZE XPL(2)=X0+SIZE YPL(1)=Y1 YPL(2)=Y1 CALL GPL(2,XPL,YPL) ENDIF IF(Y2.GE.Y0+SIZE)THEN XPL(1)=X0 XPL(2)=X0 YPL(1)=Y2 IF(NPOINT.EQ.8*(NPOINT/8))THEN YPL(2)=Y0+SIZE ELSE YPL(2)=Y0+STFACT*SIZE ENDIF CALL GPL(2,XPL,YPL) XPL(1)=X0-SIZE XPL(2)=X0+SIZE YPL(1)=Y2 YPL(2)=Y2 CALL GPL(2,XPL,YPL) ENDIF ** Unknown marker type. ELSE PRINT *,' !!!!!! MATERR WARNING : Marker type not'// - ' recognised; no markers plotted.' ENDIF ** Move to the original normalisation transformation. CALL GSELNT(NT) ** Next point. 10 CONTINUE END +DECK,MATEXT. SUBROUTINE MATEXT(IRX,IRF,XEXT,OPTION,EEPSX,EEPSF,NITMAX,IFAIL) *----------------------------------------------------------------------- * MATEXT - Searches for extrema of a matrix interpolation. * VARIABLES : * (Last changed on 15/10/01.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,GLOBALS. +SEQ,MATDATA. +SEQ,PRINTPLOT. CHARACTER*(*) OPTION CHARACTER*20 AUX1,AUX2 CHARACTER*10 NAMEX,NAMEF INTEGER NC,MODSAV,NITMAX,IFAIL,I,NRNDM, - NC1,NC2,MATSLT,IRX,IRF,ISX,ISF,IORDER REAL XMIN,XMAX,RNDUNI,XPL(MXLIST),YPL(MXLIST), - EEPSX,EEPSF,XEXT,DIVDIF DOUBLE PRECISION X1,X2,X3,F1,F2,F3,XPARA,FPARA,EPSX,EPSF,FTRY, - XTRY,FMIN,FMAX LOGICAL SET1,SET2,SET3,LPRINT,LPLOT,SMIN,SMAX,SKIP EXTERNAL RNDUNI,MATSLT,DIVDIF *** Identification. IF(LIDENT)PRINT *,' /// ROUTINE MATEXT ///' *** Assume this will not work. IFAIL=1 *** Find the matrices. ISX=MATSLT(IRX) ISF=MATSLT(IRF) * Ensure they both exist. IF(ISX.EQ.0.OR.ISF.EQ.0)THEN PRINT *,' !!!!!! MATEXT WARNING : Ordinate or function'// - ' matrix not found; no extremum search.' RETURN * The matrices must have the same size > 1. ELSEIF(MLEN(ISX).NE.MLEN(ISF))THEN PRINT *,' !!!!!! MATEXT WARNING : Ordinate and function'// - ' matrices have different length; no extremum search.' RETURN ELSEIF(MLEN(ISX).LE.1)THEN PRINT *,' !!!!!! MATEXT WARNING : Ordinate and function'// - ' matrices have length<2; no extremum search.' RETURN * The matrices must be 1-dimensional. ELSEIF(MDIM(ISX).NE.1)THEN PRINT *,' !!!!!! MATEXT WARNING : Ordinate or function'// - ' matrix not 1-dimensional; no extremum search.' RETURN ENDIF *** Verify that the ordinate matrix is well ordered. IF(MVEC(MORG(ISX)+2).GT.MVEC(MORG(ISX)+1))THEN DO 40 I=2,MLEN(ISX) IF(MVEC(MORG(ISX)+I).LE.MVEC(MORG(ISX)+I-1))THEN PRINT *,' !!!!!! MATEXT WARNING : The ordinate'// - ' vector is not strictly ordered; no extremum'// - ' search.' RETURN ENDIF 40 CONTINUE ELSEIF(MVEC(MORG(ISX)+2).LT.MVEC(MORG(ISX)+1))THEN DO 50 I=2,MLEN(ISX) IF(MVEC(MORG(ISX)+I).GE.MVEC(MORG(ISX)+I-1))THEN PRINT *,' !!!!!! MATEXT WARNING : The ordinate'// - ' vector is not strictly ordered; no extremum'// - ' search.' RETURN ENDIF 50 CONTINUE ELSE PRINT *,' !!!!!! MATEXT WARNING : The ordinate vector'// - ' is not strictly ordered; no extremum search.' RETURN ENDIF *** 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 IORDER=MIN(2,MLEN(ISX)) IF(INDEX(OPTION,'LINEAR').NE.0)THEN IORDER=1 ELSEIF(INDEX(OPTION,'QUAD').NE.0)THEN IF(MLEN(ISX).LT.3)THEN PRINT *,' !!!!!! MATEXT WARNING : Vectors are too'// - ' short for quadratic interpolation; no'// - ' extremum search.' RETURN ELSE IORDER=2 ENDIF ELSEIF(INDEX(OPTION,'CUBIC').NE.0)THEN IF(MLEN(ISX).LT.4)THEN PRINT *,' !!!!!! MATEXT WARNING : Vectors are too'// - ' short for cubic interpolation; no extremum'// - ' search.' RETURN ELSE IORDER=3 ENDIF ENDIF *** Set the range. XMIN=MVEC(MORG(ISX)+1) XMAX=MVEC(MORG(ISX)+MLEN(ISX)) *** Accuracy settings. EPSX=DBLE(EEPSX) EPSF=DBLE(EEPSF) NRNDM=100 *** Debugging output. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MATEXT DEBUG : '', - ''Ordinate and function vectors: '',I5,1X,I5/26X, - ''Interpolation order: '',I5/26X, - ''Range to be searched: '',2E15.8/26X, - ''Minimum / Maximum: '',2L15/26X, - ''Location / function convergence: '',2F15.8/26X, - ''Random cycles / max iterations: '',2I15)') - ISX,ISF,IORDER,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 *,' !!!!!! MATEXT WARNING : Received incorrect'// - ' convergence criteria; no search.' RETURN ENDIF *** Print output. IF(LPRINT)THEN NAMEX='temporary' NAMEF='temporary' DO 60 I=1,NGLB IF(NINT(GLBVAL(I)).EQ.IRX)THEN NAMEX=GLBVAR(I) ELSEIF(NINT(GLBVAL(I)).EQ.IRF)THEN NAMEF=GLBVAR(I) ENDIF 60 CONTINUE IF(SMIN)THEN WRITE(LUNOUT,'('' Searching for the minimum of '',A, - '' vs '',A)') NAMEF,NAMEX ELSEIF(SMAX)THEN WRITE(LUNOUT,'('' Searching for the maximum of '',A, - '' vs '',A)') NAMEF,NAMEX ENDIF CALL OUTFMT(XMIN,2,AUX1,NC1,'LEFT') CALL OUTFMT(XMAX,2,AUX2,NC2,'LEFT') WRITE(LUNOUT,'('' Search range: '',A,'' to '',A)') - AUX1(1:NC1),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 *** Start a plot, if requested. IF(LPLOT)THEN DO 30 I=1,MXLIST XPL(I)=XMIN+REAL(I-1)*(XMAX-XMIN)/REAL(MXLIST-1) YPL(I)=DIVDIF(MVEC(MORG(ISF)+1),MVEC(MORG(ISX)+1), - MLEN(ISX),XPL(I),IORDER) 30 CONTINUE CALL GRGRPH(XPL,YPL,MXLIST,NAMEX,NAMEF, - 'Matrix interpolation 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=DBLE(XMIN+RNDUNI(1.0)*(XMAX-XMIN)) FTRY=DBLE(DIVDIF(MVEC(MORG(ISF)+1),MVEC(MORG(ISX)+1), - MLEN(ISX),REAL(XTRY),IORDER)) * 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. FTRY=DIVDIF(MVEC(MORG(ISF)+1),MVEC(MORG(ISX)+1), - MLEN(ISX),XMIN,IORDER) IF((SMIN.AND.FTRY.LT.F1).OR.(SMAX.AND.FTRY.GT.F1))THEN X1=XMIN F1=FTRY SKIP=.TRUE. IF(LPRINT)WRITE(LUNOUT,'('' Function value at lower'', - '' range limit is better: f='',E15.8)') FTRY ENDIF FTRY=DIVDIF(MVEC(MORG(ISF)+1),MVEC(MORG(ISX)+1), - MLEN(ISX),XMAX,IORDER) IF((SMIN.AND.FTRY.LT.F1).OR.(SMAX.AND.FTRY.GT.F1))THEN X1=XMAX F1=FTRY SKIP=.TRUE. IF(LPRINT)WRITE(LUNOUT,'('' Function value at upper'', - '' range limit is better: f='',E15.8)') FTRY ENDIF IF(SKIP)THEN XEXT=X1 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,'('' ++++++ MATEXT 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 *,' !!!!!! MATEXT 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. XEXT=REAL(XPARA) FPARA=DBLE(DIVDIF(MVEC(MORG(ISF)+1),MVEC(MORG(ISX)+1), - MLEN(ISX),REAL(XPARA),IORDER)) * Normal printout. IF(LPRINT)WRITE(LUNOUT,'('' Iteration '',I3,'' x='',E15.8, - '': f = '',E15.8,''.'')') I,XPARA,FPARA IF(LPLOT)THEN 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 *,' !!!!!! MATEXT WARNING : Parabolic extremum'// - ' is outside current search range; search stopped.' IFAIL=1 GOTO 3000 ENDIF 20 CONTINUE *** No convergence. PRINT *,' !!!!!! MATEXT WARNING : No convergence after maximum'// - ' number of steps.' PRINT *,' Current extremum f=',F1 PRINT *,' Found for x=',X1 *** Clean up. 3000 CONTINUE * Close graphics, if active. IF(LPLOT)CALL GRNEXT * Seems to have worked. IFAIL=0 END +DECK,MATFAR. SUBROUTINE MATFAR(IREF1,IREF2,OPTION) *----------------------------------------------------------------------- * MATFAR - Plots an area. * (Last changed on 17/11/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,MATDATA. +SEQ,PRINTPLOT. INTEGER IREF1,IREF2,ISLOT1,ISLOT2,MATSLT EXTERNAL MATSLT CHARACTER*(*) OPTION *** Indentify the routine if requested. IF(LIDENT)PRINT *,' /// ROUTINE MATFAR ///' *** Debugging output. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MATFAR DEBUG : Plotting'', - '' line vectors '',2I5)') IREF1,IREF2 *** Locate the 2 vectors. ISLOT1=MATSLT(IREF1) ISLOT2=MATSLT(IREF2) IF(ISLOT1.EQ.0.OR.ISLOT2.EQ.0)THEN PRINT *,' !!!!!! MATFAR WARNING : Matrix to be plotted'// - ' has not been found.' RETURN ENDIF *** Verify that the 2 have the same length. IF(MLEN(ISLOT1).NE.MLEN(ISLOT2))THEN PRINT *,' !!!!!! MATFAR WARNING : The 2 vectors do not'// - ' have the same length; not plotted.' RETURN ENDIF *** Verify that the length is at least 3. IF(MLEN(ISLOT1).LT.2.OR.MLEN(ISLOT2).LT.2)THEN PRINT *,' !!!!!! MATFAR WARNING : The vectors have a'// - ' length less than 3; not plotted.' RETURN ENDIF *** Plot the area. IF(INDEX(OPTION,'GKS').NE.0)THEN CALL GFA(MLEN(ISLOT1),MVEC(MORG(ISLOT1)+1), - MVEC(MORG(ISLOT2)+1)) ELSE CALL GRAREA(MLEN(ISLOT1),MVEC(MORG(ISLOT1)+1), - MVEC(MORG(ISLOT2)+1)) ENDIF END +DECK,MATFEX. SUBROUTINE MATFEX(IREFX,IREFY,IREFEY,OPTION,PAR,ERR,NPAR,IFAIL) *----------------------------------------------------------------------- * MATFEX - Fits an exponential of a polynomial to a matrix. * (Last changed on 2/ 7/96.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,MATDATA. +SEQ,PRINTPLOT. LOGICAL LPRINT,LPLOT CHARACTER*(*) OPTION REAL PAR(*),ERR(*),XPL(MXLIST),YPL(MXLIST),XMIN,XMAX,YMIN,YMAX DOUBLE PRECISION AA(MXFPAR),EA(MXFPAR),XX,YY INTEGER IFAIL,NPAR,MATSLT,ISX,ISY,ISEY,IREFX,IREFY,IREFEY EXTERNAL MATSLT *** Assume the fit will fail. IFAIL=1 *** Locate the matrices. ISX=MATSLT(IREFX) ISY=MATSLT(IREFY) ISEY=MATSLT(IREFEY) * Make sure that they exist. IF(ISX.LE.0.OR.ISY.LE.0.OR.ISEY.LE.0)THEN PRINT *,' !!!!!! MATFEX WARNING : One or more matrix'// - ' references not valid; no fit.' RETURN * Make sure they are 1-dimensional. ELSEIF(MDIM(ISX).NE.1.OR.MDIM(ISY).NE.1.OR.MDIM(ISEY).NE.1)THEN PRINT *,' !!!!!! MATFEX WARNING : One or more matrices'// - ' is not 1-dimensional; no fit.' RETURN * Make sure there are the same length and sufficiently long. ELSEIF(MLEN(ISX).NE.MLEN(ISY).OR.MLEN(ISY).NE.MLEN(ISEY).OR. - MLEN(ISX).LT.NPAR.OR.NPAR.LT.1)THEN PRINT *,' !!!!!! MATFEX WARNING : Matrix dimensions not'// - ' compatible or too small; no fit.' RETURN ENDIF *** Decode the option string. LPRINT=.FALSE. LPLOT=.FALSE. IF(INDEX(OPTION,'NOPLOT').NE.0)THEN LPLOT=.FALSE. ELSEIF(INDEX(OPTION,'PLOT').NE.0)THEN LPLOT=.TRUE. ENDIF IF(INDEX(OPTION,'NOPRINT').NE.0)THEN LPRINT=.FALSE. ELSEIF(INDEX(OPTION,'PRINT').NE.0)THEN LPRINT=.TRUE. ENDIF *** Call the fitting routine. CALL EXPFIT(MVEC(MORG(ISX)+1),MVEC(MORG(ISY)+1), - MVEC(MORG(ISEY)+1),MLEN(ISX),LPRINT,AA,EA,NPAR,IFAIL) DO 10 I=1,NPAR PAR(I)=REAL(AA(I)) ERR(I)=REAL(EA(I)) 10 CONTINUE *** Make a plot of the fit, start plotting the frame. IF(LPLOT)THEN * Switch to logarithmic scale. CALL GRAOPT('LIN-X, LOG-Y') * Determine scale. DO 20 I=1,MLEN(ISX) IF(I.EQ.1)THEN XMIN=MVEC(MORG(ISX)+I) XMAX=MVEC(MORG(ISX)+I) YMIN=MVEC(MORG(ISY)+I)-ABS(MVEC(MORG(ISEY)+I)) YMAX=MVEC(MORG(ISY)+I)+ABS(MVEC(MORG(ISEY)+I)) ELSE XMIN=MIN(XMIN,MVEC(MORG(ISX)+I)) XMAX=MAX(XMAX,MVEC(MORG(ISX)+I)) YMIN=MIN(YMIN,MVEC(MORG(ISY)+I)- - ABS(MVEC(MORG(ISEY)+I))) YMAX=MAX(YMAX,MVEC(MORG(ISY)+I)+ - ABS(MVEC(MORG(ISEY)+I))) ENDIF 20 CONTINUE * Plot frame. CALL GRCART(XMIN-0.1*(XMAX-XMIN),YMIN-0.1*(YMAX-YMIN), - XMAX+0.1*(XMAX-XMIN),YMAX+0.1*(YMAX-YMIN), - 'x','y','Exponential fit') * Plot the error bars. CALL MATERR(IREFX,IREFY,0,IREFEY,0,IREFEY,'CIRCLE',0.01) * Prepare the plot vector. DO 30 I=1,MXLIST XPL(I)=XMIN+REAL(I-1)*(XMAX-XMIN)/REAL(MXLIST-1) XX=XPL(I) CALL EXPFUN(XX,AA,YY) YPL(I)=YY 30 CONTINUE * Set the attributes. CALL GRATTS('FUNCTION-2','POLYLINE') * Plot the line itself. CALL GRLINE(MXLIST,XPL,YPL) * Close the plot. CALL GRNEXT * Switch to normal mode. CALL GRAOPT('LIN-X, LIN-Y') * Register the plot. CALL GRALOG('Exponential fit to a matrix.') ENDIF END +DECK,MATFPR. SUBROUTINE MATFPR(IREFX,IREFY,IREFEY,OPTION, - FACT,OFF,SLOPE,THETA,EFACT,EOFF,ESLOPE,ETHETA,IFAIL) *----------------------------------------------------------------------- * MATFPR - Fits a Polya distribution to a matrix. * (Last changed on 21/ 8/96.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,MATDATA. +SEQ,PRINTPLOT. LOGICAL LPRINT,LPLOT,LSCALE,LAUTO CHARACTER*(*) OPTION REAL FACT,OFF,SLOPE,THETA,EFACT,EOFF,ESLOPE,ETHETA, - XPL(MXLIST),YPL(MXLIST),XMIN,XMAX,YMIN,YMAX DOUBLE PRECISION AA(4),EA(4),XX,YY INTEGER IFAIL,MATSLT,ISX,ISY,ISEY,IREFX,IREFY,IREFEY EXTERNAL MATSLT *** Assume the fit will fail. IFAIL=1 *** Locate the matrices. ISX=MATSLT(IREFX) ISY=MATSLT(IREFY) ISEY=MATSLT(IREFEY) * Make sure that they exist. IF(ISX.LE.0.OR.ISY.LE.0.OR.ISEY.LE.0)THEN PRINT *,' !!!!!! MATFPR WARNING : One or more matrix'// - ' references not valid; no fit.' RETURN * Make sure they are 1-dimensional. ELSEIF(MDIM(ISX).NE.1.OR.MDIM(ISY).NE.1.OR.MDIM(ISEY).NE.1)THEN PRINT *,' !!!!!! MATFPR WARNING : One or more matrices'// - ' is not 1-dimensional; no fit.' RETURN * Make sure there are the same length and sufficiently long. ELSEIF(MLEN(ISX).NE.MLEN(ISY).OR.MLEN(ISY).NE.MLEN(ISEY).OR. - MLEN(ISX).LT.4)THEN PRINT *,' !!!!!! MATFPR WARNING : Matrix dimensions not'// - ' compatible or too small; no fit.' RETURN ENDIF *** Decode the option string. LPRINT=.FALSE. LPLOT=.FALSE. LAUTO=.TRUE. LSCALE=.TRUE. IF(INDEX(OPTION,'NOPLOT').NE.0)THEN LPLOT=.FALSE. ELSEIF(INDEX(OPTION,'PLOT').NE.0)THEN LPLOT=.TRUE. ENDIF IF(INDEX(OPTION,'NOPRINT').NE.0)THEN LPRINT=.FALSE. ELSEIF(INDEX(OPTION,'PRINT').NE.0)THEN LPRINT=.TRUE. ENDIF IF(INDEX(OPTION,'FIT').NE.0)THEN LSCALE=.TRUE. ELSEIF(INDEX(OPTION,'FIX').NE.0)THEN LSCALE=.FALSE. ENDIF IF(INDEX(OPTION,'AUTO').NE.0)THEN LAUTO=.TRUE. ELSEIF(INDEX(OPTION,'MANUAL').NE.0)THEN LAUTO=.FALSE. ENDIF *** Call the fitting routine. AA(1)=FACT AA(2)=THETA AA(3)=OFF AA(4)=SLOPE CALL PYAFIT(MVEC(MORG(ISX)+1),MVEC(MORG(ISY)+1), - MVEC(MORG(ISEY)+1),MLEN(ISX),LPRINT,.TRUE.,LSCALE,LAUTO, - AA,EA,IFAIL) FACT=AA(1) THETA=AA(2) OFF=AA(3) SLOPE=AA(4) EFACT=EA(1) ETHETA=EA(2) EOFF=EA(3) ESLOPE=EA(4) *** Make a plot of the fit, start plotting the frame. IF(LPLOT)THEN * Switch to logarithmic scale. CALL GRAOPT('LIN-X, LOG-Y') * Determine scale. DO 20 I=1,MLEN(ISX) IF(I.EQ.1)THEN XMIN=MVEC(MORG(ISX)+I) XMAX=MVEC(MORG(ISX)+I) YMIN=MVEC(MORG(ISY)+I)-ABS(MVEC(MORG(ISEY)+I)) YMAX=MVEC(MORG(ISY)+I)+ABS(MVEC(MORG(ISEY)+I)) ELSE XMIN=MIN(XMIN,MVEC(MORG(ISX)+I)) XMAX=MAX(XMAX,MVEC(MORG(ISX)+I)) YMIN=MIN(YMIN,MVEC(MORG(ISY)+I)- - ABS(MVEC(MORG(ISEY)+I))) YMAX=MAX(YMAX,MVEC(MORG(ISY)+I)+ - ABS(MVEC(MORG(ISEY)+I))) ENDIF 20 CONTINUE * Plot frame. CALL GRCART(XMIN-0.1*(XMAX-XMIN),0.9*YMIN, - XMAX+0.1*(XMAX-XMIN),1.1*YMAX, - 'Multiplication','Frequency','Polya fit') * Plot the error bars. CALL MATERR(IREFX,IREFY,0,IREFEY,0,IREFEY,'CIRCLE',0.01) * Prepare the plot vector. DO 30 I=1,MXLIST XPL(I)=XMIN+REAL(I-1)*(XMAX-XMIN)/REAL(MXLIST-1) XX=XPL(I) CALL PYAFUN(XX,AA,YY) YPL(I)=YY 30 CONTINUE * Set the attributes. CALL GRATTS('FUNCTION-2','POLYLINE') * Plot the line itself. CALL GRLINE(MXLIST,XPL,YPL) * Close the plot. CALL GRNEXT * Switch to normal mode. CALL GRAOPT('LIN-X, LIN-Y') * Register the plot. CALL GRALOG('Polya fit to a matrix.') ENDIF END +DECK,MATFNR. SUBROUTINE MATFNR(IREFX,IREFY,IREFEY,OPTION,FACT,AVER,SIGMA, - EFACT,EAVER,ESIGMA,IFAIL) *----------------------------------------------------------------------- * MATFNR - Fits a Gaussian to a matrix. * (Last changed on 2/ 7/96.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,MATDATA. +SEQ,PRINTPLOT. LOGICAL LPRINT,LPLOT CHARACTER*(*) OPTION REAL XPL(MXLIST),YPL(MXLIST),XMIN,XMAX,YMIN,YMAX,FACT,AVER,SIGMA, - EFACT,EAVER,ESIGMA DOUBLE PRECISION AA(3),EA(3),XX,YY INTEGER IFAIL,MATSLT,ISX,ISY,ISEY,IREFX,IREFY,IREFEY EXTERNAL MATSLT *** Assume the fit will fail. IFAIL=1 *** Locate the matrices. ISX=MATSLT(IREFX) ISY=MATSLT(IREFY) ISEY=MATSLT(IREFEY) * Make sure that they exist. IF(ISX.LE.0.OR.ISY.LE.0.OR.ISEY.LE.0)THEN PRINT *,' !!!!!! MATFNR WARNING : One or more matrix'// - ' references not valid; no fit.' RETURN * Make sure they are 1-dimensional. ELSEIF(MDIM(ISX).NE.1.OR.MDIM(ISY).NE.1.OR.MDIM(ISEY).NE.1)THEN PRINT *,' !!!!!! MATFNR WARNING : One or more matrices'// - ' is not 1-dimensional; no fit.' RETURN * Make sure there are the same length and sufficiently long. ELSEIF(MLEN(ISX).NE.MLEN(ISY).OR.MLEN(ISY).NE.MLEN(ISEY).OR. - MLEN(ISX).LT.3)THEN PRINT *,' !!!!!! MATFNR WARNING : Matrix dimensions not'// - ' compatible or too small; no fit.' RETURN ENDIF *** Decode the option string. LPRINT=.FALSE. LPLOT=.FALSE. IF(INDEX(OPTION,'NOPLOT').NE.0)THEN LPLOT=.FALSE. ELSEIF(INDEX(OPTION,'PLOT').NE.0)THEN LPLOT=.TRUE. ENDIF IF(INDEX(OPTION,'NOPRINT').NE.0)THEN LPRINT=.FALSE. ELSEIF(INDEX(OPTION,'PRINT').NE.0)THEN LPRINT=.TRUE. ENDIF *** Call the fitting routine. CALL NORFIT(MVEC(MORG(ISX)+1),MVEC(MORG(ISY)+1), - MVEC(MORG(ISEY)+1),MLEN(ISX),LPRINT,AA,EA,IFAIL) FACT=REAL(AA(1)) AVER=REAL(AA(2)) SIGMA=REAL(AA(3)) EFACT=REAL(EA(1)) EAVER=REAL(EA(2)) ESIGMA=REAL(EA(3)) *** Make a plot of the fit, start plotting the frame. IF(LPLOT)THEN * Determine scale. DO 10 I=1,MLEN(ISX) IF(I.EQ.1)THEN XMIN=MVEC(MORG(ISX)+I) XMAX=MVEC(MORG(ISX)+I) YMIN=MVEC(MORG(ISY)+I)-ABS(MVEC(MORG(ISEY)+I)) YMAX=MVEC(MORG(ISY)+I)+ABS(MVEC(MORG(ISEY)+I)) ELSE XMIN=MIN(XMIN,MVEC(MORG(ISX)+I)) XMAX=MAX(XMAX,MVEC(MORG(ISX)+I)) YMIN=MIN(YMIN,MVEC(MORG(ISY)+I)- - ABS(MVEC(MORG(ISEY)+I))) YMAX=MAX(YMAX,MVEC(MORG(ISY)+I)+ - ABS(MVEC(MORG(ISEY)+I))) ENDIF 10 CONTINUE * Plot frame. CALL GRCART(XMIN-0.1*(XMAX-XMIN),YMIN-0.1*(YMAX-YMIN), - XMAX+0.1*(XMAX-XMIN),YMAX+0.1*(YMAX-YMIN), - 'x','y','Gaussian fit') * Plot the error bars. CALL MATERR(IREFX,IREFY,0,IREFEY,0,IREFEY,'CIRCLE',0.01) * Prepare the plot vector. DO 30 I=1,MXLIST XPL(I)=XMIN+REAL(I-1)*(XMAX-XMIN)/REAL(MXLIST-1) XX=XPL(I) CALL NORFUN(XX,AA,YY) YPL(I)=YY 30 CONTINUE * Set the attributes. CALL GRATTS('FUNCTION-2','POLYLINE') * Plot the line itself. CALL GRLINE(MXLIST,XPL,YPL) * Close the plot. CALL GRNEXT * Register the plot. CALL GRALOG('Gaussian fit to a matrix.') ENDIF END +DECK,MATFPL. SUBROUTINE MATFPL(IREFX,IREFY,IREFEY,OPTION,PAR,ERR,NPAR,IFAIL) *----------------------------------------------------------------------- * MATFPL - Fits a polynomial to a matrix. * (Last changed on 12/ 6/96.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,MATDATA. +SEQ,PRINTPLOT. LOGICAL LPRINT,LPLOT CHARACTER*(*) OPTION REAL PAR(*),ERR(*),XPL(MXLIST),YPL(MXLIST),XMIN,XMAX DOUBLE PRECISION AA(MXFPAR),EA(MXFPAR),XX,YY INTEGER IFAIL,NPAR,MATSLT,ISX,ISY,ISEY,IREFX,IREFY,IREFEY EXTERNAL MATSLT *** Assume the fit will fail. IFAIL=1 *** Locate the matrices. ISX=MATSLT(IREFX) ISY=MATSLT(IREFY) ISEY=MATSLT(IREFEY) * Make sure that they exist. IF(ISX.LE.0.OR.ISY.LE.0.OR.ISEY.LE.0)THEN PRINT *,' !!!!!! MATFPL WARNING : One or more matrix'// - ' references not valid; no fit.' RETURN * Make sure they are 1-dimensional. ELSEIF(MDIM(ISX).NE.1.OR.MDIM(ISY).NE.1.OR.MDIM(ISEY).NE.1)THEN PRINT *,' !!!!!! MATFPL WARNING : One or more matrices'// - ' is not 1-dimensional; no fit.' RETURN * Make sure there are the same length and sufficiently long. ELSEIF(MLEN(ISX).NE.MLEN(ISY).OR.MLEN(ISY).NE.MLEN(ISEY).OR. - MLEN(ISX).LT.NPAR.OR.NPAR.LT.1)THEN PRINT *,' !!!!!! MATFPL WARNING : Matrix dimensions not'// - ' compatible or too small; no fit.' RETURN ENDIF *** Decode the option string. LPRINT=.FALSE. LPLOT=.FALSE. IF(INDEX(OPTION,'NOPLOT').NE.0)THEN LPLOT=.FALSE. ELSEIF(INDEX(OPTION,'PLOT').NE.0)THEN LPLOT=.TRUE. ENDIF IF(INDEX(OPTION,'NOPRINT').NE.0)THEN LPRINT=.FALSE. ELSEIF(INDEX(OPTION,'PRINT').NE.0)THEN LPRINT=.TRUE. ENDIF *** Call the fitting routine. CALL POLFIT(MVEC(MORG(ISX)+1),MVEC(MORG(ISY)+1), - MVEC(MORG(ISEY)+1),MLEN(ISX),LPRINT,AA,EA,NPAR,IFAIL) DO 10 I=1,NPAR PAR(I)=REAL(AA(I)) ERR(I)=REAL(EA(I)) 10 CONTINUE *** Make a plot of the fit, start plotting the frame. IF(LPLOT)THEN * Determine scale. DO 20 I=1,MLEN(ISX) IF(I.EQ.1)THEN XMIN=MVEC(MORG(ISX)+I) XMAX=MVEC(MORG(ISX)+I) YMIN=MVEC(MORG(ISY)+I)-ABS(MVEC(MORG(ISEY)+I)) YMAX=MVEC(MORG(ISY)+I)+ABS(MVEC(MORG(ISEY)+I)) ELSE XMIN=MIN(XMIN,MVEC(MORG(ISX)+I)) XMAX=MAX(XMAX,MVEC(MORG(ISX)+I)) YMIN=MIN(YMIN,MVEC(MORG(ISY)+I)- - ABS(MVEC(MORG(ISEY)+I))) YMAX=MAX(YMAX,MVEC(MORG(ISY)+I)+ - ABS(MVEC(MORG(ISEY)+I))) ENDIF 20 CONTINUE * Plot frame. CALL GRCART(XMIN-0.1*(XMAX-XMIN),YMIN-0.1*(YMAX-YMIN), - XMAX+0.1*(XMAX-XMIN),YMAX+0.1*(YMAX-YMIN), - 'x','y','Polynomial fit') * Plot the error bars. CALL MATERR(IREFX,IREFY,0,IREFEY,0,IREFEY,'CIRCLE',0.01) * Prepare the plot vector. DO 30 I=1,MXLIST XPL(I)=XMIN+REAL(I-1)*(XMAX-XMIN)/REAL(MXLIST-1) XX=XPL(I) CALL POLFUN(XX,AA,YY) YPL(I)=YY 30 CONTINUE * Set the attributes. CALL GRATTS('FUNCTION-2','POLYLINE') * Plot the line itself. CALL GRLINE(MXLIST,XPL,YPL) * Close the plot. CALL GRNEXT * Register the plot. CALL GRALOG('Polynomial fit to a matrix.') ENDIF END +DECK,MATFFU. SUBROUTINE MATFFU(IREFX,IREFY,IREFEY,FUN,OPTION,IA,IE,NPAR,IFAIL) *----------------------------------------------------------------------- * MATFFU - Fits a function to a matrix. * (Last changed on 20/ 2/97.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,MATDATA. +SEQ,PRINTPLOT. +SEQ,GLOBALS. LOGICAL LPRINT,LPLOT CHARACTER*(*) OPTION,FUN CHARACTER*40 TITLE REAL XPL(MXLIST),YPL(MXLIST),XMIN,XMAX,YMIN,YMAX DOUBLE PRECISION AA(MXFPAR),XX,YY INTEGER IFAIL,IFAIL1,NPAR,NNA,IIA,IA(*),IE(*),I,IENTRY,MATSLT, - ISX,ISY,ISEY,IREFX,IREFY,IREFEY COMMON /FFUDAT/ NNA,IENTRY,IIA(MXVAR) EXTERNAL MATSLT *** Assume the fit will fail. IFAIL=1 *** Locate the matrices. ISX=MATSLT(IREFX) ISY=MATSLT(IREFY) ISEY=MATSLT(IREFEY) * Make sure that they exist. IF(ISX.LE.0.OR.ISY.LE.0.OR.ISEY.LE.0)THEN PRINT *,' !!!!!! MATFFU WARNING : One or more matrix'// - ' references not valid; no fit.' RETURN * Make sure they are 1-dimensional. ELSEIF(MDIM(ISX).NE.1.OR.MDIM(ISY).NE.1.OR.MDIM(ISEY).NE.1)THEN PRINT *,' !!!!!! MATFFU WARNING : One or more matrices'// - ' is not 1-dimensional; no fit.' RETURN * Make sure there are the same length and sufficiently long. ELSEIF(MLEN(ISX).NE.MLEN(ISY).OR.MLEN(ISY).NE.MLEN(ISEY).OR. - MLEN(ISX).LT.NPAR.OR.NPAR.LT.1)THEN PRINT *,' !!!!!! MATFFU WARNING : Matrix dimensions not'// - ' compatible or too small; no fit.' RETURN ENDIF *** Decode the option string. LPRINT=.FALSE. LPLOT=.FALSE. IF(INDEX(OPTION,'NOPLOT').NE.0)THEN LPLOT=.FALSE. ELSEIF(INDEX(OPTION,'PLOT').NE.0)THEN LPLOT=.TRUE. ENDIF IF(INDEX(OPTION,'NOPRINT').NE.0)THEN LPRINT=.FALSE. ELSEIF(INDEX(OPTION,'PRINT').NE.0)THEN LPRINT=.TRUE. ENDIF *** Call the fitting routine. CALL FUNFIT(FUN,MVEC(MORG(ISX)+1),MVEC(MORG(ISY)+1), - MVEC(MORG(ISEY)+1),MLEN(ISX),LPRINT,IA,IE,NPAR,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! MATFFU WARNING : The fit to ',FUN, - ' failed.' CALL ALGCLR(IENTRY) RETURN ENDIF *** Make a plot of the fit, start plotting the frame. IF(LPLOT)THEN * Determine scale. DO 20 I=1,MLEN(ISX) IF(I.EQ.1)THEN XMIN=MVEC(MORG(ISX)+I) XMAX=MVEC(MORG(ISX)+I) YMIN=MVEC(MORG(ISY)+I)-ABS(MVEC(MORG(ISEY)+I)) YMAX=MVEC(MORG(ISY)+I)+ABS(MVEC(MORG(ISEY)+I)) ELSE XMIN=MIN(XMIN,MVEC(MORG(ISX)+I)) XMAX=MAX(XMAX,MVEC(MORG(ISX)+I)) YMIN=MIN(YMIN,MVEC(MORG(ISY)+I)- - ABS(MVEC(MORG(ISEY)+I))) YMAX=MAX(YMAX,MVEC(MORG(ISY)+I)+ - ABS(MVEC(MORG(ISEY)+I))) ENDIF 20 CONTINUE * Plot frame. WRITE(TITLE,'(''Fit to '',A)') FUN(1:MIN(LEN(FUN),33)) CALL GRCART(XMIN-0.1*(XMAX-XMIN),YMIN-0.1*(YMAX-YMIN), - XMAX+0.1*(XMAX-XMIN),YMAX+0.1*(YMAX-YMIN), - 'x','y',TITLE) * Plot the error bars. CALL MATERR(IREFX,IREFY,0,IREFEY,0,IREFEY,'CIRCLE',0.01) * Prepare the parameter list. DO 40 I=1,NPAR AA(I)=GLBVAL(IIA(I)) 40 CONTINUE * Prepare the plot vector. DO 30 I=1,MXLIST XPL(I)=XMIN+REAL(I-1)*(XMAX-XMIN)/REAL(MXLIST-1) XX=XPL(I) CALL FUNFUN(XX,AA,YY) YPL(I)=YY 30 CONTINUE * Set the attributes. CALL GRATTS('FUNCTION-2','POLYLINE') * Plot the line itself. CALL GRLINE(MXLIST,XPL,YPL) * Close the plot. CALL GRNEXT * Register the plot. CALL GRALOG('Function fit to a matrix.') ENDIF *** We're now done with the function, so can delete the entry point. CALL ALGCLR(IENTRY) *** Seems to have worked. IFAIL=0 END +DECK,MATGET. SUBROUTINE MATGET(IREF,FILE,MEMB,IFAIL) *----------------------------------------------------------------------- * MATGET - This routine reads an matrix from a file. * VARIABLES : STRING : Character string that should contain a * description of the dataset being read. * (Last changed on 3/12/96.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,MATDATA. +SEQ,PRINTPLOT. CHARACTER*132 STRING CHARACTER*(*) FILE,MEMB CHARACTER*8 MEMBER INTEGER ISIZ(MXMDIM),MATSLT LOGICAL DSNCMP,EXIS EXTERNAL DSNCMP,MATSLT *** Identify the routine, if requested. IF(LIDENT)PRINT *,' /// ROUTINE MATGET ///' *** Initialise IFAIL on 1 (i.e. fail). IFAIL=1 *** Transfer variables. MEMBER=MEMB *** Initialise IREF so that MATCAL always gets something back. IREF=-1 *** Open the dataset and inform DSNLOG. CALL DSNOPN(FILE,LEN(FILE),12,'READ-LIBRARY',IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! MATGET WARNING : Opening ',FILE, - ' failed ; matrix not read.' IFAIL=1 RETURN ENDIF CALL DSNLOG(FILE,'Matrix ','Sequential','Read only ') IF(LDEBUG)PRINT *,' ++++++ MATGET DEBUG : Dataset ', - FILE,' opened on unit 12 for seq read.' * Locate the pointer on the header of the requested member. CALL DSNLOC(MEMBER,LEN(MEMBER),'MATRIX ',12,EXIS,'RESPECT') IF(.NOT.EXIS)THEN CALL DSNLOC(MEMBER,LEN(MEMBER),'MATRIX ',12,EXIS,'IGNORE') IF(EXIS)THEN PRINT *,' ###### MATGET ERROR : Matrix ',MEMBER, - ' has been deleted from ',FILE,'; not read.' ELSE PRINT *,' ###### MATGET ERROR : Matrix ',MEMBER, - ' not found on ',FILE,'.' ENDIF CLOSE(UNIT=12,IOSTAT=IOS,ERR=2030) IFAIL=1 RETURN ENDIF *** Check that the member is acceptable. READ(12,'(A80)',END=2000,IOSTAT=IOS,ERR=2010) STRING IF(DSNCMP('03-12-96',STRING(11:18)))THEN PRINT *,' !!!!!! MATGET WARNING : Member ',STRING(32:39), - ' can not be read because of a change in format.' CLOSE(UNIT=12,IOSTAT=IOS,ERR=2030) IFAIL=1 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 matrix dimension. READ(12,'(/12X,I10/12X,I10/12X,12I10:(/12X,12I10))', - IOSTAT=IOS,END=2000,ERR=2010) NDIM,IMOD,(ISIZ(I),I=1,NDIM) *** Allocate a matrix for this member. CALL MATADM('ALLOCATE',IREF,NDIM,ISIZ,IMOD,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! MATGET WARNING : Unable to obtain space'// - ' to store the matrix to be read; not read.' IFAIL=1 IREF=-1 CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) RETURN ENDIF *** Find the newly allocated matrix. ISLOT=MATSLT(IREF) IF(ISLOT.LE.0)THEN PRINT *,' !!!!!! MATGET WARNING : New matrix not found;'// - ' program bug - please report.' IREF=-1 IFAIL=1 RETURN ENDIF *** Execute read operations if a valid name is available. READ(12,'()',IOSTAT=IOS,END=2000,ERR=2010) READ(12,'(2X,8E15.8)',IOSTAT=IOS,END=2000,ERR=2010) - (MVEC(MORG(ISLOT)+I),I=1,MLEN(ISLOT)) * Close the file after the operation. CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) *** Register the amount of CPU time used for reading. CALL TIMLOG('Reading an matrix from a dataset: ') *** Things worked, reset the error flag. IFAIL=0 RETURN *** Handle the I/O error conditions. 2000 CONTINUE PRINT *,' ###### MATGET ERROR : EOF encountered while', - ' reading ',FILE,' from unit 12 ; no matrix read.' CALL INPIOS(IOS) IF(IREF.NE.-1)CALL MATADM('DELETE',IREF,1,ISIZ,2,IFAIL1) CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) RETURN 2010 CONTINUE PRINT *,' ###### MATGET ERROR : Error while reading ', - FILE,' from unit 12 ; no matrix read.' CALL INPIOS(IOS) IF(IREF.NE.-1)CALL MATADM('DELETE',IREF,1,ISIZ,2,IFAIL1) CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) RETURN 2030 CONTINUE PRINT *,' ###### MATGET ERROR : Dataset ',FILE, - ' on unit 12 cannot be closed ; results not predictable.' CALL INPIOS(IOS) END +DECK,MATGRA. SUBROUTINE MATGRA(IREF1,IREF2,XTXT,YTXT,TITLE) *----------------------------------------------------------------------- * MATGRA - Plots a graph. * (Last changed on 6/ 4/98.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,MATDATA. +SEQ,PRINTPLOT. CHARACTER*(*) XTXT,YTXT,TITLE *** Identify the routine if requested. IF(LIDENT)PRINT *,' /// ROUTINE MATGRA ///' *** Debugging output. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MATGRA DEBUG : Graph'', - '' of '',I5,'' vs '',I5/26X,''x-Axis label: '',A/ - 26X,''y-Axis label: '',A/26X,''Title: '',A)') - IREF1,IREF2,XTXT,YTXT,TITLE *** Locate the 2 vectors. ISLOT1=0 ISLOT2=0 DO 10 I=1,MXMAT IF(MREF(I).EQ.IREF1)THEN ISLOT1=I ELSEIF(MREF(I).EQ.IREF2)THEN ISLOT2=I ENDIF IF(ISLOT1.NE.0.AND.ISLOT2.NE.0)GOTO 20 10 CONTINUE PRINT *,' !!!!!! MATGRA WARNING : Matrix to be plotted has'// - ' not been found.' RETURN 20 CONTINUE *** Verify that the 2 have the same length. IF(MLEN(ISLOT1).NE.MLEN(ISLOT2))THEN PRINT *,' !!!!!! MATGRA WARNING : The 2 vectors do not'// - ' have the same length; not plotted.' RETURN ENDIF *** Verify that the length is at least 2. IF(MLEN(ISLOT1).LT.2.OR.MLEN(ISLOT2).LT.2)THEN PRINT *,' !!!!!! MATGRA WARNING : The vectors have a'// - ' length less than 2; not plotted.' RETURN ENDIF *** Set the correct graphics representation for the curve. CALL GRATTS('FUNCTION-1','POLYLINE') *** Plot the line. CALL GRGRPH(MVEC(MORG(ISLOT1)+1),MVEC(MORG(ISLOT2)+1), - MLEN(ISLOT1),XTXT,YTXT,TITLE) END +DECK,MATIN1. SUBROUTINE MATIN1(IRVEC1,IRVEC2,N,X,Y,ISVEC1,ISVEC2,IORD,IFAIL) *----------------------------------------------------------------------- * MATIN1 - Interpolates two vectors. * (Last changed on 19/ 9/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,MATDATA. +SEQ,PRINTPLOT. INTEGER IRVEC1,IRVEC2,ISVEC1,ISVEC2,IFAIL,I,N,MATSLT,IORD REAL X(*),Y(*) EXTERNAL MATSLT +SELF,IF=ESSL. INTEGER NAUX PARAMETER(NAUX=2*MXLIST) REAL AUX(NAUX) +SELF,IF=-ESSL. REAL DIVDIF EXTERNAL DIVDIF +SELF. *** Indentify the routine. +SELF,IF=ESSL. IF(LIDENT)PRINT *,' /// ROUTINE MATIN1 (ESSL) ///' +SELF,IF=-ESSL. IF(LIDENT)PRINT *,' /// ROUTINE MATIN1 (CERNLIB) ///' +SELF. *** Debugging information. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MATIN1 DEBUG : Order '',I2, - '' interpolation for '',I5,'' vs '',I5,'' with '',I5, - '' points.'')') IORD,IRVEC1,IRVEC2,N *** Assume the routine will fail. IFAIL=1 *** Check the interpolation order. IF(IORD.LT.1)THEN PRINT *,' !!!!!! MATIN1 WARNING : Interpolation order'// - ' is not at least 1; no interpolation.' RETURN ENDIF *** Locate slots if not already done. IF(ISVEC1.LE.0.OR.ISVEC2.LE.0)THEN * Find the slot numbers. ISVEC1=MATSLT(IRVEC1) ISVEC2=MATSLT(IRVEC2) * Ensure that the vectors exist. IF(ISVEC1.LE.0.OR.ISVEC2.LE.0)THEN PRINT *,' !!!!!! MATIN1 WARNING : Unable to locate'// - ' one of the 2 vectors; no interpolation.' RETURN ENDIF * Make sure they are indeed vectors. IF(MDIM(ISVEC1).NE.1.OR.MDIM(ISVEC2).NE.1.OR. - MLEN(ISVEC1).NE.MLEN(ISVEC2).OR. - MLEN(ISVEC1).LT.2.OR.MLEN(ISVEC2).LT.2)THEN PRINT *,' !!!!!! MATIN1 WARNING : The 2 vectors are'// - ' not 1-dimensional, too short or not compatible.' ISVEC1=-1 ISVEC2=-1 RETURN ENDIF * Check that they are properly ordered. IF(MVEC(MORG(ISVEC1)+2).GT.MVEC(MORG(ISVEC1)+1))THEN DO 10 I=2,MLEN(ISVEC1) IF(MVEC(MORG(ISVEC1)+I).LE.MVEC(MORG(ISVEC1)+I-1))THEN PRINT *,' !!!!!! MATIN1 WARNING : The ordinate'// - ' vector is not strictly ordered.' ISVEC1=-1 ISVEC2=-1 RETURN ENDIF 10 CONTINUE ELSEIF(MVEC(MORG(ISVEC1)+2).LT.MVEC(MORG(ISVEC1)+1))THEN DO 20 I=2,MLEN(ISVEC1) IF(MVEC(MORG(ISVEC1)+I).GE.MVEC(MORG(ISVEC1)+I-1))THEN PRINT *,' !!!!!! MATIN1 WARNING : The ordinate'// - ' vector is not strictly ordered.' ISVEC1=-1 ISVEC2=-1 RETURN ENDIF 20 CONTINUE ELSE PRINT *,' !!!!!! MATIN1 WARNING : The ordinate'// - ' vector is not strictly ordered.' ISVEC1=-1 ISVEC2=-1 RETURN ENDIF ENDIF *** Carry out the interpolation. IF(N.LT.1)THEN PRINT *,' !!!!!! MATIN1 WARNING : Invalid number of'// - ' points received ; no interpolation.' RETURN ENDIF +SELF,IF=-ESSL. DO 30 I=1,N * Avoid extrapolation. IF((MVEC(MORG(ISVEC1)+1)-X(I))* - (MVEC(MORG(ISVEC1)+MLEN(ISVEC1))-X(I)).GT.0)THEN Y(I)=0 * Interpolation. ELSE Y(I)=DIVDIF(MVEC(MORG(ISVEC2)+1),MVEC(MORG(ISVEC1)+1), - MLEN(ISVEC1),X(I),MIN(IORD,MLEN(ISVEC1)-1)) ENDIF 30 CONTINUE +SELF,IF=ESSL. * Check space. IF(NAUX.LT.MLEN(ISVEC1)+N)THEN PRINT *,' !!!!!! MATIN1 WARNING : Insufficient space'// - ' allocated for SPTINT; recompile.' RETURN ENDIF * Interpolation. CALL STPINT(MVEC(MORG(ISVEC1)+1),MVEC(MORG(ISVEC2)+1), - MLEN(ISVEC1),1+MIN(IORD,MLEN(ISVEC1)-1),X,Y,N,AUX,NAUX) * Avoid extrapolation. DO 40 I=1,N IF((MVEC(MORG(ISVEC1)+1)-X(I))* - (MVEC(MORG(ISVEC1)+MLEN(ISVEC1))-X(I)).GT.0)Y(I)=0 40 CONTINUE +SELF. *** Seems to have worked. IFAIL=0 END +DECK,MATINN. SUBROUTINE MATINN(IRMAT,IRORD,IRPNT,IROUT,IFAIL) *----------------------------------------------------------------------- * MATINN - Interpolates. * (Last changed on 11/ 4/96.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,MATDATA. +SEQ,PRINTPLOT. INTEGER IRMAT,IRORD,IRPNT,IROUT,IFAIL,ISMAT,ISORD,ISPNT,ISOUT,I, - LORD,ISIZ(MXMDIM),IA(MXMDIM),NPOINT,MATADR REAL FINT EXTERNAL FINT,MATADR *** Identify the routine. IF(LIDENT)PRINT *,' /// ROUTINE MATINN ///' *** Assume that the routine will fail. IFAIL=1 *** Look up the matrices a first time. ISMAT=0 ISORD=0 ISPNT=0 ISOUT=0 * Scan the table. DO 10 I=1,MXMAT IF(MREF(I).EQ.IRMAT)THEN ISMAT=I ELSEIF(MREF(I).EQ.IRORD)THEN ISORD=I ELSEIF(MREF(I).EQ.IRPNT)THEN ISPNT=I ELSEIF(MREF(I).EQ.IROUT)THEN ISOUT=I ENDIF IF(ISMAT.GT.0.AND.ISORD.GT.0.AND. - ISPNT.GT.0.AND.ISOUT.GT.0)GOTO 20 10 CONTINUE * Don't insist on the presence of an output matrix. IF(ISMAT.GT.0.AND.ISORD.GT.0.AND.ISPNT.GT.0)GOTO 20 * The others however should exist. PRINT *,' !!!!!! MATINN WARNING : Could not find one of the'// - ' matrices; no interpolation.' RETURN 20 CONTINUE *** Interpolation routine FINT is limited to 5 dimensions. IF(MDIM(ISMAT).GT.5.OR.MDIM(ISMAT).LT.1)THEN PRINT *,' !!!!!! MATINN WARNING : Library interpolation'// - ' routine limited to 1-5 dimensions; nothing done.' RETURN ENDIF *** Verify the dimensions. LORD=0 DO 30 I=1,MDIM(ISMAT) LORD=LORD+MSIZ(ISMAT,I) 30 CONTINUE IF(MDIM(ISMAT).NE.MSIZ(ISPNT,1).OR. - LORD.NE.MSIZ(ISORD,1).OR.MDIM(ISORD).NE.1.OR. - (MDIM(ISPNT).NE.1.AND.MDIM(ISPNT).NE.2))THEN PRINT *,' !!!!!! MATINN WARNING : Incompatible dimensions'// - ' of matrix, ordinates and coordinates.' RETURN ENDIF *** Take care of the output matrix. IF(ISOUT.NE.0)THEN ** Already exists, check whether the size and shape are OK. IF(MDIM(ISOUT).NE.1.OR. - MSIZ(ISOUT,1).LT.MSIZ(ISPNT,2))THEN * If not OK, re-shape the matrix. ISIZ(1)=MSIZ(ISPNT,2) CALL MATCHS(IROUT,1,ISIZ,0.0,IFAIL1) * Quit if re-shaping failed. IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! MATINN WARNING : Unable to'// - ' reshape output matrix; no interpolation.' RETURN ENDIF ENDIF ** Output matrix did not exist yet, create one. ELSE ISIZ(1)=MSIZ(ISPNT,2) CALL MATADM('ALLOCATE',IROUT,1,ISIZ,2,IFAIL1) * Quit if creating failed. IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! MATINN WARNING : Unable to'// - ' create an output matrix; no interpolation.' RETURN ENDIF ENDIF *** Look up the matrices a second time. ISMAT=0 ISORD=0 ISPNT=0 ISOUT=0 * Scan the table. DO 40 I=1,MXMAT IF(MREF(I).EQ.IRMAT)THEN ISMAT=I ELSEIF(MREF(I).EQ.IRORD)THEN ISORD=I ELSEIF(MREF(I).EQ.IRPNT)THEN ISPNT=I ELSEIF(MREF(I).EQ.IROUT)THEN ISOUT=I ENDIF IF(ISMAT.GT.0.AND.ISORD.GT.0.AND. - ISPNT.GT.0.AND.ISOUT.GT.0)GOTO 50 40 CONTINUE * Now insist on the presence of an output matrix. PRINT *,' !!!!!! MATINN WARNING : Could not find one of the'// - ' matrices; no interpolation.' RETURN 50 CONTINUE *** Carry out the actual interpolation, loop over the points. IF(MDIM(ISPNT).EQ.2)THEN NPOINT=MSIZ(ISPNT,2) ELSE NPOINT=1 ENDIF * Make a vector of sizes. DO 110 I=1,MDIM(ISMAT) ISIZ(I)=MSIZ(ISMAT,I) 110 CONTINUE * Do the actual interpolations. DO 100 I=1,NPOINT IA(1)=1 IA(2)=I MVEC(MORG(ISOUT)+I)=FINT(MDIM(ISMAT),MVEC(MATADR(ISPNT,IA)), - ISIZ,MVEC(MORG(ISORD)+1),MVEC(MORG(ISMAT)+1)) 100 CONTINUE *** Seems to have worked. IFAIL=0 END +DECK,MATINT. SUBROUTINE MATINT *----------------------------------------------------------------------- * MATINT - Initialises the matrix system. * (Last changed on 23/10/95.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,MATDATA. +SEQ,PRINTPLOT. *** Identify the routine if requested. IF(LIDENT)PRINT *,' /// ROUTINE MATINT ///' *** Debugging information. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MATINT DEBUG :'', - '' Initialising the matrix storage.''/ - 26X,''Maximum number of matrices: '',I5/ - 26X,''Maximum number of dimensions: '',I5/ - 26X,''Total storage area: '',I5)') - MXMAT,MXMDIM,MXEMAT *** Matrix reference information. DO 10 I=1,MXMAT MORG(I)=0 MLEN(I)=0 MREF(I)=0 MMOD(I)=0 DO 20 J=1,MXMDIM MSIZ(I,J)=0 20 CONTINUE MDIM(I)=0 10 CONTINUE MREF(MXMAT+1)=-1 MORG(MXMAT+1)=MXEMAT MLEN(MXMAT+1)=0 *** Matrix space. DO 30 I=1,MXEMAT MVEC(I)=0 30 CONTINUE *** Reference counter. NREFL=0 END +DECK,MATLIN. SUBROUTINE MATLIN(IREF1,IREF2,OPTION) *----------------------------------------------------------------------- * MATLIN - Plots a line. * (Last changed on 17/11/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,MATDATA. +SEQ,PRINTPLOT. INTEGER IREF1,IREF2,ISLOT1,ISLOT2,MATSLT EXTERNAL MATSLT CHARACTER*(*) OPTION *** Indentify the routine if requested. IF(LIDENT)PRINT *,' /// ROUTINE MATLIN ///' *** Debugging output. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MATLIN DEBUG : Plotting'', - '' line vectors '',2I5)') IREF1,IREF2 *** Locate the 2 vectors. ISLOT1=MATSLT(IREF1) ISLOT2=MATSLT(IREF2) IF(ISLOT1.EQ.0.OR.ISLOT2.EQ.0)THEN PRINT *,' !!!!!! MATLIN WARNING : Matrix to be plotted'// - ' has not been found.' RETURN ENDIF *** Verify that the 2 have the same length. IF(MLEN(ISLOT1).NE.MLEN(ISLOT2))THEN PRINT *,' !!!!!! MATLIN WARNING : The 2 vectors do not'// - ' have the same length; not plotted.' RETURN ENDIF *** Verify that the length is at least 2. IF(MLEN(ISLOT1).LT.2.OR.MLEN(ISLOT2).LT.2)THEN PRINT *,' !!!!!! MATLIN WARNING : The vectors have a'// - ' length less than 2; not plotted.' RETURN ENDIF *** Plot the line. IF(INDEX(OPTION,'SMOOTH').NE.0.AND. - INDEX(OPTION,'NOSMOOTH').EQ.0)THEN CALL GRSPLN(MLEN(ISLOT1),MVEC(MORG(ISLOT1)+1), - MVEC(MORG(ISLOT2)+1)) ELSEIF(INDEX(OPTION,'GKS').NE.0)THEN CALL GPL(MLEN(ISLOT1),MVEC(MORG(ISLOT1)+1), - MVEC(MORG(ISLOT2)+1)) ELSE CALL GRLINE(MLEN(ISLOT1),MVEC(MORG(ISLOT1)+1), - MVEC(MORG(ISLOT2)+1)) ENDIF END +DECK,MATMRK. SUBROUTINE MATMRK(IREF1,IREF2,OPTION) *----------------------------------------------------------------------- * MATMRK - Plots a set of markers. * (Last changed on 17/11/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,MATDATA. +SEQ,PRINTPLOT. INTEGER IREF1,IREF2,ISLOT1,ISLOT2,MATSLT EXTERNAL MATSLT CHARACTER*(*) OPTION *** Indentify the routine if requested. IF(LIDENT)PRINT *,' /// ROUTINE MATMRK ///' *** Debugging output. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MATMRK DEBUG : Plotting'', - '' marker vectors '',2I5)') IREF1,IREF2 *** Locate the 2 vectors. ISLOT1=MATSLT(IREF1) ISLOT2=MATSLT(IREF2) IF(ISLOT1.EQ.0.OR.ISLOT2.EQ.0)THEN PRINT *,' !!!!!! MATMRK WARNING : Matrix to be plotted'// - ' has not been found.' RETURN ENDIF *** Verify that the 2 have the same length. IF(MLEN(ISLOT1).NE.MLEN(ISLOT2))THEN PRINT *,' !!!!!! MATMRK WARNING : The 2 vectors do not'// - ' have the same length; not plotted.' RETURN ENDIF *** Verify that the length is at least 1. IF(MLEN(ISLOT1).LT.1.OR.MLEN(ISLOT2).LT.1)THEN PRINT *,' !!!!!! MATMRK WARNING : The vectors have a'// - ' length less than 1; not plotted.' RETURN ENDIF *** Plot the markers. IF(OPTION.EQ.'GKS')THEN CALL GRMARK(MLEN(ISLOT1),MVEC(MORG(ISLOT1)+1), - MVEC(MORG(ISLOT2)+1)) ELSE CALL GRMARK(MLEN(ISLOT1),MVEC(MORG(ISLOT1)+1), - MVEC(MORG(ISLOT2)+1)) ENDIF END +DECK,MATPLN. SUBROUTINE MATPLN(IREF1,IREF2,IREF3) *----------------------------------------------------------------------- * MATPLN - Plots a line. * (Last changed on 1/11/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,MATDATA. +SEQ,PRINTPLOT. INTEGER IREF1,IREF2,IREF3,ISLOT1,ISLOT2,ISLOT3,I,MATSLT DOUBLE PRECISION XPL(MXLIST),YPL(MXLIST),ZPL(MXLIST) EXTERNAL MATSLT *** Indentify the routine if requested. IF(LIDENT)PRINT *,' /// ROUTINE MATPLN ///' *** Debugging output. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MATPLN DEBUG : Plotting'', - '' line vectors '',3I5)') IREF1,IREF2,IREF3 *** Locate the 3 vectors. ISLOT1=MATSLT(IREF1) ISLOT2=MATSLT(IREF2) ISLOT3=MATSLT(IREF3) IF(ISLOT1.EQ.0.OR.ISLOT2.EQ.0.OR.ISLOT3.EQ.0)THEN PRINT *,' !!!!!! MATPLN WARNING : One or more of the'// - ' plot vectors has not been found; not plotted.' RETURN ENDIF *** Verify that the 3 have the same length. IF(MLEN(ISLOT1).NE.MLEN(ISLOT2).OR. - MLEN(ISLOT2).NE.MLEN(ISLOT3))THEN PRINT *,' !!!!!! MATPLN WARNING : The 3 vectors do not'// - ' have the same length; not plotted.' RETURN ENDIF *** Verify that the length is in the range [2,MXLIST]. IF(MLEN(ISLOT1).LT.2.OR.MLEN(ISLOT1).GT.MXLIST)THEN PRINT *,' !!!!!! MATPLN WARNING : The length of the'// - ' vectors is not in the range [2,MXLIST]; not plotted.' RETURN ENDIF *** Make a double precision copy of the vector. DO 10 I=1,MLEN(ISLOT1) XPL(I)=DBLE(MVEC(MORG(ISLOT1)+I)) YPL(I)=DBLE(MVEC(MORG(ISLOT2)+I)) ZPL(I)=DBLE(MVEC(MORG(ISLOT3)+I)) 10 CONTINUE *** Plot the line. CALL PLAGPL(MLEN(ISLOT1),XPL,YPL,ZPL) END +DECK,MATPMK. SUBROUTINE MATPMK(IREF1,IREF2,IREF3) *----------------------------------------------------------------------- * MATPMK - Plots a set of markers. * (Last changed on 14/12/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,MATDATA. +SEQ,PRINTPLOT. INTEGER IREF1,IREF2,IREF3,ISLOT1,ISLOT2,ISLOT3,I,MATSLT DOUBLE PRECISION XPL(MXLIST),YPL(MXLIST),ZPL(MXLIST) EXTERNAL MATSLT *** Indentify the routine if requested. IF(LIDENT)PRINT *,' /// ROUTINE MATPMK ///' *** Debugging output. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MATPMK DEBUG : Plotting'', - '' marker vectors '',3I5)') IREF1,IREF2,IREF3 *** Locate the 3 vectors. ISLOT1=MATSLT(IREF1) ISLOT2=MATSLT(IREF2) ISLOT3=MATSLT(IREF3) IF(ISLOT1.EQ.0.OR.ISLOT2.EQ.0.OR.ISLOT3.EQ.0)THEN PRINT *,' !!!!!! MATPMK WARNING : One or more of the'// - ' plot vectors has not been found; not plotted.' RETURN ENDIF *** Verify that the 3 have the same length. IF(MLEN(ISLOT1).NE.MLEN(ISLOT2).OR. - MLEN(ISLOT2).NE.MLEN(ISLOT3))THEN PRINT *,' !!!!!! MATPMK WARNING : The 3 vectors do not'// - ' have the same length; not plotted.' RETURN ENDIF *** Verify that the length is in the range [1,MXLIST]. IF(MLEN(ISLOT1).LT.1.OR.MLEN(ISLOT1).GT.MXLIST)THEN PRINT *,' !!!!!! MATPMK WARNING : The length of the'// - ' vectors is not in the range [1,MXLIST]; not plotted.' RETURN ENDIF *** Make a double precision copy of the vector. DO 10 I=1,MLEN(ISLOT1) XPL(I)=DBLE(MVEC(MORG(ISLOT1)+I)) YPL(I)=DBLE(MVEC(MORG(ISLOT2)+I)) ZPL(I)=DBLE(MVEC(MORG(ISLOT3)+I)) 10 CONTINUE *** Plot the markers. CALL PLAGPM(MLEN(ISLOT1),XPL,YPL,ZPL) END +DECK,MATPRT. SUBROUTINE MATPRT(IREF) *----------------------------------------------------------------------- * MATPRT - Prints a matrix. * (Last changed on 25/10/95.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,MATDATA. +SEQ,PRINTPLOT. INTEGER IREF,ISLOT,IA(MXMDIM),MATADR REAL AUX CHARACTER*78 STRING CHARACTER*20 STRAUX EXTERNAL MATADR *** Check validity of reference. IF(IREF.LE.0)THEN PRINT *,' !!!!!! MATPRT WARNING : Non-positive reference'// - ' given; matrix not printed.' RETURN ENDIF *** Locate the current matrix. DO 10 I=1,MXMAT IF(MREF(I).EQ.IREF)THEN ISLOT=I GOTO 20 ENDIF 10 CONTINUE PRINT *,' !!!!!! MATPRT WARNING : Matrix to be printed has'// - ' not been found.' RETURN 20 CONTINUE *** Special case: null matrices. IF(MDIM(ISLOT).LT.1)THEN WRITE(LUNOUT,'('' (Null matrix)''/)') *** Special case: the 1-dimensional matrix. ELSEIF(MDIM(ISLOT).EQ.1)THEN NC=0 STRING=' ' DO 130 I=1,MSIZ(ISLOT,1) CALL OUTFMT(MVEC(MORG(ISLOT)+I),MMOD(ISLOT), - STRAUX,NCAUX,'LEFT') IF(NC+NCAUX+1.GT.LEN(STRING))THEN IF(NC.GE.1)WRITE(LUNOUT,'(2X,A)') STRING(1:NC) STRING(1:5)=' ' NC=5 ENDIF STRING(NC+1:NC+NCAUX+1)=STRAUX(1:NCAUX)//' ' NC=NC+NCAUX+1 130 CONTINUE WRITE(LUNOUT,'(2X,A/)') STRING(1:NC) *** Print larger matrices. ELSE * First establish an initial address vector. DO 30 I=1,MDIM(ISLOT) IA(I)=1 30 CONTINUE * Return here to print a further layer of the matrix. 120 CONTINUE * Print a header for the matrix of the last 2 dimensions. IF(MDIM(ISLOT).GT.2)THEN STRING(1:1)='[' NC=1 DO 40 I=1,MDIM(ISLOT)-2 AUX=REAL(IA(I)) CALL OUTFMT(AUX,2,STRAUX,NCAUX,'LEFT') STRING(NC+1:NC+NCAUX)=STRAUX(1:NCAUX) IF(NC+NCAUX+4.GT.LEN(STRING))THEN STRING(LEN(STRING)-7:LEN(STRING))=' ... ;;]' NC=LEN(STRING) GOTO 50 ENDIF NC=NC+NCAUX IF(I.LT.MDIM(ISLOT)-2)THEN STRING(NC+1:NC+1)=';' NC=NC+1 ENDIF 40 CONTINUE STRING(NC+1:NC+3)=';;]' NC=NC+3 50 CONTINUE WRITE(LUNOUT,'(2X,A)') STRING(1:NC) ENDIF * Print the matrix for the last 2 dimensions, find longest element. MAXLEN=0 DO 60 I=1,MSIZ(ISLOT,MDIM(ISLOT)-1) DO 70 J=1,MSIZ(ISLOT,MDIM(ISLOT)) IA(MDIM(ISLOT)-1)=I IA(MDIM(ISLOT))=J IADDR=MATADR(ISLOT,IA) CALL OUTFMT(MVEC(IADDR),MMOD(ISLOT),STRAUX,NCAUX,'LEFT') MAXLEN=MAX(MAXLEN,NCAUX) 70 CONTINUE 60 CONTINUE * And now print the matrix itself. DO 80 I=1,MSIZ(ISLOT,MDIM(ISLOT)) NC=0 STRING=' ' DO 90 J=1,MSIZ(ISLOT,MDIM(ISLOT)-1) IA(MDIM(ISLOT))=I IA(MDIM(ISLOT)-1)=J IADDR=MATADR(ISLOT,IA) CALL OUTFMT(MVEC(IADDR),MMOD(ISLOT),STRAUX,NCAUX,'RIGHT') IF(NC+MAXLEN+1.GT.LEN(STRING))THEN WRITE(LUNOUT,'(2X,A)') STRING(1:NC) STRING(1:MAXLEN+1)=' ' NC=MAXLEN+1 ENDIF STRING(NC+1:NC+MAXLEN+1)=STRAUX(LEN(STRAUX)-MAXLEN+1:)//' ' NC=NC+MAXLEN+1 90 CONTINUE WRITE(LUNOUT,'(2X,A)') STRING(1:NC) 80 CONTINUE WRITE(LUNOUT,'('' '')') * Increment the address vector. DO 100 I=1,MDIM(ISLOT)-2 IF(IA(I).LT.MSIZ(ISLOT,I))THEN IA(I)=IA(I)+1 DO 110 J=1,I-1 IA(J)=1 110 CONTINUE GOTO 120 ENDIF 100 CONTINUE ENDIF END +DECK,MATSLT. INTEGER FUNCTION MATSLT(IREF) *----------------------------------------------------------------------- * MATSLT - Finds the slot number for a matrix. * Variables: IREF - Matrix to be located. * (Last changed on 12/ 4/96.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,MATDATA. INTEGER IREF,I *** Return with 0 if out of range. IF(IREF.LE.0)THEN MATSLT=0 RETURN ENDIF *** Scan the list of matrices. DO 10 I=1,MXMAT IF(MREF(I).EQ.IREF)THEN MATSLT=I RETURN ENDIF 10 CONTINUE *** Return 0 if not found. MATSLT=0 END +DECK,MATSAV. SUBROUTINE MATSAV(VAL,NDIM,IDIM,ISIZ,NAME,IFAIL) *----------------------------------------------------------------------- * MATSAV - Assigns a matrix to a global variable. * (Last changed on 26/ 6/96.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,MATDATA. +SEQ,GLOBALS. +SEQ,PRINTPLOT. CHARACTER*(*) NAME REAL VAL(*) INTEGER IFAIL,JVAR,I,NDIM,ISIZ(*),IDIM(*),MATSLT,MATADR, - IA(MXMDIM),IADDR,JADDR EXTERNAL MATSLT,MATADR *** Tracing and debugging output. IF(LIDENT)PRINT *,' /// ROUTINE MATSAV ///' IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MATSAV DEBUG : Storing '', - I3,''-matrix to '',A,''.'')') NDIM,NAME *** Initial failure flag setting. IFAIL=1 *** Make sure that the number of dimensions is reasonable. IF(NDIM.GT.MXMDIM.OR.NDIM.LT.1)THEN PRINT *,' !!!!!! MATSAV WARNING : Number of dimensions'// - ' not in the range [1,MXMDIM]; not stored.' RETURN ENDIF *** Scan the list of global variables. JVAR=0 DO 100 I=1,NGLB IF(GLBVAR(I).EQ.NAME)JVAR=I 100 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 *,' !!!!!! MATSAV WARNING : No global variable'// - ' space left for ',NAME,'; matrix not saved.' RETURN ENDIF *** Otherwise re-use an existing global. ELSE CALL ALGREU(NINT(GLBVAL(JVAR)),GLBMOD(JVAR),0) ENDIF *** Allocate a matrix. CALL MATADM('ALLOCATE',IRMAT,NDIM,ISIZ,2,IFAIL1) * Check error condition. IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! MATSAV WARNING : Unable to allocate'// - ' space for ',NAME,'; matrix not saved.' RETURN ENDIF * Find location. ISMAT=MATSLT(IRMAT) IF(ISMAT.LE.0)THEN PRINT *,' !!!!!! MATSAV WARNING : Failure to locate'// - ' the receiving matrix; matrix not stored.' RETURN ENDIF *** Copy the array to the matrix, initial address vector. DO 10 I=1,NDIM IF(ISIZ(I).LE.0)THEN IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MATSAV DEBUG :'', - '' Dimension '',I2,'' has length < 1.'')') I RETURN ENDIF IA(I)=1 10 CONTINUE 20 CONTINUE * Compute matrix address. IADDR=MATADR(ISMAT,IA) * Compute Fortran address. JADDR=IA(NDIM)-1 DO 30 I=NDIM-1,1,-1 JADDR=JADDR*IDIM(I)+IA(I)-1 30 CONTINUE JADDR=JADDR+1 * Copy. MVEC(IADDR)=VAL(JADDR) * Update address pointer. DO 40 I=1,NDIM IF(IA(I).LT.ISIZ(I))THEN IA(I)=IA(I)+1 DO 50 J=1,I-1 IA(J)=1 50 CONTINUE GOTO 20 ENDIF 40 CONTINUE *** Assign the number to the global. GLBVAL(JVAR)=REAL(IRMAT) GLBMOD(JVAR)=5 *** Things seem to have worked. IFAIL=0 END +DECK,MT2SAV. SUBROUTINE MT2SAV(VAL,NDIM,IDIM,ISIZ,NAME,IFAIL) *----------------------------------------------------------------------- * MT2SAV - Assigns a double precision matrix to a global variable. * (Last changed on 26/ 6/96.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,MATDATA. +SEQ,GLOBALS. +SEQ,PRINTPLOT. CHARACTER*(*) NAME DOUBLE PRECISION VAL(*) INTEGER IFAIL,JVAR,I,NDIM,ISIZ(*),IDIM(*),MATSLT,MATADR, - IA(MXMDIM),IADDR,JADDR EXTERNAL MATSLT,MATADR *** Tracing and debugging output. IF(LIDENT)PRINT *,' /// ROUTINE MT2SAV ///' IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MT2SAV DEBUG : Storing '', - I3,''-matrix to '',A,''.'')') NDIM,NAME *** Initial failure flag setting. IFAIL=1 *** Make sure that the number of dimensions is reasonable. IF(NDIM.GT.MXMDIM.OR.NDIM.LT.1)THEN PRINT *,' !!!!!! MT2SAV WARNING : Number of dimensions'// - ' not in the range [1,MXMDIM]; not stored.' RETURN ENDIF *** Scan the list of global variables. JVAR=0 DO 100 I=1,NGLB IF(GLBVAR(I).EQ.NAME)JVAR=I 100 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 *,' !!!!!! MT2SAV WARNING : No global variable'// - ' space left for ',NAME,'; matrix not saved.' RETURN ENDIF *** Otherwise re-use an existing global. ELSE CALL ALGREU(NINT(GLBVAL(JVAR)),GLBMOD(JVAR),0) ENDIF *** Allocate a matrix. CALL MATADM('ALLOCATE',IRMAT,NDIM,ISIZ,2,IFAIL1) * Check error condition. IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! MT2SAV WARNING : Unable to allocate'// - ' space for ',NAME,'; matrix not saved.' RETURN ENDIF * Find location. ISMAT=MATSLT(IRMAT) IF(ISMAT.LE.0)THEN PRINT *,' !!!!!! MT2SAV WARNING : Failure to locate'// - ' the receiving matrix; matrix not stored.' RETURN ENDIF *** Copy the array to the matrix, initial address vector. DO 10 I=1,NDIM IF(ISIZ(I).LE.0)THEN IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MT2SAV DEBUG :'', - '' Dimension '',I2,'' has length < 1.'')') I RETURN ENDIF IA(I)=1 10 CONTINUE 20 CONTINUE * Compute matrix address. IADDR=MATADR(ISMAT,IA) * Compute Fortran address. JADDR=IA(NDIM)-1 DO 30 I=NDIM-1,1,-1 JADDR=JADDR*IDIM(I)+IA(I)-1 30 CONTINUE JADDR=JADDR+1 * Copy. MVEC(IADDR)=REAL(VAL(JADDR)) * Update address pointer. DO 40 I=1,NDIM IF(IA(I).LT.ISIZ(I))THEN IA(I)=IA(I)+1 DO 50 J=1,I-1 IA(J)=1 50 CONTINUE GOTO 20 ENDIF 40 CONTINUE *** Assign the number to the global. GLBVAL(JVAR)=REAL(IRMAT) GLBMOD(JVAR)=5 *** Things seem to have worked. IFAIL=0 END +DECK,MATSUB. SUBROUTINE MATSUB(ACTION,ISEL,IRSUB,IRMAT,IFAIL) *----------------------------------------------------------------------- * MATSUB - Stores in or extracts from a sub-matrix. * Variables: ACTION - Either STORE to save the matrix IRMAT in a * IRMAT submatrix of IRSUB, or EXTRACT to save a * IRSUB submatrix of IRSUB in matrix IRMAT. * ISEL - Sub matrix selection (#dim, #sel in dim1, * #sel in dim2 ..., sel dim1, sel dim2, ... * (Last changed on 12/ 4/96.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,MATDATA. +SEQ,PRINTPLOT. INTEGER IRSUB,IRMAT,ISSUB,ISMAT,ISEL(*),IA(MXMDIM),MATADR,ILEN, - ISIZ(MXMDIM),IOFF(MXMDIM),IASUB(MXMDIM),IADDR,MATSLT CHARACTER*(*) ACTION EXTERNAL MATADR,MATSLT *** Identify the routine. IF(LIDENT)PRINT *,' /// ROUTINE MATSUB ///' *** Assume this will fail. IFAIL=1 *** Check the ACTION flag. IF(ACTION.NE.'STORE'.AND.ACTION.NE.'EXTRACT')THEN PRINT *,' !!!!!! MATSUB WARNING : Unknown action'// - ' received; nothing done.' RETURN ENDIF *** Locate the matrix of which a sub-matrix is to be formed. ISSUB=MATSLT(IRSUB) IF(ISSUB.LE.0)THEN PRINT *,' !!!!!! MATSUB WARNING : Indexed matrix not found.' RETURN ENDIF *** Check that the number of dimensions matches the selection vector. IF(MDIM(ISSUB).NE.ISEL(1).OR.ISEL(1).LE.0)THEN PRINT *,' !!!!!! MATSUB WARNING : Matrix dimension and'// - ' indexing do not match.' RETURN ENDIF *** Prepare sub-matrix addressing vectors, check the dimensions. DO 90 I=1,ISEL(1) ISIZ(I)=ISEL(I+1) IF(ISIZ(I).EQ.0)ISIZ(I)=MSIZ(ISSUB,I) IF(I.EQ.1)THEN IOFF(I)=ISEL(1)+1 ELSE IOFF(I)=IOFF(I-1)+ISEL(I) ENDIF DO 100 J=IOFF(I)+1,IOFF(I)+ISEL(I+1) IF(ISEL(J).LT.1.OR.ISEL(J).GT.MSIZ(ISSUB,I))THEN PRINT *,' !!!!!! MATSUB WARNING : Indexing out of bounds'// - ' of the matrix; no sub-matrix.' RETURN ENDIF 100 CONTINUE 90 CONTINUE *** Locate the input matrix when STORE'ing. IF(ACTION.EQ.'STORE')THEN * Find the matrix. ISMAT=MATSLT(IRMAT) IF(ISMAT.LE.0)THEN PRINT *,' !!!!!! MATSUB WARNING : Input matrix has'// - ' not been found.' RETURN ENDIF * See whether the size is the same as that of the sub-matrix. ILEN=1 DO 50 I=1,ISEL(1) ILEN=ILEN*ISIZ(I) 50 CONTINUE IF(MLEN(ISMAT).NE.1.AND.ILEN.NE.MLEN(ISMAT))THEN PRINT *,' !!!!!! MATSUB WARNING : Mismatch in matrix'// - ' sizes; matrix not assigned.' RETURN ENDIF *** Or allocate a matrix when EXTRACT'ing. ELSE * Set the mode for the new matrix. IMOD=MMOD(ISSUB) * Allocate. CALL MATADM('ALLOCATE',IRMAT,ISEL(1),ISIZ,IMOD,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! MATSUB WARNING : Unable to allocate'// - ' space for the sub-matrix; not extracted.' RETURN ENDIF * Find where the new matrix sits. ISMAT=MATSLT(IRMAT) IF(ISMAT.LE.0)THEN PRINT *,' !!!!!! MATSUB WARNING : New matrix not'// - ' found; program bug - please report.' RETURN ENDIF ENDIF *** Re-locate the matrix of which a sub-matrix is to be formed. ISSUB=MATSLT(IRSUB) IF(ISSUB.LE.0)THEN PRINT *,' !!!!!! MATSUB WARNING : Indexed matrix not found.' RETURN ENDIF *** Loop over the sub matrix, initial address vector. DO 200 I=1,MDIM(ISSUB) IA(I)=1 200 CONTINUE * Initial pointer in the matrix vector. IELEM=MORG(ISMAT) * Return here for the next element. 210 CONTINUE IF(MLEN(ISMAT).EQ.1)THEN IELEM=MORG(ISMAT)+1 ELSE IELEM=IELEM+1 ENDIF * Convert the address in a true sub-matrix address. DO 240 I=1,MDIM(ISSUB) IF(ISEL(I+1).EQ.0)THEN IASUB(I)=IA(I) ELSE IASUB(I)=ISEL(IOFF(I)+IA(I)) ENDIF 240 CONTINUE * Carry out the assignments. IADDR=MATADR(ISSUB,IASUB) IF(ACTION.EQ.'STORE')THEN MVEC(IADDR)=MVEC(IELEM) ELSE MVEC(IELEM)=MVEC(IADDR) ENDIF * Increment the address vector. DO 220 I=1,MDIM(ISSUB) IF(IA(I).LT.ISIZ(I))THEN IA(I)=IA(I)+1 DO 230 J=1,I-1 IA(J)=1 230 CONTINUE GOTO 210 ENDIF 220 CONTINUE *** Seems to have worked. IFAIL=0 END +DECK,MATSUR. SUBROUTINE MATSUR(IREFM,IREFX,IREFY,XTXT,YTXT,TITLE,PHI,THETA) *----------------------------------------------------------------------- * MATSUR - Plots a surface for a matrix. * (Last changed on 19/ 8/99.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,MATDATA. +SEQ,PRINTPLOT. INTEGER MATSLT,MATADR,IA(MXMDIM),NX,NY, - ISLOTX,ISLOTY,ISLOTM,IREFX,IREFY,IREFM REAL PHI,THETA,XMIN,XMAX,YMIN,YMAX,ZMIN,ZMAX CHARACTER*(*) XTXT,YTXT,TITLE EXTERNAL MATSLT,MATADR +SELF,IF=NAG. DOUBLE PRECISION WS,CHTS PARAMETER(MXWS=MXWIRE**2+3*MXWIRE+3) COMMON /MATRIX/ WS(MXWS),CHTS(MXWIRE) +SELF,IF=HIGZ. REAL WS,PAR PARAMETER(MXWS=2*MXWIRE**2+8*MXWIRE-31) COMMON /MATRIX/ WS(MXWS),PAR(37) +SELF. *** Identify the routine if requested. IF(LIDENT)PRINT *,' /// ROUTINE MATSUR ///' *** Debugging output. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MATSUR DEBUG : Plotting'', - '' matrix '',I5,'' axes '',2I5/ - 26X,''Viewing angles: '',2F10.2,'' degrees''/ - 26X,''x-Axis label: '',A/26X,''y-Axis label: '',A/ - 26X,''Title: '',A)') - IREFM,IREFX,IREFY,PHI,THETA,XTXT,YTXT,TITLE +SELF,IF=-NAG,IF=-HIGZ. *** This routine needs either NAG or HIGZ. PRINT *,' ------ MATSUR MESSAGE : No graphics package capable'// - ' of plotting has been linked; no surface plot.' RETURN +SELF. *** Locate the matrix. ISLOTM=MATSLT(IREFM) IF(ISLOTM.LE.0)THEN PRINT *,' !!!!!! MATSUR WARNING : Matrix to be plotted'// - ' does not exist; not plotted.' RETURN ENDIF NX=MSIZ(ISLOTM,1) NY=MSIZ(ISLOTM,2) *** See whether the coordinates are present. ISLOTX=MATSLT(IREFX) IF(ISLOTX.GT.0)THEN IF(MDIM(ISLOTX).EQ.1.AND.MSIZ(ISLOTX,1).EQ.NX)THEN XMIN=MVEC(MORG(ISLOTX)+1) XMAX=MVEC(MORG(ISLOTX)+MLEN(ISLOTX)) ELSE PRINT *,' !!!!!! MATSUR WARNING : x-Coordinate'// - ' vector does not have the right format.' XMIN=0 XMAX=1 ENDIF ELSE PRINT *,' ------ MATSUR MESSAGE : x-Range of plot not'// - ' given; set to [0,1].' XMIN=0 XMAX=1 ENDIF ISLOTY=MATSLT(IREFY) IF(ISLOTY.GT.0)THEN IF(MDIM(ISLOTY).EQ.1.AND.MSIZ(ISLOTY,1).EQ.NY)THEN YMIN=MVEC(MORG(ISLOTY)+1) YMAX=MVEC(MORG(ISLOTY)+MLEN(ISLOTY)) ELSE PRINT *,' !!!!!! MATSUR WARNING : y-Coordinate'// - ' vector does not have the right format.' YMIN=0 YMAX=1 ENDIF ELSE PRINT *,' ------ MATSUR MESSAGE : y-Range of plot not'// - ' given; set to [0,1].' YMIN=0 YMAX=1 ENDIF *** Make sure that this matrix has the right dimensions. IF(MDIM(ISLOTM).NE.2.OR. - NX.LT.2.OR.NY.LT.2.OR. - NX*NY.GT.MXWS)THEN PRINT *,' !!!!!! MATSUR WARNING : The matrix to be'// - ' plotted doesn''t have the right dimensions.' RETURN ENDIF +SELF,IF=NAG,HIGZ. *** Obtain the matrix for surface plotting. CALL BOOK('BOOK','MATRIX','MATSURF',IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! MATSUR WARNING : Unable to obtain'// - ' storage for the surface plot; plot not made.' RETURN ENDIF *** Transfer the matrix to the fixed arrays, establish range. IELEM=0 DO 10 IY=1,NY DO 20 IX=1,NX IA(1)=IX IA(2)=IY IELEM=IELEM+1 WS(IELEM)=MVEC(MATADR(ISLOTM,IA)) IF(IELEM.EQ.1)THEN ZMIN=WS(IELEM) ZMAX=WS(IELEM) ELSE IF(ZMIN.GT.WS(IELEM))ZMIN=WS(IELEM) IF(ZMAX.LT.WS(IELEM))ZMAX=WS(IELEM) ENDIF 20 CONTINUE 10 CONTINUE *** Make the plot, go to to graphics mode. CALL GRGRAF(.TRUE.) +SELF,IF=NAG. * Store the CH eXPansion, NAG has the nasty habit of changing it. CALL GQCHXP(IERR,CHEXP) IF(IERR.NE.0)CHEXP=1.0 * Initialize NAG. CALL X04AAF(1,10) CALL J06WAF CALL J06WCF(0.1D0,0.9D0,0.1D0,0.9D0) CALL J06WBF(0.0D0,1.0D0,0.0D0,1.0D0,1) IFAIL=0 CALL J06HCF(WS,NX,NX,NY,DBLE(THETA), - DBLE(PHI),XTXT,YTXT,IFAIL) * Reset the CH eXPension factor to the original value, CALL GSCHXP(CHEXP) +SELF,IF=HIGZ. * Fill the PAR vector. PAR(1)=THETA PAR(2)=PHI PAR(3)=XMIN-0.5*(XMAX-XMIN)/REAL(NX-1) PAR(4)=XMAX+0.5*(XMAX-XMIN)/REAL(NX-1) PAR(5)=YMIN-0.5*(YMAX-YMIN)/REAL(NY-1) PAR(6)=YMAX+0.5*(YMAX-YMIN)/REAL(NY-1) PAR(7)=ZMIN PAR(8)=ZMAX PAR(9)=0 PAR(10)=0 PAR(11)=510 PAR(12)=510 PAR(13)=510 PAR(14)=1 PAR(15)=1 PAR(16)=1 PAR(17)=0.02 PAR(18)=0.02 PAR(19)=0.02 PAR(20)=0.03 PAR(21)=2 PAR(22)=0.03 PAR(23)=0.03 PAR(24)=0.03 PAR(25)=7 PAR(26)=8 PAR(27)=9 PAR(28)=10 PAR(29)=11 PAR(30)=12 PAR(31)=13 PAR(32)=14 PAR(33)=15 PAR(34)=16 PAR(35)=17 PAR(36)=18 PAR(37)=19 * Plot the surface. CALL ISVP(1,0.1,0.9,0.1,0.9) CALL ISWN(1,0.0,1.0,0.0,1.0) CALL ISELNT(1) CALL IGTABL(NX,NY,WS,37,PAR,'S1') +SELF. *** Plot the title at the top. CALL GSELNT(0) CALL GSTXAL(0,0) CALL GSCHUP(0.0,1.0) CALL GRATTS('TITLE','TEXT') CALL GRTX(0.1,0.95,TITLE) *** Close the plot and register it. CALL GRNEXT CALL TIMLOG('Making a 3-dimensional plot: ') CALL GRALOG('3-D plot of a matrix.') *** Release the matrix. CALL BOOK('RELEASE','MATRIX','MATSURF',IFAIL) END +DECK,MATCON. SUBROUTINE MATCON(IREFM,IREFX,IREFY,XTXT,YTXT,TITLE,NCHTS,OPTION) *----------------------------------------------------------------------- * MATCON - Plots contours for a matrix. * (Last changed on 19/ 8/99.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,MATDATA. +SEQ,PRINTPLOT. INTEGER MATSLT,MATADR,IA(MXMDIM),NX,NY,NCHTS, - ISLOTX,ISLOTY,ISLOTM,IREFX,IREFY,IREFM,IELEM REAL XMIN,XMAX,YMIN,YMAX,ZMIN,ZMAX CHARACTER*(*) XTXT,YTXT,TITLE,OPTION EXTERNAL MATSLT,MATADR +SELF,IF=NAG. DOUBLE PRECISION WS,CHTS REAL XMINP,YMINP,XMAXP,YMAXP,CHEXP PARAMETER(MXWS=MXWIRE**2+3*MXWIRE+3) COMMON /MATRIX/ WS(MXWS),CHTS(MXWIRE) COMMON /LWSCOM/ LWS LOGICAL LWS(MXWIRE**2) INTEGER ILAB,IERR EXTERNAL J06GBY,J06GBV +SELF,IF=HIGZ. REAL WS,PAR,COLFLG PARAMETER(MXWS=2*MXWIRE**2+8*MXWIRE-31) COMMON /MATRIX/ WS(MXWS),PAR(37) +SELF. *** Identify the routine if requested. IF(LIDENT)PRINT *,' /// ROUTINE MATCON ///' *** Debugging output. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MATCON DEBUG : Plotting'', - '' matrix '',I5,'' axes '',2I5,'' #contours='',I5/ - 26X,''x-Axis label: '',A/26X,''y-Axis label: '',A/ - 26X,''Title: '',A/26X,''Options: '',A/)') - IREFM,IREFX,IREFY,NCHTS,XTXT,YTXT,TITLE,OPTION +SELF,IF=-NAG,IF=-HIGZ. *** This routine needs either NAG or HIGZ. PRINT *,' ------ MATCON MESSAGE : No graphics package capable'// - ' of plotting has been linked; no contour plot.' RETURN +SELF. *** Verify number of contours. IF(NCHTS.LT.2.OR.NCHTS.GT.50)THEN PRINT *,' !!!!!! MATCON WARNING : Number of contours out'// - ' of range; set to 10.' NCHTS=10 ENDIF *** Locate the matrix. ISLOTM=MATSLT(IREFM) IF(ISLOTM.LE.0)THEN PRINT *,' !!!!!! MATCON WARNING : Matrix to be plotted'// - ' does not exist; not plotted.' RETURN ENDIF NX=MSIZ(ISLOTM,1) NY=MSIZ(ISLOTM,2) *** See whether the coordinates are present. ISLOTX=MATSLT(IREFX) IF(ISLOTX.GT.0)THEN IF(MDIM(ISLOTX).EQ.1.AND.MSIZ(ISLOTX,1).EQ.NX)THEN XMIN=MVEC(MORG(ISLOTX)+1) XMAX=MVEC(MORG(ISLOTX)+MLEN(ISLOTX)) ELSE PRINT *,' !!!!!! MATCON WARNING : x-Coordinate'// - ' vector does not have the right format.' XMIN=0 XMAX=1 ENDIF ELSE PRINT *,' ------ MATCON MESSAGE : x-Range of plot not'// - ' given; set to [0,1].' XMIN=0 XMAX=1 ENDIF ISLOTY=MATSLT(IREFY) IF(ISLOTY.GT.0)THEN IF(MDIM(ISLOTY).EQ.1.AND.MSIZ(ISLOTY,1).EQ.NY)THEN YMIN=MVEC(MORG(ISLOTY)+1) YMAX=MVEC(MORG(ISLOTY)+MLEN(ISLOTY)) ELSE PRINT *,' !!!!!! MATCON WARNING : y-Coordinate'// - ' vector does not have the right format.' YMIN=0 YMAX=1 ENDIF ELSE PRINT *,' ------ MATCON MESSAGE : y-Range of plot not'// - ' given; set to [0,1].' YMIN=0 YMAX=1 ENDIF *** Make sure that this matrix has the right dimensions. IF(MDIM(ISLOTM).NE.2.OR. - NX.LT.2.OR.NY.LT.2.OR. - NX*NY.GT.MXWS)THEN PRINT *,' !!!!!! MATCON WARNING : The matrix to be'// - ' plotted doesn''t have the right dimensions.' RETURN ENDIF +SELF,IF=NAG,HIGZ. *** Obtain the matrix for surface plotting. CALL BOOK('BOOK','MATRIX','MATCONT',IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! MATCON WARNING : Unable to obtain'// - ' storage for the surface plot; plot not made.' RETURN ENDIF *** Transfer the matrix to the fixed arrays, establish range. IELEM=0 DO 10 IY=1,NY DO 20 IX=1,NX IA(1)=IX IA(2)=IY IELEM=IELEM+1 WS(IELEM)=MVEC(MATADR(ISLOTM,IA)) IF(IELEM.EQ.1)THEN ZMIN=WS(IELEM) ZMAX=WS(IELEM) ELSE IF(ZMIN.GT.WS(IELEM))ZMIN=WS(IELEM) IF(ZMAX.LT.WS(IELEM))ZMAX=WS(IELEM) ENDIF 20 CONTINUE 10 CONTINUE *** Make the plot, go to to graphics mode. CALL GRGRAF(.TRUE.) +SELF,IF=NAG. * Store the CH eXPansion, NAG has the nasty habit of changing it. CALL GQCHXP(IERR,CHEXP) IF(IERR.NE.0)CHEXP=1.0 * Initialize NAG. CALL X04AAF(1,10) CALL J06XAF IF(INDEX(OPTION,'POLAR').EQ.0)THEN CALL GRCART(XMIN,YMIN,XMAX,YMAX,XTXT,YTXT,TITLE) CALL J06WBF(DBLE(XMIN),DBLE(XMAX),DBLE(YMIN),DBLE(YMAX),0) ELSE CALL CFMRTP(XMIN,YMIN,XMINP,YMINP,1) CALL CFMRTP(XMAX,YMAX,XMAXP,YMAXP,1) CALL GRCART(XMINP,YMINP,XMAXP,YMAXP,XTXT,YTXT,TITLE) CALL J06WBF(DBLE(XMINP),DBLE(XMAXP),DBLE(YMINP), - DBLE(YMAXP),0) ENDIF CALL J06WCF(0.1D0,0.9D0,0.1D0,0.9D0) IFAIL=1 IF(INDEX(OPTION,'LABEL').NE.0)THEN ILAB=1 ELSE ILAB=0 ENDIF CALL J06GBF(WS,NX,1,NX,1,NY,NCHTS,CHTS,0, - J06GBY,ILAB,0,J06GBV,0,LWS,IFAIL) * Reset the CH eXPension factor to the original value, CALL GSCHXP(CHEXP) +SELF,IF=HIGZ. * Compute a reasonable set of contours. CMIN=ZMIN CMAX=ZMAX IF(INDEX(OPTION,'ROUND').NE.0)THEN CALL ROUND(CMIN,CMAX,NCHTS,'SMALLER',STEP) IF(STEP.NE.0)THEN NCHTS=1+NINT((CMAX-CMIN)/STEP) ELSE CMIN=ZMIN CMAX=ZMAX NCHTS=10 ENDIF ENDIF IF(INDEX(OPTION,'COLOUR').NE.0)THEN COLFLG=0 ELSEIF(INDEX(OPTION,'TYPE').NE.0)THEN COLFLG=1 ELSE COLFLG=2 ENDIF * Fill the PAR vector. IF(COLFLG.LT.0.5)THEN PAR(1)=0 PAR(2)=0 ELSE PAR(1)=NCHTS PAR(2)=COLFLG ENDIF PAR(3)=XMIN-0.5*(XMAX-XMIN)/REAL(NX-1) PAR(4)=XMAX+0.5*(XMAX-XMIN)/REAL(NX-1) PAR(5)=YMIN-0.5*(YMAX-YMIN)/REAL(NY-1) PAR(6)=YMAX+0.5*(YMAX-YMIN)/REAL(NY-1) PAR(7)=CMIN PAR(8)=CMAX PAR(9)=0 PAR(10)=0 * Plot the contours. CALL GRCART(PAR(3),PAR(5),PAR(4),PAR(6),XTXT,YTXT,TITLE) CALL ISVP(1,0.1,0.9,0.1,0.9) CALL ISELNT(1) IF(COLFLG.LT.0.5)THEN CALL IGTABL(NX,NY,WS,10,PAR,'COL') ELSE CALL IGTABL(NX,NY,WS,10,PAR,'C') ENDIF +SELF. *** Close the plot and register it. CALL GRNEXT CALL TIMLOG('Making a contour plot of a matrix: ') CALL GRALOG('Contour plot of a matrix:') *** Release the matrix. CALL BOOK('RELEASE','MATRIX','MATCONT',IFAIL) END +DECK,MATVCR. SUBROUTINE MATVCR(IFAIL) *----------------------------------------------------------------------- * MATVCR - Reads vectors from input. * VARIABLES : IBLOCK - Block size for matrix allocation. * (Last changed on 12/ 4/96.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,MATDATA. +SEQ,GLOBALS. +SEQ,PRINTPLOT. CHARACTER*(MXCHAR) STRING INTEGER ISIZ(MXMDIM),IBLOCK,ISLOT(MXWORD),IREF(MXWORD),NVECT, - NREAD(MXWORD),IGLB(MXWORD),MATSLT REAL ELEM LOGICAL EXTEND(MXWORD),BLOCK(MXWORD),LPRINT EXTERNAL MATSLT PARAMETER(IBLOCK=100,LPRINT=.TRUE.) *** Assume the routine will fail. IFAIL=1 *** Get the number of words. CALL INPNUM(NWORD) *** Set the number of vectors to read. NVECT=NWORD-1 IF(NVECT.LT.1)THEN PRINT *,' ------ MATVCR MESSAGE : Please provide at least'// - ' one vector name as argument; nothing done.' RETURN ENDIF *** Read a word at the time. DO 10 IWORD=2,NWORD ** Fetch the name of the global. CALL INPSTR(IWORD,IWORD,STRING,NC) * Check the name starts with a character. IF(INDEX('ABCDEFGHIJKLMNOPQRSTUVWXYZ',STRING(1:1)).EQ.0)THEN PRINT *,' !!!!!! MATVCR WARNING : A vector name does'// - ' not start with a character.' RETURN ENDIF * Check for illegal characters. DO 20 I=1,NC IF(INDEX('+-*/&|<=#>^ ,.:;([{)]}''"`',STRING(I:I)).NE.0)THEN PRINT *,' !!!!!! MATVCR WARNING : A vector name'// - ' contains at least 1 illegal character; ignored.' RETURN ENDIF 20 CONTINUE * Make sure the name is not empty. IF(STRING.EQ.' '.OR.NC.LT.1)THEN PRINT *,' !!!!!! MATVCR WARNING : A vector name'// - ' is empty; definition is ignored.' RETURN ENDIF * Warn if the name is longer than 10 characters. IF(NC.GT.10)PRINT *,' !!!!!! MATVCR WARNING : A vector'// - ' name is truncated to the first 10 characters.' ** Scan the list of globals, add an entry if needed. DO 30 I=1,NGLB IF(GLBVAR(I).EQ.STRING(1:MAX(1,MIN(10,NC))))THEN IGLB(IWORD-1)=I GOTO 40 ENDIF 30 CONTINUE IF(NGLB.GE.MXVAR)THEN PRINT *,' !!!!!! MATVCR WARNING : No room to add another'// - ' global variable; definition ignored.' RETURN ENDIF NGLB=NGLB+1 IGLB(IWORD-1)=NGLB GLBVAR(IGLB(IWORD-1))=STRING(1:MAX(1,MIN(10,NC))) GLBMOD(IGLB(IWORD-1))=0 ** Ensure that this variable is not a system variable. 40 CONTINUE IF(IGLB(IWORD-1).LE.4)THEN PRINT *,' !!!!!! MATVCR WARNING : This variable may'// - ' not be user redefined.' RETURN ENDIF ** If this is not a matrix, generate one. IF(GLBMOD(IGLB(IWORD-1)).NE.5)THEN * Erase the current contents. CALL ALGREU(NINT(GLBVAL(IGLB(IWORD-1))), - GLBMOD(IGLB(IWORD-1)),0) * Create a new matrix for it. ISIZ(1)=IBLOCK IMOD=2 CALL MATADM('ALLOCATE',IREF(IWORD-1),1,ISIZ,IMOD,IFAIL1) * Quit if the matrix could not be created. IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! MATVCR WARNING : Unable to'// - ' allocate matrix storage; not read.' RETURN ENDIF * Otherwise register the array with the global variable. GLBVAL(IGLB(IWORD-1))=IREF(IWORD-1) GLBMOD(IGLB(IWORD-1))=5 * These can be extended if desired. EXTEND(IWORD-1)=.TRUE. * If already a matrix, then do/don't extend. ELSE EXTEND(IWORD-1)=.TRUE. IREF(IWORD-1)=NINT(GLBVAL(IGLB(IWORD-1))) ENDIF 10 CONTINUE *** Find the slots for the matrices and open all of them. DO 50 I=1,NVECT ISLOT(I)=MATSLT(IREF(I)) IF(ISLOT(I).LE.0)THEN PRINT *,' !!!!!! MATVCR WARNING : Matrix to be read has'// - ' not been found.' RETURN ENDIF BLOCK(I)=.FALSE. NREAD(I)=0 50 CONTINUE *** Read the contents, line by line. CALL INPPRM('Matrix','ADD-NOPRINT') 100 CONTINUE * Read a line. CALL INPWRD(NWORD) * Quit if the line is empty. IF(NWORD.EQ.0)GOTO 200 * Make sure no attempt is made to leave the section here. CALL INPSTR(1,1,STRING,NC) IF(STRING(1:1).EQ.'&')THEN PRINT *,' !!!!!! MATVCR WARNING : The section can'// - ' not be left at this point ; line ignored.' GOTO 100 ENDIF ** If only 1 vector, store the words. IF(NVECT.EQ.1)THEN * Read each word in turn. DO 110 I=1,NWORD * Skip the rest if the array is full. IF(BLOCK(1))GOTO 110 * See whether there is need to adjust array length. IF(NREAD(1)+1.GT.MLEN(ISLOT(1)))THEN IF(EXTEND(1))THEN ISIZ(1)=MLEN(ISLOT(1))+IBLOCK CALL MATADJ(IREF(1),1,ISIZ,0.0,IFAIL1) ISLOT(1)=MATSLT(IREF(1)) IF(ISLOT(1).LE.0)THEN PRINT *,' !!!!!! MATVCR WARNING : Matrix'// - ' has not been found; program bug.' RETURN ENDIF ELSE IFAIL1=1 ENDIF * Warn if adjust failed. IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! MATVCR WARNING : Vector too'// - ' short or not extendable; reading stopped.' BLOCK(1)=.TRUE. ENDIF ENDIF * Store the elements. IF(.NOT.BLOCK(1))THEN NREAD(1)=NREAD(1)+1 CALL INPCHK(I,2,IFAIL2) CALL INPRDR(I,ELEM,0.0) MVEC(MORG(ISLOT(1))+NREAD(1))=ELEM ENDIF 110 CONTINUE CALL INPERR ** Only if only 1 vector is to be read, accept any number of words. ELSEIF(NWORD.NE.NVECT)THEN PRINT *,' !!!!!! MATVCR WARNING : The # of words'// - ' differs from the # of vectors ; line ignored.' GOTO 100 ** More than 1 word: each word on the line goes to a vector. ELSE DO 120 I=1,NWORD IF(BLOCK(I))GOTO 120 * If not long enough. IF(NREAD(I)+1.GT.MLEN(ISLOT(I)))THEN * If extendable, try to extend. IF(EXTEND(I))THEN ISIZ(1)=MLEN(ISLOT(I))+IBLOCK CALL MATADJ(IREF(I),1,ISIZ,0.0,IFAIL1) * Relocate all matrices. DO 160 J=1,NVECT ISLOT(J)=MATSLT(IREF(J)) IF(ISLOT(J).LE.0)THEN PRINT *,' !!!!!! MATVCR WARNING : Matrix'// - ' to be read has not been found.' BLOCK(J)=.TRUE. ENDIF 160 CONTINUE * If not extendable, nothing much can be done. ELSE IFAIL1=1 ENDIF * Process the errors. IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! MATVCR WARNING : Vector too'// - ' short or not extendable; reading stopped.' BLOCK(I)=.TRUE. ENDIF ENDIF * If still open, read the word. IF(.NOT.BLOCK(I))THEN NREAD(I)=NREAD(I)+1 CALL INPCHK(I,2,IFAIL2) CALL INPRDR(I,ELEM,0.0) MVEC(MORG(ISLOT(I))+NREAD(I))=ELEM ENDIF * Next word. 120 CONTINUE * Print error messages. CALL INPERR ENDIF * New line of input. GOTO 100 200 CONTINUE * Reset the prompt. CALL INPPRM(' ','BACK-PRINT') *** Truncate the newly created extendable vectors to their real length. DO 210 I=1,NVECT IF(EXTEND(I))THEN ISIZ(1)=NREAD(I) CALL MATADJ(IREF(I),1,ISIZ,0.0,IFAIL1) ENDIF IF(LPRINT)WRITE(LUNOUT,'('' Matrix '',A,'' has received '', - I10,'' words.'')') GLBVAR(IGLB(I)),NREAD(I) 210 CONTINUE END +DECK,MATWRT. SUBROUTINE MATWRT(IREF,FILE,MEMB,REM,IFAIL) *----------------------------------------------------------------------- * MATWRT - This routine writes a matrix to a dataset. * VARIABLES : * (Last changed on 30/ 8/97.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,MATDATA. +SEQ,PRINTPLOT. CHARACTER*132 STRING CHARACTER*(*) FILE,MEMB,REM CHARACTER*29 REMARK CHARACTER*8 TIME,DATE,MEMBER LOGICAL EXMEMB *** Identify the routine. IF(LIDENT)PRINT *,' /// ROUTINE MATWRT ///' *** Preset IFAIL to 1: failure. IFAIL=1 *** Check whether the member already exists. CALL DSNREM(FILE,MEMB,'MATRIX',EXMEMB) IF(JEXMEM.EQ.2.AND.EXMEMB)THEN PRINT *,' ------ MATWRT MESSAGE : A copy of the member'// - ' exists; new member will be appended.' ELSEIF(JEXMEM.EQ.3.AND.EXMEMB)THEN PRINT *,' !!!!!! MATWRT WARNING : A copy of the member'// - ' exists already; member will not be written.' RETURN ENDIF *** Transfer variables. REMARK=REM MEMBER=MEMB *** Print some debugging output if requested. IF(LDEBUG)PRINT *,' ++++++ MATWRT DEBUG : Ref=',IREF, - ', File=',FILE,', member=',MEMBER,', Remark=',REMARK,'.' *** Find the slot where the matrix is stored. DO 10 I=1,MXMAT IF(MREF(I).EQ.IREF)THEN ISLOT=I GOTO 20 ENDIF 10 CONTINUE PRINT *,' !!!!!! MATWRT WARNING : Matrix to be written has'// - ' not been found.' RETURN 20 CONTINUE *** Open the dataset for sequential write and inform DSNLOG. CALL DSNOPN(FILE,LEN(FILE),12,'WRITE-LIBRARY',IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! MATWRT WARNING : Opening ',FILE, - ' failed ; matrix will not be written.' IFAIL=1 RETURN ENDIF CALL DSNLOG(FILE,'Matrix ','Sequential','Write ') IF(LDEBUG)PRINT *,' ++++++ MATWRT DEBUG : Dataset ', - FILE,' 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,'' MATRIX '', - 1X,''"'',A29,''"'')') DATE,TIME,MEMBER,REMARK WRITE(12,'(A80)',IOSTAT=IOS,ERR=2010) STRING * Write the matrix. WRITE(12,'('' MATRIX INFORMATION:''/'' Dimension: '',I10/ - '' Mode: '',I10/ - '' Sizes: '',12I10:(/12X,12I10))',IOSTAT=IOS,ERR=2010) - MDIM(ISLOT),MMOD(ISLOT),(MSIZ(ISLOT,I),I=1,MDIM(ISLOT)) WRITE(12,'('' CONTENTS''/(2X,8E15.8))',IOSTAT=IOS,ERR=2010) - (MVEC(MORG(ISLOT)+I),I=1,MLEN(ISLOT)) * Close the file after the operation. CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) CALL TIMLOG('Writing a matrix to a dataset: ') *** Things worked, reset error flag. IFAIL=0 RETURN *** Handle the error conditions. 2010 CONTINUE PRINT *,' ###### MATWRT ERROR : Error while writing'// - ' to ',FILE,' via unit 12 ; matrix not written.' CALL INPIOS(IOS) CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) RETURN 2030 CONTINUE PRINT *,' ###### MATWRT ERROR : Dataset ',FILE, - ' unit 12 cannot be closed ; results not predictable' CALL INPIOS(IOS) END +DECK,MATZRO. SUBROUTINE MATZRO(IREF1,IREF2,NZERO,ZERO,IFAIL) *----------------------------------------------------------------------- * MATZRO - Finds the zeroes of one matrix vs another. * (Last changed on 21/ 7/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,MATDATA. +SEQ,PRINTPLOT. INTEGER IREF1,IREF2,ISLOT1,ISLOT2,I,J,MATSLT,NZERO,NVEC,IFAIL REAL ZERO(MXLIST),XVEC(4),YVEC(4),DIVDIF EXTERNAL MATSLT,DIVDIF *** Indentify the routine if requested. IF(LIDENT)PRINT *,' /// ROUTINE MATZRO ///' *** Assume this will fail. IFAIL=1 *** Preset number of zeroes. NZERO=0 *** Debugging output. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MATZRO DEBUG : Searching'', - '' for zero crossings of vectors '',2I5)') IREF1,IREF2 *** Locate the 3 vectors. ISLOT1=MATSLT(IREF1) ISLOT2=MATSLT(IREF2) IF(ISLOT1.EQ.0.OR.ISLOT2.EQ.0)THEN PRINT *,' !!!!!! MATZRO WARNING : One or more of the'// - ' vectors has not been found; no zero search.' RETURN ENDIF *** Verify that the 2 have the same length. IF(MLEN(ISLOT1).NE.MLEN(ISLOT2))THEN PRINT *,' !!!!!! MATZRO WARNING : The vectors do not'// - ' have the same length; no zero search.' RETURN ENDIF *** Scan the vectors. DO 10 I=1,MLEN(ISLOT1)-1 ** See whether the starting point is a zero. IF(MVEC(MORG(ISLOT2)+I).EQ.0)THEN NZERO=NZERO+1 ZERO(NZERO)=MVEC(MORG(ISLOT1)+I) IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MATZRO DEBUG :'', - '' Point '',I4,'': '',E15.8,'' is a zero.'')') - I,ZERO(NZERO) ** Look for crossings in the interval. ELSEIF(MVEC(MORG(ISLOT2)+I)*MVEC(MORG(ISLOT2)+I+1).LT.0)THEN * Add the point below, if in the same order. NVEC=0 IF(I-1.GE.1)THEN IF((MVEC(MORG(ISLOT2)+I-1).GT. - MVEC(MORG(ISLOT2)+I).AND. - MVEC(MORG(ISLOT2)+I).GT.0).OR. - (MVEC(MORG(ISLOT2)+I-1).LT. - MVEC(MORG(ISLOT2)+I).AND. - MVEC(MORG(ISLOT2)+I).LT.0))THEN NVEC=NVEC+1 XVEC(NVEC)=MVEC(MORG(ISLOT1)+I-1) YVEC(NVEC)=MVEC(MORG(ISLOT2)+I-1) ENDIF ENDIF * Add the 2 points around the crossing. NVEC=NVEC+1 XVEC(NVEC)=MVEC(MORG(ISLOT1)+I) YVEC(NVEC)=MVEC(MORG(ISLOT2)+I) NVEC=NVEC+1 XVEC(NVEC)=MVEC(MORG(ISLOT1)+I+1) YVEC(NVEC)=MVEC(MORG(ISLOT2)+I+1) * Add the point above, if in the same order. IF(I+2.LE.MLEN(ISLOT1))THEN IF((MVEC(MORG(ISLOT2)+I+2).GT. - MVEC(MORG(ISLOT2)+I+1).AND. - MVEC(MORG(ISLOT2)+I+1).GT.0).OR. - (MVEC(MORG(ISLOT2)+I+2).LT. - MVEC(MORG(ISLOT2)+I+1).AND. - MVEC(MORG(ISLOT2)+I+1).LT.0))THEN NVEC=NVEC+1 XVEC(NVEC)=MVEC(MORG(ISLOT1)+I+2) YVEC(NVEC)=MVEC(MORG(ISLOT2)+I+2) ENDIF ENDIF * Interpolate. IF(LDEBUG)THEN WRITE(LUNOUT,'('' ++++++ MATZRO DEBUG :'', - '' Zero search over the point: '')') DO 20 J=1,NVEC WRITE(LUNOUT,'(26X,2E15.8)') XVEC(J),YVEC(J) 20 CONTINUE ENDIF NZERO=NZERO+1 IF(NZERO.LE.MXLIST)THEN ZERO(NZERO)=DIVDIF(XVEC,YVEC,NVEC,0.0,MIN(2,NVEC-1)) IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MATZRO DEBUG :'', - '' Zero at '',E15.8)') ZERO(NZERO) ELSE WRITE(LUNOUT,'('' ++++++ MATZRO DEBUG : Zero not'', - '' added, buffer is full.'')') ENDIF ENDIF 10 CONTINUE *** Check the last point. IF(MVEC(MORG(ISLOT2)+MLEN(ISLOT1)).EQ.0)THEN IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MATZRO DEBUG :'', - '' Final point '',E15.8,'' is a zero.'')') ZERO(NZERO) NZERO=NZERO+1 IF(NZERO.LE.MXLIST)ZERO(NZERO)= - MVEC(MORG(ISLOT1)+MLEN(ISLOT1)) ENDIF *** Check the total zero count. IF(NZERO.GT.MXLIST)THEN PRINT *,' !!!!!! MATZRO WARNING : Number of zeroes'// - ' exceeds MXLIST; list truncated.' NZERO=MXLIST ENDIF *** Seems to have worked. IFAIL=0 END +PATCH,VAXAST,IF=VAX,IF=AST. +DECK,ASTDOC,IF=NEVER. Copyright (C) 1988 CAJ Mekenkamp. All Rights Reserved. Carlo Mekenkamp, President Krugerstraat 42, 1975 EH IJmuiden, Holland * * Date: 10-MAR-1988 * The author of this program does not accept any responsibilities for * damage caused by use or ill-use of this program. * This program may be used in combination with FIOPAT.MAR * together with the program GARFIELD which was written by Rob Veenhof. * * PROGRAM DESCRIPTION: * * Control-C interrupt routines * * Routines below: * ASTINT - Init Control-C AST Routines * ASTXIT - Exit Control-C AST Routines * ASTECC - Enable Control-C AST * ASTDCC - Disable Control-C AST * ASTCCA - Control-C AST Routine * ASTCCH - Control-C Condition Handler * ASTSCS - Start Critical Section * ASTECS - End Critical Section * * AUTHOR: * * C.A.J. Mekenkamp * * CREATION DATE: 10-MAR-1988 * * VERSION: 2.04 * * C H A N G E L O G * * Date | Name | Description *----------------------------------------------------------------------- * [change_entry] * * Start of the routines * +DECK,ASTINT. SUBROUTINE ASTINT *----------------------------------------------------------------------- * ASTINT - Initialisation Control C AST Routines * AUTHOR : Carlo Mekenkamp /Leiden (MEKENKAM@HLERUL5) * SIDE EFFECTS: Initialize ASTCS and ASTIP to .FALSE., * Assign a channel to the terminal, * Enable control-C AST. * CREATION DATE: 10-MAR-1988 *----------------------------------------------------------------------- +SEQ,ASTCOM. INCLUDE '($SYSSRVNAM)/NOLIST' ASTCS = .FALSE. ASTIP = .FALSE. CALL SYS$ASSIGN('TT',CHAN,,) CALL ASTECC END +DECK,ASTXIT. SUBROUTINE ASTXIT *----------------------------------------------------------------------- * ASTXIT - Exitialisation Control C AST routines * AUTHOR : Carlo Mekenkamp /Leiden (MEKENKAM@HLERUL5) * SIDE EFFECTS: Disable control-C AST, * Deassign channel to terminal. * CREATION DATE: 10-MAR-1988 *----------------------------------------------------------------------- +SEQ,ASTCOM. INCLUDE '($SYSSRVNAM)/NOLIST' CALL ASTDCC CALL SYS$DASSGN(%VAL(CHAN)) END +DECK,ASTECC. SUBROUTINE ASTECC *----------------------------------------------------------------------- * ASTECC - Enables Control C AST * AUTHOR : Carlo Mekenkamp /Leiden (MEKENKAM@HLERUL5) * SIDE EFFECTS: Queues a control-C-AST to CHAN. * CREATION DATE: 10-MAR-1988 *----------------------------------------------------------------------- +SEQ,ASTCOM. EXTERNAL ASTCCA INCLUDE '($SYSSRVNAM)/NOLIST' INCLUDE '($IODEF)/NOLIST' CALL SYS$QIOW(,%VAL(CHAN),%VAL(IOR(IO$_SETMODE,IO$M_CTRLCAST)), - ,,,ASTCCA,,,,,) END +DECK,ASTDCC. SUBROUTINE ASTDCC *----------------------------------------------------------------------- * ASTDCC - Disables Control C AST * AUTHOR : Carlo Mekenkamp /Leiden (MEKENKAM@HLERUL5) * SIDE EFFECTS: Cancels control-C-AST on CHAN. * CREATION DATE: 10-MAR-1988 *----------------------------------------------------------------------- +SEQ,ASTCOM. INCLUDE '($SYSSRVNAM)/NOLIST' CALL SYS$CANCEL(%VAL(CHAN)) END +DECK,ASTCCA. SUBROUTINE ASTCCA *----------------------------------------------------------------------- * ASTCCA - This routines receives control when a control_c is typed * to the terminal. * AUTHOR : Carlo Mekenkamp /Leiden (MEKENKAM@HLERUL5) * SIDE EFFECTS: Signal SS$_CONTROLC. * CREATION DATE: 10-MAR-1988 *----------------------------------------------------------------------- +SEQ,ASTCOM. INCLUDE '($SYSSRVNAM)/NOLIST' INCLUDE '($SSDEF)/NOLIST' INCLUDE '($LIBDEF)/NOLIST' INCLUDE '($STSDEF)/NOLIST' CALL LIB$SIGNAL(%VAL(IOR(IAND(-(STS$M_SEVERITY+1), - SS$_CONTROLC),STS$K_ERROR))) END +DECK,ASTCCH. INTEGER*4 FUNCTION ASTCCH(SA, MA) *----------------------------------------------------------------------- * ASTCCH - This routine gets control if an exception occurs * when established * AUTHOR : Carlo Mekenkamp /Leiden (MEKENKAM@HLERUL5) * VARIABLES : SA : Signal Array * SA(1) Number of arguments * SA(2) Condition name * SA(3) First signal-specific argument * ... * SA(SA(1)) PC at time exception * SA(SA(1)+1) PSL at time exception * MA : Mechanism Array * MA(1) Number of mechanism arguments * MA(2) Establisher frame address * MA(3) Frame depth of establisher * MA(4) Saved register R0 * MA(5) Saved register R1 * SIDE EFFECTS: IF condition matches SS$_CONTROLC THEN * IF NOT ASTCS THEN * stack unwind to establisher of caller * enable control-C AST * ELSE * ASTIP=.TRUE. * return SS$_CONTINUE * ENDIF * ELSE * resignal * ENDIF * CREATION DATE: 10-MAR-1988 *----------------------------------------------------------------------- +SEQ,ASTCOM. INTEGER*4 SA(*), MA(5) INCLUDE '($SYSSRVNAM)/NOLIST' INCLUDE '($LIBDEF)/NOLIST' INCLUDE '($SSDEF)/NOLIST' INTEGER*4 LIB$MATCH_COND IF(LIB$MATCH_COND(SA(2),SS$_CONTROLC).EQ.1)THEN IF(ASTCS)THEN ASTIP = .TRUE. ASTCCH = SS$_CONTINUE ELSE CALL SYS$UNWIND(MA(3),) CALL ASTECC ENDIF ELSE ASTCCH = SS$_RESIGNAL ENDIF END +DECK,ASTSCS. SUBROUTINE ASTSCS *----------------------------------------------------------------------- * ASTSCS - Starts critical section in which no stack unwind may occur * AUTHOR : Carlo Mekenkamp /Leiden (MEKENKAM@HLERUL5) * SIDE EFFECTS: ASTCS = .TRUE. * CREATION DATE: 10-MAR-1988 *----------------------------------------------------------------------- +SEQ,ASTCOM. ASTCS = .TRUE. END +DECK,ASTECS. SUBROUTINE ASTECS *----------------------------------------------------------------------- * ASTECS - Ends critical section in which no stack unwind may occur * AUTHOR : Carlo Mekenkamp /Leiden (MEKENKAM@HLERUL5) * SIDE EFFECTS: ASTCS = .FALSE., * IF ASTIP THEN SIGNAL SS$_CONTROLC * CREATION DATE: 10-MAR-1988 *----------------------------------------------------------------------- +SEQ,ASTCOM. INCLUDE '($LIBDEF)/NOLIST' INCLUDE '($SSDEF)/NOLIST' INCLUDE '($STSDEF)/NOLIST' ASTCS = .FALSE. IF(ASTIP)THEN ASTIP=.FALSE. CALL LIB$SIGNAL(%VAL(IOR(IAND(-(STS$M_SEVERITY+1), - SS$_CONTROLC),STS$K_ERROR))) ENDIF END +PATCH,HELP. +DECK,HLPCNT,IF=APOLLO,CMS,UNIX. SUBROUTINE HLPCNT(NOUT,IFAIL) *----------------------------------------------------------------------- * HLPCNT - Counts the number of records the packed dataset will have. * (Last changed on 21/11/90.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. LOGICAL EXIST CHARACTER*80 IN CHARACTER*(MXHLRL) OUT *** Check the existence of both raw and processed help files. +SELF,IF=VAX. INQUIRE(FILE='HELP_RAW$GARFIELD',EXIST=EXIST) +SELF,IF=APOLLO,UNIX. INQUIRE(FILE='garfield.rawhelp',EXIST=EXIST) +SELF,IF=CMS. CALL VMCMS('STATE GARFIELD RAWHELP *',IRC) IF(IRC.EQ.0)THEN EXIST=.TRUE. ELSE EXIST=.FALSE. ENDIF +SELF. IF(.NOT.EXIST)THEN PRINT *,' !!!!!! HLPCNT WARNING : Raw help dataset not'// - ' found ; no record count.' IFAIL=1 RETURN ENDIF *** Open the raw help file. +SELF,IF=VAX. OPEN(UNIT=12,FILE='HELP_RAW$GARFIELD',STATUS='OLD',IOSTAT=IOS, - ERR=2020) +SELF,IF=APOLLO,UNIX. OPEN(UNIT=12,FILE='garfield.rawhelp',STATUS='OLD',IOSTAT=IOS, - ERR=2020) +SELF,IF=CMS. OPEN(UNIT=12,FILE='/GARFIELD RAWHELP *',STATUS='OLD',IOSTAT=IOS, - FORM='UNFORMATTED',ERR=2020) +SELF. *** Initialise various global variables. NOUT=1 NIN=0 IOUT=1 OUT=' ' ** Read a line from the file, skipping comment lines. 10 CONTINUE +SELF,IF=-CMS. READ(12,'(A80)',IOSTAT=IOS,ERR=2010,END=20) IN LENIN=80 +SELF,IF=CMS. READ(12,IOSTAT=IOS,ERR=2010,END=20,NUM=LENIN) IN +SELF. NIN=NIN+1 IF(IN(1:1).EQ.'!')GOTO 10 ** New heading level. IF(IN(1:2).NE.' ')THEN NOUT=NOUT+2 IOUT=1 OUT=' ' ** Ordinary line, simply written to the file. ELSE * Determine the length of the line. DO 100 I=LENIN,3,-1 IF(IN(I:I).NE.' ')THEN N=I GOTO 110 ENDIF 100 CONTINUE N=3 110 CONTINUE * Add the present line to the buffer. IFIRST=3 120 CONTINUE ILAST=MIN(N+1,IFIRST+MXHLRL-1) IF(IOUT+ILAST-IFIRST.GT.MXHLRL)ILAST=MXHLRL-IOUT+IFIRST IF(IOUT+ILAST-IFIRST.EQ.MXHLRL)THEN NOUT=NOUT+1 IOUT=1 OUT=' ' ELSE IOUT=IOUT+ILAST-IFIRST+1 ENDIF IFIRST=ILAST+1 IF(IFIRST.LE.N+1)GOTO 120 ENDIF GOTO 10 *** Jump to this point at EOF on the raw help file. 20 CONTINUE * Write the current record to the file, if not empty. NOUT=NOUT+1 * Close the files. CLOSE(UNIT=12,IOSTAT=IOS,ERR=2030) * Signal to the calling routine that everything worked well. IFAIL=0 IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ HLPCNT DEBUG : Expected'', - '' count of the number of output records:'',I5/26X, - ''The input file contains'',I5,'' records.'')') NOUT,NIN RETURN *** Handle I/O errors. 2010 CONTINUE PRINT *,' ###### HLPCNT ERROR : I/O error reading the raw'// - ' help file at record ',NIN,'; no record count.' CALL INPIOS(IOS) CLOSE(UNIT=12,IOSTAT=IOS,ERR=2030) IFAIL=1 RETURN 2020 CONTINUE PRINT *,' ###### HLPCNT ERROR : Unable to open the raw help'// - ' file ; no record count.' CALL INPIOS(IOS) IFAIL=1 RETURN 2030 CONTINUE PRINT *,' !!!!!! HLPCNT WARNING : Unable to close the raw'// - ' help file ; record count probably OK.' CALL INPIOS(IOS) RETURN END +DECK,HLPDEB,IF=APOLLO,CMS,UNIX. SUBROUTINE HLPDEB *----------------------------------------------------------------------- * HLPDEB - Debugging routine that dumps the entire HELP file. *----------------------------------------------------------------------- +SEQ,DIMENSIONS. INTEGER PATH(MXSUBT) CHARACTER*20 TOPIC LOGICAL EXIST *** Open the help file. +SELF,IF=VAX. INQUIRE(FILE='HELP$GARFIELD',EXIST=EXIST) +SELF,IF=APOLLO,UNIX. INQUIRE(FILE='garfield.packhelp',EXIST=EXIST) +SELF,IF=CMS. CALL VMCMS('STATE GARFIELD PACKHELP *',IRC) IF(IRC.EQ.0)THEN EXIST=.TRUE. ELSE EXIST=.FALSE. ENDIF +SELF. IF(.NOT.EXIST)THEN PRINT *,' !!!!!! HLPDEB WARNING : The HELP library can''t'// - ' be found; no help is offered.' CALL INPPRM(' ','BACK') RETURN ENDIF +SELF,IF=APOLLO,UNIX. OPEN(UNIT=17,FILE='garfield.packhelp',ACCESS='DIRECT', - STATUS='OLD',RECL=MXHLRL,IOSTAT=IOS,ERR=2020) +SELF,IF=CMS. CALL VMCMS('FILEDEF HELP CLEAR',IRC) CALL VMCMS('FILEDEF HELP DISK GARFIELD PACKHELP * (CHANGE'// - ' XTENT 2000',IRC) IF(IRC.NE.0)GOTO 2020 OPEN(UNIT=17,FILE='HELP',ACCESS='DIRECT',STATUS='OLD', - RECL=MXHLRL,FORM='UNFORMATTED',IOSTAT=IOS,ERR=2020) +SELF,IF=VAX. OPEN(UNIT=17,FILE='HELP$GARFIELD',ACCESS='DIRECT',STATUS='OLD', - IOSTAT=IOS,ERR=2020) +SELF. *** Search the entire tree, start at the root. NPATH=1 PATH(1)=1 10 CONTINUE CALL HLPINQ(PATH,NPATH,EXIST,NSUB,TOPIC,IREC,IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! HLPDEB WARNING : Inquiry for the'// - ' existence of a topic failed; help ended.' RETURN ENDIF IF(EXIST)THEN CALL HLPPRT(IREC,2*NPATH,IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! HLPDEB WARNING : Unable to print'// - ' the subtopics; help ended.' RETURN ENDIF CALL HLPSUB(IREC,2*NPATH,IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! HLPDEB WARNING : Unable to list'// - ' the subtopics; help ended.' RETURN ENDIF NPATH=NPATH+1 PATH(NPATH)=1 ELSE NPATH=NPATH-1 IF(NPATH.LE.0)THEN PRINT *,' End of listing.' CLOSE(UNIT=17,STATUS='KEEP',ERR=2030) RETURN ENDIF PATH(NPATH)=PATH(NPATH)+1 ENDIF GOTO 10 *** Handle I/O errors during opening of the file. 2020 CONTINUE PRINT *,' ###### HLPDEB WARNING : Unable to open the help file.' RETURN 2030 CONTINUE PRINT *,' ###### HLPDEB WARNING : Unable to close the help file.' END +DECK,HLPINPAL,IF=-APOLLO,IF=-CMS,IF=-UNIX,IF=-VAX. SUBROUTINE HLPINP *----------------------------------------------------------------------- * HELP - Routine providing help. *----------------------------------------------------------------------- PRINT *,' !!!!!! HLPINP WARNING : Sorry, online help'// - ' is not available on this machine.' END +DECK,HLPINPVX,IF=VAX. SUBROUTINE HLPINP *----------------------------------------------------------------------- * HLPINP - Routine calling the VAX/VMS HELP utility to display online * help information. * AUTHOR: Carlo Mekenkamp / Rijks Universiteit Leiden *----------------------------------------------------------------------- +SEQ,DIMENSIONS. CHARACTER*(MXINCH) STRING EXTERNAL LBR$OUTPUT_HELP, LIB$PUT_OUTPUT, LIB$GET_INPUT INTEGER*4 LBR$OUTPUT_HELP, LIB$PUT_OUTPUT, LIB$GET_INPUT LOGICAL EXIST *** Pick up the argument string. CALL INPNUM(NWORD) CALL INPSTR(1,NWORD,STRING,NC) IF(STRING(1:1).EQ.'?')THEN STRING(1:1)=' ' ELSEIF(NWORD.GE.2)THEN CALL INPSTR(2,NWORD,STRING,NC) ELSE NC=1 STRING=' ' ENDIF IF(STRING(1:NC).EQ.' ')THEN PRINT *,' ' PRINT *,' ------------------------------------------------' PRINT *,' ---------- Help subsection ----------' PRINT *,' ------------------------------------------------' PRINT *,' ' ENDIF *** Check for the existence of the help library. INQUIRE(FILE='HELP$GARFIELD',EXIST=EXIST) IF(.NOT.EXIST)THEN PRINT *,' !!!!!! HLPINP WARNING : Unable to find the HELP'// - ' library; check the logical HELP$GARFIELD.' RETURN ENDIF *** Call the Vax/VMS HELP facility. IERR=LBR$OUTPUT_HELP( * Output routine for HELP - LIB$PUT_OUTPUT, * Number of characters on an output line - 80, * Initial command - STRING(1:NC), * HELP library - 'HELP$GARFIELD', * Indicate that we wish further help - 1, * Input routine for HELP - LIB$GET_INPUT) *** Check the error status on return. IF(IERR.EQ.2*INT(IERR/2.0))PRINT *,' !!!!!! HLPINP WARNING :'// - ' Error status ',IERR,' received from VMS HELP.' END +DECK,HLPINPOT,IF=APOLLO,CMS,UNIX. SUBROUTINE HLPINP *----------------------------------------------------------------------- * HLPINP - Reads the help commands and fetches the information. * (Last changed on 12/ 1/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. CHARACTER*100 FILE +SELF,IF=UNIX. CHARACTER*80 HOME INTEGER NCHOME +SELF. CHARACTER*80 STRING,BLANK CHARACTER*20 TOPIC,SEARCH(MXHLEV),TOPL(MXHLEV),TOPTL(MXHLEV),AUX INTEGER PATH(MXHLEV),IRECL(MXHLEV),IRECTL(MXHLEV),NOCCUR, - INPCMP,NCFILE,IOS,NWORD,I,ISMIN,ISMAX,NC,IOLD,NPATH,NSUB, - NSUBN,IREC,IFAIL,ISTR,NCAUX +SELF,IF=CMS. INTEGER IRC +SELF. LOGICAL EXIST,MATCH,DSNCMP EXTERNAL INPCMP,DSNCMP *** Set the blank string which is used for indenting. BLANK=' ' *** Open the help file. +SELF,IF=VAX. * First try with a logical. FILE='HELP$GARFIELD' NCFILE=13 INQUIRE(FILE=FILE(1:NCFILE),EXIST=EXIST) * If this fails, try an explicit file name. IF(.NOT.EXIST)THEN FILE='GARFIELD.HLB' NCFILE=12 INQUIRE(FILE=FILE(1:NCFILE),EXIST=EXIST) ENDIF * If found, open the file. IF(EXIST)THEN OPEN(UNIT=17,FILE='HELP$GARFIELD',ACCESS='DIRECT', - STATUS='OLD',IOSTAT=IOS,ERR=2020) ELSE PRINT *,' !!!!!! HLPINP WARNING : No help library'// - ' found; try the URL' PRINT *,' http://consult'// - '.cern.ch/writeup/garfield/help' CALL INPPRM(' ','BACK') RETURN ENDIF +SELF,IF=APOLLO,UNIX. * Determine home directory. CALL GETENV('HOME',HOME) DO 50 I=LEN(HOME),1,-1 IF(HOME(I:I).NE.' ')THEN NCHOME=I GOTO 60 ENDIF 50 CONTINUE NCHOME=1 HOME=' ' 60 CONTINUE * Try a file or link in the current directory. FILE='garfield.packhelp' NCFILE=17 INQUIRE(FILE=FILE(1:NCFILE),EXIST=EXIST) IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ HLPINP DEBUG :'', - '' Checking for '',A/26X,''Existence flag: '',L1)') - FILE(1:NCFILE),EXIST * If not found, look in the home directory. IF(.NOT.EXIST)THEN FILE=HOME(1:NCHOME)//'/garfield.packhelp' NCFILE=MIN(NCHOME+18,LEN(FILE)) INQUIRE(FILE=FILE(1:NCFILE),EXIST=EXIST) IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ HLPINP DEBUG :'', - '' Checking for '',A/26X,''Existence flag: '',L1)') - FILE(1:NCFILE),EXIST ENDIF IF(.NOT.EXIST)THEN FILE=HOME(1:NCHOME)//'/.garfield.packhelp' NCFILE=MIN(NCHOME+19,LEN(FILE)) INQUIRE(FILE=FILE(1:NCFILE),EXIST=EXIST) IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ HLPINP DEBUG :'', - '' Checking for '',A/26X,''Existence flag: '',L1)') - FILE(1:NCFILE),EXIST ENDIF * If still not found, try the AFS file name. IF(.NOT.EXIST)THEN FILE='/afs/cern.ch/user/r/rjd/Garfield/Files/'// - 'garfield.packhelp' NCFILE=MIN(56,LEN(FILE)) INQUIRE(FILE=FILE(1:NCFILE),EXIST=EXIST) IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ HLPINP DEBUG :'', - '' Checking for '',A/26X,''Existence flag: '',L1)') - FILE(1:NCFILE),EXIST ENDIF * If found, open the file. IF(EXIST)THEN OPEN(UNIT=17,FILE=FILE(1:NCFILE),ACCESS='DIRECT', - STATUS='OLD',RECL=MXHLRL,IOSTAT=IOS,ERR=2020) IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ HLPINP DEBUG :'', - '' Opened '',A)') FILE(1:NCFILE) ELSE PRINT *,' !!!!!! HLPINP WARNING : No help library'// - ' found; try the URL' PRINT *,' http://consult'// - '.cern.ch/writeup/garfield/help' CALL INPPRM(' ','BACK') RETURN ENDIF +SELF,IF=CMS. CALL VMCMS('STATE GARFIELD PACKHELP *',IRC) IF(IRC.EQ.0)THEN EXIST=.TRUE. ELSE EXIST=.FALSE. ENDIF IF(.NOT.EXIST)THEN PRINT *,' !!!!!! HLPINP WARNING : No help library'// - ' found; try the URL' PRINT *,' http://consult'// - '.cern.ch/writeup/garfield/help' CALL INPPRM(' ','BACK') RETURN ENDIF CALL VMCMS('FILEDEF HELP CLEAR',IRC) CALL VMCMS('FILEDEF HELP DISK GARFIELD PACKHELP * (CHANGE'// - ' XTENT 2000',IRC) IF(IRC.NE.0)GOTO 2020 OPEN(UNIT=17,FILE='HELP',ACCESS='DIRECT',STATUS='OLD', - RECL=MXHLRL,FORM='UNFORMATTED',IOSTAT=IOS,ERR=2020) +SELF. *** Read the root record to check the date on which the file was packed. READ(UNIT=17,REC=1,ERR=2010,IOSTAT=IOS) TOPIC IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ HLPINP DEBUG :'', - '' Creation date of help library: '',A)') TOPIC(5:12) IF(DSNCMP('01-01-01',TOPIC(5:12)).OR. - DSNCMP(TOPIC(5:12),'01-01-02').OR. - TOPIC(5:12).EQ.' ')THEN PRINT *,' !!!!!! HLPINP WARNING : Mismatch between the'// - ' help file and program versions;' +SELF,IF=CMS. PRINT *,' you may have to link'// - ' the library disk at another mode,' +SELF. PRINT *,' contact the program'// - ' library office or the author.' C CLOSE(UNIT=17,STATUS='KEEP',IOSTAT=IOS,ERR=2030) C RETURN ENDIF *** Set the prompt. CALL INPPRM('Help','ADD-PRINT') *** Pick up the initial list. CALL INPNUM(NWORD) IF(NWORD.EQ.1.AND.INPCMP(1,'?')+INPCMP(1,'HELP')+ - INPCMP(1,'INFO#RMATION').NE.0)THEN PRINT *,' ------------------------------------------------' PRINT *,' ---------- Help subsection ----------' PRINT *,' ------------------------------------------------' 40 CONTINUE CALL HLPSUB(1,1,IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! HLPINP WARNING : Unable to list'// - ' the subtopics; help ended.' CLOSE(UNIT=17,STATUS='KEEP',IOSTAT=IOS,ERR=2030) RETURN ENDIF CALL INPPRM('Topic','ADD-PRINT') WRITE(LUNOUT,'('' '')') CALL INPGET CALL INPNUM(NWORD) CALL INPPRM(' ','BACK-PRINT') IF(INPCMP(1,'?').NE.0)GOTO 40 ENDIF *** Return if all parameters are absent, shouldn't be the case. IF(NWORD.EQ.0)THEN CALL INPPRM(' ','BACK') CLOSE(UNIT=17,STATUS='KEEP',IOSTAT=IOS,ERR=2030) RETURN ENDIF * Store the parameters in the search stack. ISMIN=1 ISMAX=0 DO 10 I=1,NWORD * Get the string, skip if blank. CALL INPSTR(I,I,STRING,NC) IF(NC.EQ.0.OR.STRING.EQ.' '.OR.(INPCMP(I,'?')+INPCMP(I,'HELP')+ - INPCMP(I,'INFO#RMATION').NE.0.AND.I.EQ.1))GOTO 10 * Add to the stack. IF(ISMAX+1.GT.MXHLEV)THEN PRINT *,' !!!!!! HLPINP WARNING : Too many keywords'// - ' provided, list truncated.' GOTO 30 ENDIF ISMAX=ISMAX+1 IF(I.EQ.1.AND.STRING(1:1).EQ.'?')THEN SEARCH(ISMAX)=STRING(2:NC) ELSE SEARCH(ISMAX)=STRING(1:NC) ENDIF 10 CONTINUE 30 CONTINUE *** Loop over the input. IOLD=1 20 CONTINUE * Search for the topic, starting from the root. NPATH=1 PATH(1)=1 NOCCUR=0 ** Return at this point for a next item to be examined. 100 CONTINUE ** Determine whether the item exists at all. CALL HLPINQ(PATH,NPATH,EXIST,NSUB,TOPIC,IREC,IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! HLPINP WARNING : Inquiry for the'// - ' existence of a topic failed; help ended.' CLOSE(UNIT=17,STATUS='KEEP',IOSTAT=IOS,ERR=2030) RETURN ENDIF * If it exists, check whether the strings match. IF(EXIST)THEN CALL WLDCRD(TOPIC,SEARCH(NPATH),.TRUE.,MATCH) ELSE MATCH=.FALSE. ENDIF ** Assume the strings match ... IF(EXIST.AND.MATCH)THEN * Remember the full reference string and record reference. TOPTL(NPATH)=TOPIC IRECTL(NPATH)=IREC * print if we are at the end of the tree and keep track, IF(NPATH.EQ.ISMAX)THEN NOCCUR=NOCCUR+1 NSUBN=NSUB DO 120 I=1,ISMAX TOPL(I)=TOPTL(I) IRECL(I)=IRECTL(I) 120 CONTINUE DO 130 I=1,ISMAX-1 WRITE(LUNOUT,'(1X,A)') BLANK(1:1+3*(I-1))//TOPL(I) 130 CONTINUE CALL HLPPRT(IREC,1+3*(NPATH-1),IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! HLPINP WARNING : Unable to'// - ' print the subtopics; help ended.' CLOSE(UNIT=17,STATUS='KEEP',IOSTAT=IOS,ERR=2030) RETURN ENDIF PATH(NPATH)=PATH(NPATH)+1 * if there are subtopics, go deeper, ELSEIF(NSUB.GT.0)THEN NPATH=NPATH+1 PATH(NPATH)=1 * otherwise go further on the same level. ELSE PATH(NPATH)=PATH(NPATH)+1 ENDIF ** In case the item exists but doesn't match. ELSEIF(EXIST)THEN PATH(NPATH)=PATH(NPATH)+1 ** If there is no match, return one level. ELSE NPATH=NPATH-1 IF(NPATH.LT.ISMIN)GOTO 200 PATH(NPATH)=PATH(NPATH)+1 ENDIF * And go for the next item. GOTO 100 *** Take care of the subtopics. 200 CONTINUE * Information not found, revert to old record. IF(NOCCUR.EQ.0)THEN PRINT *,' ' PRINT *,' The information you requested is not available.' PRINT *,' ' IREC=IOLD ISTR=1 * Only one occurence and subtopics for that one. ELSEIF(NOCCUR.EQ.1.AND.NSUBN.GT.0)THEN IREC=IRECL(ISMAX) IOLD=IREC ISMIN=ISMAX+1 ISTR=2 * Anything else: go back to the previous choice. ELSE IREC=IOLD ISTR=1 ENDIF * Display the subtopics. 220 CONTINUE IF(ISTR.EQ.1)THEN WRITE(LUNOUT,'('' '')') DO 230 I=1,ISMIN-1 WRITE(LUNOUT,'(1X,A)') BLANK(1:1+3*(I-1))//TOPL(I) 230 CONTINUE CALL INPPRM('Topic','ADD-PRINT') ELSE WRITE(LUNOUT,'('' '')') CALL OUTFMT(REAL(ISMIN),2,AUX,NCAUX,'LEFT') CALL INPPRM('Subtopic_'//AUX(1:NCAUX),'ADD-PRINT') ENDIF CALL HLPSUB(IREC,MAX(1,1+3*(ISMIN-2)),IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! HLPINP WARNING : Unable to list'// - ' the subtopics; help ended.' CLOSE(UNIT=17,STATUS='KEEP',IOSTAT=IOS,ERR=2030) RETURN ENDIF * And ask which of the subtopics the user likes most. WRITE(LUNOUT,'('' '')') CALL INPGET CALL INPNUM(NWORD) CALL INPSTR(1,1,STRING,NC) CALL INPPRM(' ','BACK-PRINT') IF(NWORD.EQ.1.AND.STRING.EQ.'?'.AND.NC.EQ.1)GOTO 220 * Put the new words on the stack. IF(NWORD.GE.1)THEN DO 240 I=1,NWORD IF(ISMIN+I-1.GT.MXHLEV)THEN PRINT *,' !!!!!! HLPINP WARNING : Too many keywords'// - ' provided, list truncated.' ISMAX=MXHLEV GOTO 250 ENDIF CALL INPSTR(I,I,STRING,NC) SEARCH(ISMIN+I-1)=STRING(1:NC) 240 CONTINUE ISMAX=ISMIN+NWORD-1 250 CONTINUE * Return one level if the return is blank. ELSE ISMIN=ISMIN-1 IF(ISMIN.LE.0)THEN CALL INPPRM(' ','BACK') CLOSE(UNIT=17,STATUS='KEEP',IOSTAT=IOS,ERR=2030) RETURN ENDIF IF(ISMIN.GT.1)THEN IREC=IRECL(ISMIN-1) ELSE IREC=1 ENDIF IOLD=IREC ISTR=1 GOTO 220 ENDIF *** Go back for a new input line. GOTO 20 *** Handle I/O problems. 2010 CONTINUE PRINT *,' !!!!!! HLPINP WARNING : I/O error reading the root'// - ' record of the help file ; no help can ne provided.' CALL INPIOS(IOS) CLOSE(UNIT=17,STATUS='KEEP',IOSTAT=IOS,ERR=2030) RETURN 2020 CONTINUE PRINT *,' !!!!!! HLPINP WARNING : Unable to open the help'// - ' file ; no help can be provided.' CALL INPIOS(IOS) RETURN 2030 CONTINUE PRINT *,' !!!!!! HLPINP WARNING : Unable to close the help'// - ' file after use ; future use might be troublesome.' CALL INPIOS(IOS) END +DECK,HLPINQ,IF=APOLLO,CMS,UNIX. SUBROUTINE HLPINQ(PATH,NPATH,EXIST,NSUB,TOPIC,IREC,IFAIL) *----------------------------------------------------------------------- * HLPINQ - This routine determines whether some branch exists or not * and it returns the number of subbranches (NSUB) and the * topic string (TOPIC) if it does. *----------------------------------------------------------------------- +SEQ,DIMENSIONS. INTEGER PATH(NPATH),SUBREC(MXSUBT) LOGICAL EXIST CHARACTER*20 TOPIC *** Start lifting the root reference list. NXTREC=1 *** And next trace down the path. DO 10 I=1,NPATH READ(UNIT=17,REC=NXTREC,IOSTAT=IOS,ERR=2010) - TOPIC,NREC,NSUB,(SUBREC(J),J=1,MIN(MXSUBT,NSUB)) IF(NSUB.GT.MXSUBT)THEN PRINT *,' ###### HLPINQ ERROR : Number of subrecords'// - ' exceeds MXSUBT; recompile with at least ',NSUB IFAIL=1 RETURN ENDIF * Make sure the next branch really exists, flag if not. IF(NSUB.LT.PATH(I).OR.0.GE.PATH(I))THEN EXIST=.FALSE. IFAIL=0 RETURN ENDIF * Set the next reference record. NXTREC=SUBREC(PATH(I)) 10 CONTINUE *** Passing here means the record exists. READ(UNIT=17,REC=NXTREC,IOSTAT=IOS,ERR=2010) - TOPIC,NREC,NSUB,(SUBREC(I),I=1,MIN(MXSUBT,NSUB)) IF(NSUB.GT.MXSUBT)THEN PRINT *,' ###### HLPINQ ERROR : Number of subrecords'// - ' exceeds MXSUBT; recompile with at least ',NSUB IFAIL=1 RETURN ENDIF IREC=NXTREC EXIST=.TRUE. IFAIL=0 RETURN *** Take care of I/O problems. 2010 CONTINUE PRINT *,' ###### HLPINQ ERROR : I/O error on the HELP file.' CALL INPIOS(IOS) IFAIL=1 END +DECK,HLPPACVX,IF=VAX. SUBROUTINE HLPPAC(IFAIL) *----------------------------------------------------------------------- * HLPPAC - Packs the help file into a help library. * (Last changed on 19/10/93.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. LOGICAL EXIST INTEGER LIB$SPAWN EXTERNAL LIB$SPAWN *** Figure out whether the raw help file exists. INQUIRE(FILE='HELP_RAW$GARFIELD',EXIST=EXIST) IF(.NOT.EXIST)THEN PRINT *,' !!!!!! HLPPAC WARNING : Unable to find the raw'// - ' help file; no help library made.' IFAIL=1 RETURN ENDIF *** Prepare the library, always as a new version. IERR=LIB$SPAWN( - 'LIBRARY/CREATE/HELP HELP$GARFIELD HELP_RAW$GARFIELD') *** Check the error flag. IF(IERR.EQ.2*INT(IERR/2.0))THEN IFAIL=1 ELSE IFAIL=0 ENDIF *** Keep track of CPU time consumption. CALL TIMLOG('Packing the help file') END +DECK,HLPPACOT,IF=APOLLO,CMS,UNIX. SUBROUTINE HLPPAC(IFAIL) *----------------------------------------------------------------------- * HLPPAC - Packs the help file into a direct access dataset. * (Last changed on 19/ 7/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. LOGICAL EXIST CHARACTER*500 IN CHARACTER*20 TOPIC CHARACTER*8 DATE,TIME CHARACTER*(MXHLRL) OUT INTEGER PATH(0:MXHLEV),SUBREC(0:MXSUBT),INPCMP,I,NWORD,IFAIL,IOS, - NTOTAL,NOUT,NIN,IOUT,NREC,LEVEL,LAST,LENIN,NSUB,IFIRST,J, - ILAST,N,NEWLEV,NNREC,ISTART,IEND,IADD EXTERNAL INPCMP +SELF,IF=CMS. CHARACTER*80 FILDEF LOGICAL LHLPTR INTEGER IRC,IRC1,IRC2 DATA LHLPTR /.FALSE./ +SELF,IF=VAX. +SELF. *** Determine whether character translation is to be performed. CALL INPNUM(NWORD) DO 40 I=2,NWORD IF(INPCMP(I,'TR#ANSLATE').NE.0)THEN +SELF,IF=CMS. LHLPTR=.TRUE. +SELF,IF=-CMS. CALL INPMSG(I,'Option only meaningful on IBM.') +SELF. ELSEIF(INPCMP(I,'NOTR#ANSLATE').NE.0)THEN +SELF,IF=CMS. LHLPTR=.FALSE. +SELF,IF=-CMS. CALL INPMSG(I,'Option only meaningful on IBM.') +SELF. ELSE CALL INPMSG(I,'Not a valid option. ') ENDIF 40 CONTINUE *** Check the existence of both raw and processed help files. +SELF,IF=VAX. INQUIRE(FILE='HELP_RAW$GARFIELD',EXIST=EXIST) +SELF,IF=APOLLO,UNIX. INQUIRE(FILE='garfield.rawhelp',EXIST=EXIST) +SELF,IF=CMS. CALL VMCMS('STATE GARFIELD RAWHELP *',IRC) IF(IRC.EQ.0)THEN EXIST=.TRUE. ELSE EXIST=.FALSE. ENDIF +SELF. IF(.NOT.EXIST)THEN PRINT *,' !!!!!! HLPPAC WARNING : Raw help dataset not'// - ' found ; direct access dataset not prepared.' IFAIL=1 RETURN ENDIF +SELF,IF=VAX. INQUIRE(FILE='HELP$GARFIELD',EXIST=EXIST) +SELF,IF=APOLLO,UNIX. INQUIRE(FILE='garfield.packhelp',EXIST=EXIST) +SELF,IF=CMS. CALL VMCMS('STATE GARFIELD PACKHELP A6',IRC) IF(IRC.EQ.0)THEN EXIST=.TRUE. ELSE EXIST=.FALSE. ENDIF +SELF. IF(EXIST)THEN PRINT *,' !!!!!! HLPPAC WARNING : Packed help file'// - ' exists already ; no new copy prepared.' IFAIL=1 RETURN ENDIF *** Have the number of records counted. CALL HLPCNT(NTOTAL,IFAIL) *** Open the raw and the direct access help file. +SELF,IF=APOLLO,UNIX. OPEN(UNIT=12,FILE='garfield.rawhelp',STATUS='OLD',IOSTAT=IOS, - ERR=2020) OPEN(UNIT=17,FILE='garfield.packhelp',STATUS='NEW', - ACCESS='DIRECT',RECL=MXHLRL,FORM='UNFORMATTED', - IOSTAT=IOS,ERR=2020) CALL DSNLOG('garfield.rawhelp','Raw help ','Sequential', - 'Read ') CALL DSNLOG('garfield.packhelp','HELP file ','Direct ', - 'Created ') +SELF,IF=VAX. OPEN(UNIT=12,FILE='HELP_RAW$GARFIELD',STATUS='OLD',IOSTAT=IOS, - ERR=2020) OPEN(UNIT=17,FILE='HELP$GARFIELD',STATUS='NEW',ACCESS='DIRECT', - RECL=MXHLRL/4,FORM='UNFORMATTED',MAXREC=NTOTAL, - IOSTAT=IOS,ERR=2020) CALL DSNLOG('HELP_RAW$GARFIELD','Raw help ','Sequential', - 'Read ') CALL DSNLOG('HELP$GARFIELD','HELP file ','Direct ', - 'Created ') +SELF,IF=CMS. WRITE(FILDEF,'(''FILEDEF HELP DISK GARFIELD PACKHELP A6'', - '' (XTENT '',I5)') NTOTAL CALL VMCMS('FILEDEF HELP CLEAR',IRC1) CALL VMCMS(FILDEF,IRC2) IF(IRC1.NE.0.OR.IRC2.NE.0)GOTO 2020 OPEN(UNIT=12,FILE='/GARFIELD RAWHELP *',STATUS='OLD',IOSTAT=IOS, - FORM='UNFORMATTED',ERR=2020) OPEN(UNIT=17,FILE='HELP',STATUS='NEW',ACCESS='DIRECT', - RECL=MXHLRL,FORM='UNFORMATTED',IOSTAT=IOS,ERR=2020) CALL DSNLOG('GARFIELD RAWHELP *','Raw help ','Sequential', - 'Read ') CALL DSNLOG('GARFIELD PACKHELP A6','HELP file ','Direct ', - 'Created ') +SELF. *** Initialise various global variables. NOUT=0 NIN=0 IOUT=1 NREC=0 OUT=' ' LEVEL=0 PATH(0)=1 LAST=1 ** Write the initial pointer record. CALL DATTIM(DATE,TIME) TOPIC='Root'//DATE//TIME NOUT=NOUT+1 WRITE(UNIT=17,REC=NOUT,IOSTAT=IOS,ERR=2015) TOPIC,0,0 ** Read a line from the file, skipping comment lines. 10 CONTINUE +SELF,IF=-CMS. READ(12,'(A)',IOSTAT=IOS,ERR=2010,END=20) IN LENIN=LEN(IN) +SELF,IF=CMS. READ(12,IOSTAT=IOS,ERR=2010,END=20,NUM=LENIN) IN IF(LENIN.LT.LEN(IN))IN(LENIN+1:)=' ' +SELF. NIN=NIN+1 IF(IN(1:1).EQ.'!')GOTO 10 +SELF,IF=CMS. * Translate curly brackets when the file is coming from a Vax. IF(LHLPTR)THEN DO 30 I=1,LENIN IF(ICHAR(IN(I:I)).EQ.192)IN(I:I)=CHAR(139) IF(ICHAR(IN(I:I)).EQ.208)IN(I:I)=CHAR(155) 30 CONTINUE ENDIF +SELF. ** New heading level. IF(IN(1:2).NE.' ')THEN * Empty the buffer. IF(IOUT.GT.1)THEN NOUT=NOUT+1 OUT(IOUT-1:IOUT-1)=CHAR(11) WRITE(UNIT=17,REC=NOUT,IOSTAT=IOS,ERR=2015) OUT NREC=NREC+1 ELSE NOUT=NOUT+1 WRITE(UNIT=17,REC=NOUT,IOSTAT=IOS,ERR=2015) CHAR(11) NREC=NREC+1 ENDIF IOUT=1 OUT=' ' * Read the new heading level. CALL INPRIC(IN(1:2),NEWLEV,0,IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! HLPPAC WARNING : Invalid level'// - ' string "'//IN(1:2)//'" encountered at line', - NIN,' ; packed help file deleted.' CLOSE(UNIT=12,IOSTAT=IOS,ERR=2030) CLOSE(UNIT=17,STATUS='DELETE',IOSTAT=IOS,ERR=2030) RETURN ENDIF IF(NEWLEV.GT.LEVEL+1.OR.NEWLEV.LE.0)THEN PRINT *,' !!!!!! HLPPAC WARNING : Incorrect heading'// - ' level (',NEWLEV,') encountered at line ',NIN,'.' PRINT *,' Packed help-file'// - ' deleted.' CLOSE(UNIT=12,IOSTAT=IOS,ERR=2030) CLOSE(UNIT=17,STATUS='DELETE',IOSTAT=IOS,ERR=2030) IFAIL=1 RETURN ENDIF IF(NEWLEV.GT.MXHLEV)THEN PRINT *,' !!!!!! HLPPAC WARNING : Heading level'// - ' exceeds compilation limit (',NEWLEV,' vs ', - MXHLEV,') at line ',NIN,'.' PRINT *,' Packed help-file'// - ' deleted.' CLOSE(UNIT=12,IOSTAT=IOS,ERR=2030) CLOSE(UNIT=17,STATUS='DELETE',IOSTAT=IOS,ERR=2030) IFAIL=1 RETURN ENDIF LEVEL=NEWLEV * Write an almost empty header for this topic, updated later on. NOUT=NOUT+1 WRITE(UNIT=17,REC=NOUT,IOSTAT=IOS,ERR=2015) IN(3:22),0,0 C print *,' Heading at level ',LEVEL,': ',IN(3:22) * Update the link record for the next higher level. READ(UNIT=17,REC=PATH(LEVEL-1),IOSTAT=IOS,ERR=2015) - TOPIC,NNREC,NSUB,(SUBREC(I),I=1,NSUB) NSUB=NSUB+1 IF(NSUB.GT.MXSUBT)THEN PRINT *,' ###### HLPPAC ERROR : The help file'// - ' cannot be packed because MXSUBT is too small.' CLOSE(UNIT=12,IOSTAT=IOS,ERR=2030) CLOSE(UNIT=17,STATUS='DELETE',IOSTAT=IOS,ERR=2030) IFAIL=1 RETURN ENDIF SUBREC(NSUB)=NOUT WRITE(UNIT=17,REC=PATH(LEVEL-1),IOSTAT=IOS,ERR=2015) - TOPIC,NNREC,NSUB,(SUBREC(I),I=1,NSUB) * Update the path pointer for this level. PATH(LEVEL)=NOUT * Update the number of records the previous item had. READ(UNIT=17,REC=LAST,IOSTAT=IOS,ERR=2015) - TOPIC,NNREC,NSUB,(SUBREC(I),I=1,NSUB) WRITE(UNIT=17,REC=LAST,IOSTAT=IOS,ERR=2015) - TOPIC,NREC,NSUB,(SUBREC(I),I=1,NSUB) * Update the pointer to the new last item (this one). LAST=NOUT NREC=0 ** Ordinary line, simply written to the file. ELSE * Determine the length of the line. DO 100 I=LENIN,3,-1 IF(IN(I:I).NE.' ')THEN N=I GOTO 110 ENDIF 100 CONTINUE N=3 110 CONTINUE * Compress lines which contain an HTML reference. 30 CONTINUE IF(INDEX(IN(1:N),'"->').NE.0)THEN ISTART=INDEX(IN(1:N),'"->') IEND=ISTART+INDEX(IN(ISTART+1:N),'"') IF(IEND.LE.ISTART)THEN PRINT *,' !!!!!! HLPPAC WARNING : Reference'// - ' string at line ',NIN,' not closed;'// - ' line not compressed.' GOTO 50 ENDIF IADD=ISTART DO 70 I=IEND-1,ISTART,-1 IF(IN(I:I).EQ.' ')THEN DO 80 J=I+1,IEND-1 IN(IADD:IADD)=IN(J:J) IADD=IADD+1 80 CONTINUE GOTO 90 ENDIF 70 CONTINUE 90 CONTINUE DO 60 I=IEND+1,N IN(IADD:IADD)=IN(I:I) IADD=IADD+1 60 CONTINUE IN(IADD:)=' ' N=IADD-1 GOTO 30 ENDIF 50 CONTINUE * Add the present line to the buffer, separating by a LF (ASCII 10). IFIRST=3 120 CONTINUE ILAST=MIN(N+1,IFIRST+MXHLRL-1) IF(IOUT+ILAST-IFIRST.GT.MXHLRL)ILAST=MXHLRL-IOUT+IFIRST IF(ILAST.EQ.N+1)THEN IF(ILAST.GT.IFIRST)OUT(IOUT:IOUT+ILAST-IFIRST)= - IN(IFIRST:ILAST-1)//CHAR(10) IF(ILAST.EQ.IFIRST)OUT(IOUT:IOUT)=CHAR(10) ELSE OUT(IOUT:IOUT+ILAST-IFIRST)=IN(IFIRST:ILAST) ENDIF IF(IOUT+ILAST-IFIRST.EQ.MXHLRL)THEN NOUT=NOUT+1 WRITE(UNIT=17,REC=NOUT,IOSTAT=IOS,ERR=2015) OUT IOUT=1 OUT=' ' NREC=NREC+1 ELSE IOUT=IOUT+ILAST-IFIRST+1 ENDIF IFIRST=ILAST+1 IF(IFIRST.LE.N+1)GOTO 120 ENDIF GOTO 10 *** Jump to this point at EOF on the raw help file. 20 CONTINUE * Write the current record to the file, if not empty. IF(IOUT.GT.1)THEN NOUT=NOUT+1 OUT(IOUT-1:IOUT-1)=CHAR(11) WRITE(UNIT=17,REC=NOUT,IOSTAT=IOS,ERR=2015) OUT NREC=NREC+1 ELSE NOUT=NOUT+1 WRITE(UNIT=17,REC=NOUT,IOSTAT=IOS,ERR=2015) CHAR(11) NREC=NREC+1 ENDIF * Update the number of records the final item had. READ(UNIT=17,REC=LAST,IOSTAT=IOS,ERR=2015) - TOPIC,NNREC,NSUB,(SUBREC(I),I=1,NSUB) WRITE(UNIT=17,REC=LAST,IOSTAT=IOS,ERR=2015) - TOPIC,NREC,NSUB,(SUBREC(I),I=1,NSUB) * Close the files. CLOSE(UNIT=12,IOSTAT=IOS,ERR=2030) CLOSE(UNIT=17,IOSTAT=IOS,ERR=2030) * Signal to the calling routine that everything worked well. IFAIL=0 IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ HLPPAC DEBUG : Reference'', - '' count of the number of records:'',I5)') NOUT *** Keep track of CPU time consumption. CALL TIMLOG('Packing the help file') RETURN *** Handle I/O errors. 2010 CONTINUE PRINT *,' ###### HLPPAC ERROR : I/O error reading the raw'// - ' help file at line ',NIN,' ; packed help file deleted.' CALL INPIOS(IOS) CLOSE(UNIT=12,IOSTAT=IOS,ERR=2030) CLOSE(UNIT=17,STATUS='DELETE',IOSTAT=IOS,ERR=2030) IFAIL=1 RETURN 2015 CONTINUE PRINT *,' ###### HLPPAC ERROR : I/O error on the direct'// - ' access help file ; dataset not prepared.' CALL INPIOS(IOS) CLOSE(UNIT=12,IOSTAT=IOS,ERR=2030) CLOSE(UNIT=17,STATUS='DELETE',IOSTAT=IOS,ERR=2030) IFAIL=1 RETURN 2020 CONTINUE PRINT *,' ###### HLPPAC ERROR : Unable to open a help'// - ' file ; direct access dataset not prepared.' CALL INPIOS(IOS) IFAIL=1 RETURN 2030 CONTINUE PRINT *,' !!!!!! HLPPAC WARNING : Unable to close the raw or'// - ' the packed help file ; direct access file probably OK.' CALL INPIOS(IOS) RETURN END +DECK,HLPPRT,IF=APOLLO,CMS,UNIX. SUBROUTINE HLPPRT(IREC,INDENT,IFAIL) *----------------------------------------------------------------------- * HLPPRT - Prints the item starting at record IREC * (Last changed on 20/ 7/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. INTEGER SUBREC(MXSUBT),NREC,NSUB,J,IOUT,NSTR,I0,I1,IREC,INDENT, - IFAIL,IOS CHARACTER*20 TOPIC CHARACTER*132 OUT CHARACTER*(MXSUBT) BLANK CHARACTER*(MXHLRL) STRING *** Set BLANK to blank. BLANK=' ' *** Read the heading record and loop over all records of the item. READ(UNIT=17,REC=IREC,IOSTAT=IOS,ERR=2010) - TOPIC,NREC,NSUB,(SUBREC(J),J=1,MIN(MXSUBT,NSUB)) IF(NSUB.GT.MXSUBT)THEN PRINT *,' ###### HLPPRT ERROR : Number of subrecords'// - ' exceeds MXSUBT; recompile with at least ',NSUB IFAIL=1 RETURN ENDIF * Print the TOPIC as a heading. WRITE(LUNOUT,'(1X,A,/)') BLANK(1:INDENT)//TOPIC * Record loop. OUT=' ' IOUT=1 DO 10 J=1,NREC READ(UNIT=17,REC=IREC+J,IOSTAT=IOS,ERR=2010) STRING * Determine the length of the string. NSTR=INDEX(STRING,CHAR(11))-1 IF(NSTR.EQ.-1)THEN NSTR=MXHLRL ELSEIF(NSTR.EQ.0)THEN GOTO 10 ENDIF * Figure out where the line-breaks are. I0=1 20 CONTINUE I1=I0+INDEX(STRING(I0:NSTR),CHAR(10))-2 * Take the end of the line in case there is no LF left. IF(I1.EQ.I0-2)I1=NSTR * Print or skip a line if I1 < I0. IF(I1.LT.I0)THEN IF(IOUT.GT.1)THEN WRITE(LUNOUT,'(1X,A)') BLANK(1:INDENT)//OUT(1:IOUT-1) ELSE WRITE(LUNOUT,'(1X)') ENDIF OUT=' ' IOUT=1 I0=I1+2 IF(I0.LE.NSTR)GOTO 20 * Restrict when the total record would be too long. ELSEIF(IOUT+I1-I0.GT.LEN(OUT))THEN PRINT *,' ###### HLPPRT ERROR : Record longer'// - ' than ',LEN(OUT),' characters encountered.' I1=LEN(OUT)+I0-IOUT OUT(IOUT:IOUT+I1-I0)=STRING(I0:I1) IOUT=IOUT+I1-I0+1 WRITE(LUNOUT,'(1X,A)') - BLANK(1:INDENT)//OUT(1:IOUT-1) OUT=' ' IOUT=1 I0=I1+1 IF(I0.LE.NSTR)GOTO 20 * Buffer when no line-break is present at the end of record. ELSEIF(I1.EQ.NSTR.AND.STRING(NSTR:NSTR).NE.CHAR(10))THEN OUT(IOUT:IOUT+I1-I0)=STRING(I0:I1) IOUT=IOUT+I1-I0+1 I0=I1+1 IF(I0.LE.NSTR)GOTO 20 * Output when the line-break is seen. ELSE OUT(IOUT:IOUT+I1-I0)=STRING(I0:I1) WRITE(LUNOUT,'(1X,A)') BLANK(1:INDENT)//OUT(1:IOUT+I1-I0) OUT=' ' IOUT=1 I0=I1+2 IF(I0.LE.NSTR)GOTO 20 ENDIF * Next record. 10 CONTINUE *** Print the remainder of the last record. IF(IOUT.GT.1)WRITE(LUNOUT,'(1X,A)') - BLANK(1:INDENT)//OUT(1:IOUT-1) WRITE(LUNOUT,'('' '')') *** Things worked it seems. IFAIL=0 RETURN *** Handle I/O errors. 2010 CONTINUE PRINT *,' ###### HLPPRT ERROR : I/O error on the HELP file.' CALL INPIOS(IOS) IFAIL=1 END +DECK,HLPSUB,IF=APOLLO,CMS,UNIX. SUBROUTINE HLPSUB(IREC,INDENT,IFAIL) *----------------------------------------------------------------------- * HLPSUB - List the subtopics for the item starting at record IREC. *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. INTEGER SUBREC(MXSUBT) CHARACTER*20 TOPIC CHARACTER*80 OUT CHARACTER*(MXSUBT) BLANK *** Set BLANK to blank. BLANK=' ' *** Read the heading record and loop over all records of the item. READ(UNIT=17,REC=IREC,IOSTAT=IOS,ERR=2010) - TOPIC,NREC,NSUB,(SUBREC(J),J=1,MIN(MXSUBT,NSUB)) IF(NSUB.GT.MXSUBT)THEN PRINT *,' ###### HLPSUB ERROR : Number of subrecords'// - ' exceeds MXSUBT; recompile with at least ',NSUB IFAIL=1 RETURN ENDIF *** Last record done, print the candidate subtopics. IF(NSUB.GT.0)THEN * Print a heading. WRITE(LUNOUT,'(/,1X,A,/)') - BLANK(1:INDENT)//'Additional information available:' OUT=' ' IOUT=1 * Pick up the topics one by one. DO 100 I=1,NSUB READ(UNIT=17,REC=SUBREC(I),IOSTAT=IOS,ERR=2010) TOPIC * Figure out how long the topic is. DO 110 J=20,1,-1 IF(TOPIC(J:J).NE.' ')THEN NTOPIC=J GOTO 120 ENDIF 110 CONTINUE * Substitute a string if empty. TOPIC='< not named >' NTOPIC=13 120 CONTINUE * Output the string if the new topic won't fit anymore. IF(INDENT+IOUT+NTOPIC-1.GE.80)THEN WRITE(LUNOUT,'(1X,A)') BLANK(1:INDENT)//OUT(1:IOUT) IOUT=1 OUT=' ' ENDIF * Store the subtopic names in an output string, properly tabbed. OUT(IOUT:IOUT+NTOPIC-1)=TOPIC(1:NTOPIC) DO 130 J=1,61,15 IF(OUT(MAX(1,J-2):).EQ.' ')THEN IOUT=J GOTO 100 ENDIF 130 CONTINUE * Output the string if the new topic won't fit anymore. WRITE(LUNOUT,'(1X,A)') BLANK(1:INDENT)//OUT(1:IOUT+NTOPIC-1) IOUT=1 OUT=' ' 100 CONTINUE * Don't forget to output the last piece of string. WRITE(LUNOUT,'(1X,A)') BLANK(1:INDENT)//OUT(1:IOUT) ELSE WRITE(LUNOUT,'(/,'' No subtopics.'',/)') ENDIF *** Things worked it seems. IFAIL=0 RETURN *** Handle I/O errors. 2010 CONTINUE PRINT *,' ###### HLPSUB ERROR : I/O error on the HELP file.' CALL INPIOS(IOS) IFAIL=1 END +PATCH,CELL. +DECK,CELCAL. SUBROUTINE CELCAL(INSTR,IFAIL) *----------------------------------------------------------------------- * CELCAL - Processes cell related procedure calls. * (Last changed on 1/12/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,ALGDATA. INTEGER INPCMX,IFAIL1,IFAIL2,IFAIL3,ISTR,IAUX,NARG,IPROC,NC,I,IW, - INSTR,IFAIL EXTERNAL INPCMX *** Assume the CALL will fail. IFAIL=1 *** Verify that we really have a cell. IF(.NOT.CELSET)THEN PRINT *,' !!!!!! CELCAL WARNING : Cell data not available'// - ' ; call not executed.' RETURN ENDIF *** Some easy reference variables. NARG=INS(INSTR,3) IPROC=INS(INSTR,1) ** Get general information about the cell. IF(IPROC.EQ.-11)THEN * Check number of arguments. IF(NARG.GT.4)THEN PRINT *,' !!!!!! CELCAL WARNING : Incorrect number'// - ' of arguments for GET_CELL_DATA.' RETURN * Check the the results can be transferred back. ELSEIF((NARG.GE.1.AND.ARGREF(1,1).GE.2).OR. - (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))THEN PRINT *,' !!!!!! CELCAL WARNING : Some arguments'// - ' of GET_CELL_DATA can not be modified.' RETURN ENDIF * Variables already in use as strings ? DO 200 ISTR=1,NARG CALL ALGREU(NINT(ARG(ISTR)),MODARG(ISTR),ARGREF(ISTR,1)) 200 CONTINUE * Store the cell information. IF(NARG.GE.1)THEN ARG(1)=REAL(NWIRE) MODARG(1)=2 ENDIF IF(NARG.GE.2)THEN CALL STRBUF('STORE',IAUX,TYPE,3,IFAIL1) ARG(2)=REAL(IAUX) MODARG(2)=1 ELSE IFAIL1=0 ENDIF IF(NARG.GE.3)THEN IF(POLAR)THEN CALL STRBUF('STORE',IAUX,'Polar',5,IFAIL2) ELSEIF(TUBE)THEN CALL STRBUF('STORE',IAUX,'Tube',4,IFAIL2) ELSE CALL STRBUF('STORE',IAUX,'Cartesian',9,IFAIL2) ENDIF ARG(3)=REAL(IAUX) MODARG(3)=1 ELSE IFAIL2=0 ENDIF IF(NARG.GE.4)THEN DO 300 I=LEN(CELLID),1,-1 IF(CELLID(I:I).NE.' ')THEN NC=I GOTO 310 ENDIF 300 CONTINUE NC=1 310 CONTINUE CALL STRBUF('STORE',IAUX,CELLID,NC,IFAIL3) ARG(4)=REAL(IAUX) MODARG(4)=1 ELSE IFAIL3=0 ENDIF * Error processing. IF(IFAIL1.NE.0.OR.IFAIL2.NE.0.OR.IFAIL3.NE.0) - PRINT *,' !!!!!! CELCAL WARNING : Error storing'// - ' strings for GET_CELL_DATA.' *** Get the cell size. ELSEIF(IPROC.EQ.-12)THEN * Check number of arguments. IF(NARG.NE.6.AND.NARG.NE.4)THEN PRINT *,' !!!!!! CELCAL WARNING : Incorrect number'// - ' of arguments for GET_CELL_SIZE.' RETURN * Check the the results can be transferred back. ELSEIF(ARGREF(1,1).GE.2.OR.ARGREF(2,1).GE.2.OR. - ARGREF(3,1).GE.2.OR.ARGREF(4,1).GE.2.OR. - (NARG.EQ.6.AND.ARGREF(5,1).GE.2).OR. - (NARG.EQ.6.AND.ARGREF(6,1).GE.2))THEN PRINT *,' !!!!!! CELCAL WARNING : Some arguments'// - ' of GET_CELL_SIZE can not be modified.' RETURN ENDIF * Variables already in use as strings ? DO 210 ISTR=1,NARG CALL ALGREU(NINT(ARG(ISTR)),MODARG(ISTR),ARGREF(ISTR,1)) 210 CONTINUE * Store the cell size. IF(NARG.EQ.4)THEN ARG(1)=XMIN MODARG(1)=2 ARG(2)=YMIN MODARG(2)=2 ARG(3)=XMAX MODARG(3)=2 ARG(4)=YMAX MODARG(4)=2 ELSE ARG(1)=XMIN MODARG(1)=2 ARG(2)=YMIN MODARG(2)=2 ARG(3)=ZMIN MODARG(3)=2 ARG(4)=XMAX MODARG(4)=2 ARG(5)=YMAX MODARG(5)=2 ARG(6)=ZMAX MODARG(6)=2 ENDIF *** Get wire information. ELSEIF(IPROC.EQ.-13)THEN * Check number of arguments. IF(NARG.LT.2.OR.NARG.GT.10)THEN PRINT *,' !!!!!! CELCAL WARNING : Incorrect number'// - ' of arguments for GET_WIRE_DATA.' RETURN * Check the the results can be transferred back. ELSEIF((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.GE.10.AND.ARGREF(10,1).GE.2))THEN PRINT *,' !!!!!! CELCAL WARNING : Some arguments'// - ' of GET_WIRE_DATA can not be modified.' RETURN ENDIF * Verify the wire number. IF(MODARG(1).NE.2.OR.ABS(ARG(1)-ANINT(ARG(1))).GT.1E-3.OR. - NINT(ARG(1)).LE.0.OR.NINT(ARG(1)).GT.NWIRE)THEN PRINT *,' CELCAL WARNING : The wire number in the'// - ' GET_WIRE_DATA call is not valid.' RETURN ENDIF * Variables already in use as strings ? DO 220 ISTR=2,NARG CALL ALGREU(NINT(ARG(ISTR)),MODARG(ISTR),ARGREF(ISTR,1)) 220 CONTINUE * Store the wire information. IW=NINT(ARG(1)) IF(NARG.GE.2)THEN ARG(2)=X(IW) MODARG(2)=2 ENDIF IF(NARG.GE.3)THEN ARG(3)=Y(IW) MODARG(3)=2 ENDIF IF(NARG.GE.4)THEN ARG(4)=V(IW) MODARG(4)=2 ENDIF IF(NARG.GE.5)THEN ARG(5)=D(IW) MODARG(5)=2 ENDIF IF(NARG.GE.6)THEN ARG(6)=E(IW) MODARG(6)=2 ENDIF IF(NARG.GE.7)THEN CALL STRBUF('STORE',IAUX,WIRTYP(IW),1,IFAIL1) ARG(7)=IAUX MODARG(7)=1 ELSE IFAIL1=0 ENDIF IF(NARG.GE.8)THEN ARG(8)=U(IW) MODARG(8)=2 ENDIF IF(NARG.GE.9)THEN ARG(9)=W(IW) MODARG(9)=2 ENDIF IF(NARG.GE.10)THEN ARG(10)=DENS(IW) MODARG(10)=2 ENDIF * Error processing. IF(IFAIL1.NE.0)PRINT *,' !!!!!! CELCAL WARNING : Error'// - ' storing strings for GET_WIRE_DATA.' *** Get information about the planes in x. ELSEIF(IPROC.EQ.-14)THEN * Check number of arguments. IF(NARG.NE.8)THEN PRINT *,' !!!!!! CELCAL WARNING : Incorrect number'// - ' of arguments for GET_X_PLANES.' RETURN * Check the the results can be transferred back. ELSEIF(ARGREF(1,1).GE.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.OR.ARGREF(6,1).GE.2.OR. - ARGREF(7,1).GE.2.OR.ARGREF(8,1).GE.2)THEN PRINT *,' !!!!!! CELCAL WARNING : Some arguments'// - ' of GET_X_PLANES can not be modified.' RETURN ENDIF * Variables already in use as strings ? DO 230 ISTR=1,8 CALL ALGREU(NINT(ARG(ISTR)),MODARG(ISTR),ARGREF(ISTR,1)) 230 CONTINUE * Store the information about the planes. IF(YNPLAN(1))THEN ARG(1)=1 ARG(2)=COPLAN(1) ARG(3)=VTPLAN(1) CALL STRBUF('STORE',IAUX,PLATYP(1),1,IFAIL1) ARG(4)=REAL(IAUX) MODARG(1)=3 MODARG(2)=2 MODARG(3)=2 MODARG(4)=1 ELSE ARG(1)=0 ARG(2)=0 ARG(3)=0 ARG(4)=0 MODARG(1)=3 MODARG(2)=0 MODARG(3)=0 MODARG(4)=0 ENDIF IF(YNPLAN(2))THEN ARG(5)=1 ARG(6)=COPLAN(2) ARG(7)=VTPLAN(2) CALL STRBUF('STORE',IAUX,PLATYP(2),1,IFAIL1) ARG(8)=REAL(IAUX) MODARG(5)=3 MODARG(6)=2 MODARG(7)=2 MODARG(8)=1 ELSE ARG(5)=0 ARG(6)=0 ARG(7)=0 ARG(8)=0 MODARG(5)=3 MODARG(6)=0 MODARG(7)=0 MODARG(8)=0 ENDIF *** Get information about the planes in y. ELSEIF(IPROC.EQ.-15)THEN * Check number of arguments. IF(NARG.NE.8)THEN PRINT *,' !!!!!! CELCAL WARNING : Incorrect number'// - ' of arguments for GET_Y_PLANES.' RETURN * Check the the results can be transferred back. ELSEIF(ARGREF(1,1).GE.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.OR.ARGREF(6,1).GE.2.OR. - ARGREF(7,1).GE.2.OR.ARGREF(8,1).GE.2)THEN PRINT *,' !!!!!! CELCAL WARNING : Some arguments'// - ' of GET_Y_PLANES can not be modified.' RETURN ENDIF * Variables already in use as strings ? DO 235 ISTR=1,8 CALL ALGREU(NINT(ARG(ISTR)),MODARG(ISTR),ARGREF(ISTR,1)) 235 CONTINUE * Store the information about the planes. IF(YNPLAN(3))THEN ARG(1)=1 ARG(2)=COPLAN(3) ARG(3)=VTPLAN(3) CALL STRBUF('STORE',IAUX,PLATYP(3),1,IFAIL1) ARG(4)=REAL(IAUX) MODARG(1)=3 MODARG(2)=2 MODARG(3)=2 MODARG(4)=1 ELSE ARG(1)=0 ARG(2)=0 ARG(3)=0 ARG(4)=0 MODARG(1)=3 MODARG(2)=0 MODARG(3)=0 MODARG(4)=0 ENDIF IF(YNPLAN(4))THEN ARG(5)=1 ARG(6)=COPLAN(4) ARG(7)=VTPLAN(4) CALL STRBUF('STORE',IAUX,PLATYP(4),1,IFAIL1) ARG(8)=REAL(IAUX) MODARG(5)=3 MODARG(6)=2 MODARG(7)=2 MODARG(8)=1 ELSE ARG(5)=0 ARG(6)=0 ARG(7)=0 ARG(8)=0 MODARG(5)=3 MODARG(6)=0 MODARG(7)=0 MODARG(8)=0 ENDIF *** Get information about periodicities. ELSEIF(IPROC.EQ.-16)THEN * Check number of arguments. IF(NARG.NE.4)THEN PRINT *,' !!!!!! CELCAL WARNING : Incorrect number'// - ' of arguments for GET_PERIODS.' RETURN * Check the the results can be transferred back. ELSEIF(ARGREF(1,1).GE.2.OR.ARGREF(2,1).GE.2.OR. - ARGREF(3,1).GE.2.OR.ARGREF(4,1).GE.2)THEN PRINT *,' !!!!!! CELCAL WARNING : Some arguments'// - ' of GET_PERIODS can not be modified.' RETURN ENDIF * Variables already in use ? DO 240 ISTR=1,4 CALL ALGREU(NINT(ARG(ISTR)),MODARG(ISTR),ARGREF(ISTR,1)) 240 CONTINUE * Store the periodicity information. MODARG(1)=3 MODARG(2)=2 IF(PERX)THEN ARG(1)=1 ARG(2)=SX ELSE ARG(1)=0 ARG(2)=0 ENDIF MODARG(3)=3 MODARG(4)=2 IF(PERY)THEN ARG(3)=1 ARG(4)=SY ELSE ARG(3)=0 ARG(4)=0 ENDIF *** Unknown cell operation. ELSE PRINT *,' !!!!!! CELCAL WARNING : Unknown procedure code'// - ' received; nothing done.' IFAIL=1 RETURN ENDIF *** Seems to have worked. IFAIL=0 END +DECK,CELCHK. SUBROUTINE CELCHK(IFAIL) *----------------------------------------------------------------------- * CELCHK - Subroutine checking the wire positions, The equipotential * planes and the periodicity. Two planes having different * voltages are not allowed to have a common line, wires are * not allowed to be at the same position etc. * This routine determines also the cell-dimensions. * VARIABLE : WRONG(I) : .TRUE. if wire I will be removed * IPLAN. : Number of wires with coord > than plane . * (Last changed on 29/11/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,FIELDMAP. +SEQ,PRINTPLOT. +SEQ,PARAMETERS. +SEQ,CONSTANTS. LOGICAL WRONG(MXWIRE),WRMATX(MXMATT),WRMATY(MXMATT),OK, - SETX,SETY,SETZ,SETV REAL CONEW1,CONEW2,CONEW3,CONEW4,COHLP,VTHLP,XNEW,YNEW, - XPRT,YPRT,XPRTI,YPRTI,XPRTJ,YPRTJ,XSEPAR,YSEPAR, - XAUX1,YAUX1,XAUX2,YAUX2,SMIN,SMAX,GAP INTEGER IFAIL,I,J,IPLAN1,IPLAN2,IPLAN3,IPLAN4,IWIRE,NXOLD,NYOLD, - IOUT,NC1,NC2,NC3,NC4,IFAIL1,NELEM,NHLP CHARACTER*10 USER CHARACTER*20 STR1,STR2,STR3,STR4 CHARACTER LABHLP *** Identify the routine. IF(LIDENT)PRINT *,' /// ROUTINE CELCHK ///' IFAIL=1 OK=.TRUE. *** See whether this is a field map cell. CALL BOOK('INQUIRE','MAP',USER,IFAIL1) * Unable to tell: reset the field map. IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! CELCHK WARNING : Unable to obtain'// - ' field map allocation information ; assumed to'// - ' be a non-field map cell.' OK=.FALSE. CALL MAPINT * Field map chamber: ensure that there are no other elements. ELSEIF(USER.EQ.'CELL')THEN IF(TUBE)THEN TUBE=.FALSE. PRINT *,' !!!!!! CELCHK WARNING : Field map cell'// - ' found to have a tube; tube deleted.' OK=.FALSE. ENDIF IF(POLAR)THEN POLAR=.FALSE. PRINT *,' !!!!!! CELCHK WARNING : Field map cell'// - ' found to be polar; set to Cartesian.' OK=.FALSE. ENDIF IF(NWIRE.NE.0)THEN NWIRE=0 PRINT *,' !!!!!! CELCHK WARNING : Wires found in'// - ' field map cell; wires deleted.' OK=.FALSE. ENDIF IF(YNPLAN(1).OR.YNPLAN(2).OR.YNPLAN(3).OR.YNPLAN(4))THEN YNPLAN(1)=.FALSE. YNPLAN(2)=.FALSE. YNPLAN(3)=.FALSE. YNPLAN(4)=.FALSE. PRINT *,' !!!!!! CELCHK WARNING : Plane found in'// - ' field map cell; planes deleted.' OK=.FALSE. ENDIF IF(NXMATT.NE.0.OR.NYMATT.NE.0)THEN NXMATT=0 NYMATT=0 PRINT *,' !!!!!! CELCHK WARNING : Dielectric slab'// - ' found in a field map cell; dielectrica deleted.' OK=.FALSE. ENDIF IF(NMAP.LE.0.OR..NOT.MAPFLG(1))THEN PRINT *,' ###### CELCHK ERROR : The field map has'// - ' no elements or no mesh; cell rejected.' RETURN ENDIF GOTO 3000 ENDIF *** Checks on the planes, first move the x planes to the basic cell. IF(PERX)THEN CONEW1=COPLAN(1)-SX*ANINT(COPLAN(1)/SX) CONEW2=COPLAN(2)-SX*ANINT(COPLAN(2)/SX) * Check that they are not one on top of the other. IF(YNPLAN(1).AND.YNPLAN(2).AND.CONEW1.EQ.CONEW2)THEN IF(CONEW1.GT.0.0)THEN CONEW1=CONEW1-SX ELSE CONEW2=CONEW2+SX ENDIF ENDIF * Print some warnings if the planes have been moved. IF((CONEW1.NE.COPLAN(1).AND.YNPLAN(1)).OR. - (CONEW2.NE.COPLAN(2).AND.YNPLAN(2))) - PRINT *,' ------ CELCHK MESSAGE : The planes in x or'// - ' r are moved to the basic period; this should'// - ' not affect the results.' COPLAN(1)=CONEW1 COPLAN(2)=CONEW2 * Two planes should now be separated by SX, cancel PERX if not. IF(YNPLAN(1).AND.YNPLAN(2).AND. - ABS(COPLAN(2)-COPLAN(1)).NE.SX)THEN PRINT *,' !!!!!! CELCHK WARNING : The separation of'// - ' the x or r planes does not match the period;'// - ' the periodicity is cancelled.' PERX=.FALSE. OK=.FALSE. ENDIF * If there are two planes left, they should have identical V's. IF(YNPLAN(1).AND.YNPLAN(2).AND.VTPLAN(1).NE.VTPLAN(2))THEN PRINT *,' !!!!!! CELCHK WARNING : The voltages of'// - ' the two x (or r) planes differ;'// - ' the periodicity is cancelled.' PERX=.FALSE. OK=.FALSE. ENDIF ENDIF ** Idem for the y or r planes: move them to the basic period. IF(PERY)THEN CONEW3=COPLAN(3)-SY*ANINT(COPLAN(3)/SY) CONEW4=COPLAN(4)-SY*ANINT(COPLAN(4)/SY) * Check that they are not one on top of the other. IF(YNPLAN(3).AND.YNPLAN(4).AND.CONEW3.EQ.CONEW4)THEN IF(CONEW3.GT.0.0)THEN CONEW3=CONEW3-SY ELSE CONEW4=CONEW4+SY ENDIF ENDIF * Print some warnings if the planes have been moved. IF((CONEW3.NE.COPLAN(3).AND.YNPLAN(3)).OR. - (CONEW4.NE.COPLAN(4).AND.YNPLAN(4))) - PRINT *,' ------ CELCHK MESSAGE : The planes in y'// - ' are moved to the basic period; this should'// - ' not affect the results.' COPLAN(3)=CONEW3 COPLAN(4)=CONEW4 * Two planes should now be separated by SY, cancel PERY if not. IF(YNPLAN(3).AND.YNPLAN(4).AND. - ABS(COPLAN(4)-COPLAN(3)).NE.SY)THEN PRINT *,' !!!!!! CELCHK WARNING : The separation of'// - ' the two y planes does not match the period;'// - ' the periodicity is cancelled.' PERY=.FALSE. OK=.FALSE. ENDIF * If there are two planes left, they should have identical V's. IF(YNPLAN(3).AND.YNPLAN(4).AND.VTPLAN(3).NE.VTPLAN(4))THEN PRINT *,' !!!!!! CELCHK WARNING : The voltages of'// - ' the two y planes differ;'// - ' the periodicity is cancelled.' PERY=.FALSE. OK=.FALSE. ENDIF ENDIF ** Check that there is no voltage conflict of crossing planes. DO 20 I=1,2 DO 10 J=3,4 IF(YNPLAN(I).AND.YNPLAN(J).AND.VTPLAN(I).NE.VTPLAN(J))THEN PRINT *,' !!!!!! CELCHK WARNING : Conflicting potential of', - ' 2 crossing planes; one y (or phi) plane is removed.' YNPLAN(J)=.FALSE. OK=.FALSE. ENDIF 10 CONTINUE 20 CONTINUE ** Make sure the the coordinates of the planes are properly ordered. DO 30 I=1,3,2 IF(YNPLAN(I).AND.YNPLAN(I+1))THEN IF(COPLAN(I).EQ.COPLAN(I+1))THEN PRINT *,' !!!!!! CELCHK WARNING : Two planes are on'// - ' top of each other; one of them is removed.' YNPLAN(I+1)=.FALSE. OK=.FALSE. ENDIF IF(COPLAN(I).GT.COPLAN(I+1))THEN IF(LDEBUG)PRINT *,' ++++++ CELCHK DEBUG : Planes ',I, - ' and ',I+1,' are interchanged.' COHLP=COPLAN(I) COPLAN(I)=COPLAN(I+1) COPLAN(I+1)=COHLP VTHLP=VTPLAN(I) VTPLAN(I)=VTPLAN(I+1) VTPLAN(I+1)=VTHLP LABHLP=PLATYP(I) PLATYP(I)=PLATYP(I+1) PLATYP(I+1)=LABHLP DO 300 J=1,MXPSTR SMIN=PLSTR1(I,J,1) SMAX=PLSTR1(I,J,2) GAP= PLSTR1(I,J,3) LABHLP=PSLAB1(I,J) PLSTR1(I,J,1)=PLSTR1(I+1,J,1) PLSTR1(I,J,2)=PLSTR1(I+1,J,2) PLSTR1(I,J,3)=PLSTR1(I+1,J,3) PSLAB1(I,J)=PSLAB1(I+1,J) PLSTR1(I+1,J,1)=SMIN PLSTR1(I+1,J,2)=SMAX PLSTR1(I+1,J,3)=GAP PSLAB1(I+1,J)=LABHLP SMIN=PLSTR2(I,J,1) SMAX=PLSTR2(I,J,2) GAP= PLSTR2(I,J,3) LABHLP=PSLAB2(I,J) PLSTR2(I,J,1)=PLSTR2(I+1,J,1) PLSTR2(I,J,2)=PLSTR2(I+1,J,2) PLSTR2(I,J,3)=PLSTR2(I+1,J,3) PSLAB2(I,J)=PSLAB2(I+1,J) PLSTR2(I+1,J,1)=SMIN PLSTR2(I+1,J,2)=SMAX PLSTR2(I+1,J,3)=GAP PSLAB2(I+1,J)=LABHLP 300 CONTINUE NHLP=NPSTR1(I) NPSTR1(I)=NPSTR1(I+1) NPSTR1(I+1)=NHLP NHLP=NPSTR2(I) NPSTR2(I)=NPSTR2(I+1) NPSTR2(I+1)=NHLP ENDIF ENDIF 30 CONTINUE *** Checks on the wires, start moving them to the basic x period. IF(PERX)THEN DO 40 I=1,NWIRE XNEW=X(I)-SX*ANINT(X(I)/SX) IF(ANINT(X(I)/SX).NE.0)THEN XPRT=X(I) YPRT=Y(I) IF(POLAR)CALL CFMRTP(XPRT,YPRT,XPRT,YPRT,1) CALL OUTFMT(XPRT,2,STR1,NC1,'LEFT') CALL OUTFMT(YPRT,2,STR2,NC2,'LEFT') PRINT *,' ------ CELCHK MESSAGE : The '//WIRTYP(I)// - '-wire at ('//STR1(1:NC1)//','//STR2(1:NC2)// - ') is moved to the basic x' PRINT *,' (or r) period;'// - ' this should not affect the results.' ENDIF X(I)=XNEW 40 CONTINUE ENDIF ** In case of y-periodicity, all wires should be in the first y-period. IF(TUBE.AND.PERY)THEN DO 55 I=1,NWIRE XNEW=X(I) YNEW=Y(I) CALL CFMCTP(XNEW,YNEW,XNEW,YNEW,1) IF(ANINT((PI*YNEW)/(SY*180.0)).NE.0)THEN CALL OUTFMT(X(I),2,STR1,NC1,'LEFT') CALL OUTFMT(Y(I),2,STR2,NC2,'LEFT') PRINT *,' ------ CELCHK MESSAGE : The '//WIRTYP(I)// - '-wire at ('//STR1(1:NC1)//','//STR2(1:NC2)// - ') is moved to the basic phi period;' PRINT *,' this should not', - ' affect the results.' YNEW=YNEW-180*SY*ANINT((PI*YNEW)/(SY*180.0))/PI CALL CFMPTC(XNEW,YNEW,X(I),Y(I),1) ENDIF 55 CONTINUE ELSEIF(PERY)THEN DO 50 I=1,NWIRE YNEW=Y(I)-SY*ANINT(Y(I)/SY) IF(ANINT(Y(I)/SY).NE.0)THEN XPRT=X(I) YPRT=Y(I) IF(POLAR)CALL CFMRTP(XPRT,YPRT,XPRT,YPRT,1) CALL OUTFMT(XPRT,2,STR1,NC1,'LEFT') CALL OUTFMT(YPRT,2,STR2,NC2,'LEFT') PRINT *,' ------ CELCHK MESSAGE : The '//WIRTYP(I)// - '-wire at ('//STR1(1:NC1)//','//STR2(1:NC2)// - ') is moved to the basic y period;' PRINT *,' this should not', - ' affect the results.' ENDIF Y(I)=YNEW 50 CONTINUE ENDIF *** Make sure the plane numbering is standard: P1 wires P2, P3 wires P4. IPLAN1=0 IPLAN2=0 IPLAN3=0 IPLAN4=0 DO 60 I=1,NWIRE IF(YNPLAN(1).AND.X(I).LE.COPLAN(1))IPLAN1=IPLAN1+1 IF(YNPLAN(2).AND.X(I).LE.COPLAN(2))IPLAN2=IPLAN2+1 IF(YNPLAN(3).AND.Y(I).LE.COPLAN(3))IPLAN3=IPLAN3+1 IF(YNPLAN(4).AND.Y(I).LE.COPLAN(4))IPLAN4=IPLAN4+1 60 CONTINUE * find out whether smaller (-1) or larger (+1) coord. are to be kept. IF(YNPLAN(1).AND.YNPLAN(2))THEN IF(IPLAN1.GT.NWIRE/2)THEN YNPLAN(2)=.FALSE. IPLAN1=-1 ELSE IPLAN1=+1 ENDIF IF(IPLAN2.LT.NWIRE/2)THEN YNPLAN(1)=.FALSE. IPLAN2=+1 ELSE IPLAN2=-1 ENDIF ENDIF IF(YNPLAN(1).AND..NOT.YNPLAN(2))THEN IF(IPLAN1.GT.NWIRE/2)THEN IPLAN1=-1 ELSE IPLAN1=+1 ENDIF ENDIF IF(YNPLAN(2).AND..NOT.YNPLAN(1))THEN IF(IPLAN2.LT.NWIRE/2)THEN IPLAN2=+1 ELSE IPLAN2=-1 ENDIF ENDIF IF(YNPLAN(3).AND.YNPLAN(4))THEN IF(IPLAN3.GT.NWIRE/2)THEN YNPLAN(4)=.FALSE. IPLAN3=-1 ELSE IPLAN3=+1 ENDIF IF(IPLAN4.LT.NWIRE/2)THEN YNPLAN(3)=.FALSE. IPLAN4=+1 ELSE IPLAN4=-1 ENDIF ENDIF IF(YNPLAN(3).AND..NOT.YNPLAN(4))THEN IF(IPLAN3.GT.NWIRE/2)THEN IPLAN3=-1 ELSE IPLAN3=+1 ENDIF ENDIF IF(YNPLAN(4).AND..NOT.YNPLAN(3))THEN IF(IPLAN4.LT.NWIRE/2)THEN IPLAN4=+1 ELSE IPLAN4=-1 ENDIF ENDIF * Adapt the numbering of the planes if necessary. IF(IPLAN1.EQ.-1)THEN YNPLAN(1)=.FALSE. YNPLAN(2)=.TRUE. COPLAN(2)=COPLAN(1) VTPLAN(2)=VTPLAN(1) PLATYP(2)=PLATYP(1) DO 310 J=1,MXPSTR PLSTR1(2,J,1)=PLSTR1(1,J,1) PLSTR1(2,J,2)=PLSTR1(1,J,2) PLSTR1(2,J,3)=PLSTR1(1,J,3) PSLAB1(2,J)= PSLAB1(1,J) PLSTR2(2,J,1)=PLSTR2(1,J,1) PLSTR2(2,J,2)=PLSTR2(1,J,2) PLSTR2(2,J,3)=PLSTR2(1,J,3) PSLAB2(2,J)= PSLAB2(1,J) 310 CONTINUE NPSTR1(2)= NPSTR1(1) NPSTR2(2)= NPSTR2(1) NPSTR1(1)= 0 NPSTR2(1)= 0 ENDIF IF(IPLAN2.EQ.+1)THEN YNPLAN(2)=.FALSE. YNPLAN(1)=.TRUE. COPLAN(1)=COPLAN(2) VTPLAN(1)=VTPLAN(2) PLATYP(1)=PLATYP(2) DO 320 J=1,MXPSTR PLSTR1(1,J,1)=PLSTR1(2,J,1) PLSTR1(1,J,2)=PLSTR1(2,J,2) PLSTR1(1,J,3)=PLSTR1(2,J,3) PSLAB1(1,J)= PSLAB1(2,J) PLSTR2(1,J,1)=PLSTR2(2,J,1) PLSTR2(1,J,2)=PLSTR2(2,J,2) PLSTR2(1,J,3)=PLSTR2(2,J,3) PSLAB2(1,J)= PSLAB2(2,J) 320 CONTINUE NPSTR1(1)= NPSTR1(2) NPSTR2(1)= NPSTR2(2) NPSTR1(2)= 0 NPSTR2(2)= 0 ENDIF IF(IPLAN3.EQ.-1)THEN YNPLAN(3)=.FALSE. YNPLAN(4)=.TRUE. COPLAN(4)=COPLAN(3) VTPLAN(4)=VTPLAN(3) PLATYP(4)=PLATYP(3) DO 330 J=1,MXPSTR PLSTR1(4,J,1)=PLSTR1(3,J,1) PLSTR1(4,J,2)=PLSTR1(3,J,2) PLSTR1(4,J,3)=PLSTR1(3,J,3) PSLAB1(4,J)= PSLAB1(3,J) PLSTR2(4,J,1)=PLSTR2(3,J,1) PLSTR2(4,J,2)=PLSTR2(3,J,2) PLSTR2(4,J,3)=PLSTR2(3,J,3) PSLAB2(4,J)= PSLAB2(3,J) 330 CONTINUE NPSTR1(4)= NPSTR1(3) NPSTR2(4)= NPSTR2(3) NPSTR1(3)= 0 NPSTR2(3)= 0 ENDIF IF(IPLAN4.EQ.+1)THEN YNPLAN(4)=.FALSE. YNPLAN(3)=.TRUE. COPLAN(3)=COPLAN(4) VTPLAN(3)=VTPLAN(4) PLATYP(3)=PLATYP(4) DO 340 J=1,MXPSTR PLSTR1(3,J,1)=PLSTR1(4,J,1) PLSTR1(3,J,2)=PLSTR1(4,J,2) PLSTR1(3,J,3)=PLSTR1(4,J,3) PSLAB1(3,J)= PSLAB1(4,J) PLSTR2(3,J,1)=PLSTR2(4,J,1) PLSTR2(3,J,2)=PLSTR2(4,J,2) PLSTR2(3,J,3)=PLSTR2(4,J,3) PSLAB2(3,J)= PSLAB2(4,J) 340 CONTINUE NPSTR1(3)= NPSTR1(4) NPSTR2(3)= NPSTR2(4) NPSTR1(4)= 0 NPSTR2(4)= 0 ENDIF *** Second pass for the wires, check position relative to the planes. DO 70 I=1,NWIRE WRONG(I)=.FALSE. IF(YNPLAN(1).AND.X(I)-.5*D(I).LE.COPLAN(1))WRONG(I)=.TRUE. IF(YNPLAN(2).AND.X(I)+.5*D(I).GE.COPLAN(2))WRONG(I)=.TRUE. IF(YNPLAN(3).AND.Y(I)-.5*D(I).LE.COPLAN(3))WRONG(I)=.TRUE. IF(YNPLAN(4).AND.Y(I)+.5*D(I).GE.COPLAN(4))WRONG(I)=.TRUE. IF(TUBE)THEN CALL INTUBE(X(I),Y(I),COTUBE,NTUBE,IOUT) IF(IOUT.NE.0)THEN CALL OUTFMT(X(I),2,STR1,NC1,'LEFT') CALL OUTFMT(Y(I),2,STR2,NC2,'LEFT') PRINT *,' !!!!!! CELCHK WARNING : The '//WIRTYP(I)// - '-wire at ('//STR1(1:NC1)//','//STR2(1:NC2)// - ') is located outside the tube; removed.' WRONG(I)=.TRUE. OK=.FALSE. ENDIF ELSEIF(WRONG(I))THEN XPRT=X(I) YPRT=Y(I) IF(POLAR)CALL CFMRTP(XPRT,YPRT,XPRT,YPRT,1) CALL OUTFMT(XPRT,2,STR1,NC1,'LEFT') CALL OUTFMT(YPRT,2,STR2,NC2,'LEFT') PRINT *,' !!!!!! CELCHK WARNING : The '//WIRTYP(I)// - '-wire at ('//STR1(1:NC1)//','//STR2(1:NC2)// - ') is located outside the planes; it is removed.' OK=.FALSE. ELSEIF((PERX.AND.D(I).GE.SX).OR.(PERY.AND.D(I).GE.SY))THEN XPRT=X(I) YPRT=Y(I) IF(POLAR)CALL CFMRTP(XPRT,YPRT,XPRT,YPRT,1) CALL OUTFMT(XPRT,2,STR1,NC1,'LEFT') CALL OUTFMT(YPRT,2,STR2,NC2,'LEFT') PRINT *,' !!!!!! CELCHK WARNING : The diameter of the '// - WIRTYP(I)//'-wire at ('//STR1(1:NC1)//','// - STR2(1:NC2)//') exceeds 1 period; it is removed.' WRONG(I)=.TRUE. OK=.FALSE. ENDIF 70 CONTINUE ** Check the wire spacing. DO 90 I=1,NWIRE IF(WRONG(I))GOTO 90 DO 80 J=I+1,NWIRE IF(WRONG(J))GOTO 80 IF(TUBE)THEN IF(PERY)THEN CALL CFMCTP(X(I),Y(I),XAUX1,YAUX1,1) CALL CFMCTP(X(J),Y(J),XAUX2,YAUX2,1) YAUX1=YAUX1-SY*ANINT(YAUX1/SY) YAUX2=YAUX2-SY*ANINT(YAUX2/SY) CALL CFMPTC(XAUX1,YAUX1,XAUX1,YAUX1,1) CALL CFMPTC(XAUX2,YAUX2,XAUX2,YAUX2,1) XSEPAR=XAUX1-XAUX2 YSEPAR=YAUX1-YAUX2 ELSE XSEPAR=X(I)-X(J) YSEPAR=Y(I)-Y(J) ENDIF ELSE XSEPAR=ABS(X(I)-X(J)) IF(PERX)XSEPAR=XSEPAR-SX*ANINT(XSEPAR/SX) YSEPAR=ABS(Y(I)-Y(J)) IF(PERY)YSEPAR=YSEPAR-SY*ANINT(YSEPAR/SY) ENDIF IF(XSEPAR**2+YSEPAR**2.LT.0.25*(D(I)+D(J))**2)THEN XPRTI=X(I) YPRTI=Y(I) XPRTJ=X(J) YPRTJ=Y(J) IF(POLAR)CALL CFMRTP(XPRTI,YPRTI,XPRTI,YPRTI,1) IF(POLAR)CALL CFMRTP(XPRTJ,YPRTJ,XPRTJ,YPRTJ,1) CALL OUTFMT(XPRTI,2,STR1,NC1,'LEFT') CALL OUTFMT(YPRTI,2,STR2,NC2,'LEFT') CALL OUTFMT(XPRTJ,2,STR3,NC3,'LEFT') CALL OUTFMT(YPRTJ,2,STR4,NC4,'LEFT') PRINT *,' !!!!!! CELCHK WARNING : The '//WIRTYP(I)// - '-wire at ('//STR1(1:NC1)//','//STR2(1:NC2)//') and'// - ' the '//WIRTYP(J)//'-wire at ('//STR3(1:NC3)//','// - STR4(1:NC4)//')' PRINT *,' overlap at least', - ' partially; the latter is removed.' WRONG(J)=.TRUE. OK=.FALSE. ENDIF 80 CONTINUE 90 CONTINUE ** Remove the wires which are not acceptable for one reason or another. IWIRE=NWIRE NWIRE=0 DO 100 I=1,IWIRE IF(.NOT.WRONG(I))THEN NWIRE=NWIRE+1 X(NWIRE)=X(I) Y(NWIRE)=Y(I) D(NWIRE)=D(I) V(NWIRE)=V(I) WIRTYP(NWIRE)=WIRTYP(I) ENDIF 100 CONTINUE *** Ensure that some elements are left. NELEM=NWIRE IF(YNPLAN(1))NELEM=NELEM+1 IF(YNPLAN(2))NELEM=NELEM+1 IF(YNPLAN(3))NELEM=NELEM+1 IF(YNPLAN(4))NELEM=NELEM+1 IF(TUBE)NELEM=NELEM+1 IF(NELEM.LT.2)THEN PRINT *,' ###### CELCHK ERROR : Neither a field map,'// - ' nor at least 2 elements; cell rejected.' OK=.FALSE. RETURN ENDIF *** Check dielectrica, initialise the remove flag for the slabs. DO 150 I=1,MXMATT WRMATX(I)=.FALSE. WRMATY(I)=.FALSE. 150 CONTINUE * Check overlapping x-slabs and kill slabs outside the planes. DO 160 I=1,NXMATT IF(WRMATX(I))GOTO 160 DO 170 J=I+1,NXMATT IF(WRMATX(J))GOTO 170 IF(XMATT(I,3).NE.0.AND.XMATT(J,3).NE.0)THEN PRINT *,' !!!!!! CELCHK WARNING : Two dielectric slabs'// - ' extend to -infinity in x ; one is removed.' WRMATX(J)=.TRUE. OK=.FALSE. ELSEIF(XMATT(I,4).NE.0.AND.XMATT(J,4).NE.0)THEN PRINT *,' !!!!!! CELCHK WARNING : Two dielectric slabs'// - ' extend to +infinity in x ; one is removed.' WRMATX(J)=.TRUE. OK=.FALSE. ELSEIF((XMATT(I,3).NE.0.AND.XMATT(I,2).GT.XMATT(J,1)).OR. - (XMATT(I,4).NE.0.AND.XMATT(I,1).LT.XMATT(J,2)).OR. - (XMATT(J,3).NE.0.AND.XMATT(J,2).GT.XMATT(I,1)).OR. - (XMATT(J,4).NE.0.AND.XMATT(J,1).LT.XMATT(I,2)))THEN PRINT *,' !!!!!! CELCHK WARNING : A dielectric'// - ' semi-infinite x-slab overlaps partially' PRINT *,' with another x-slab.'// - ' One of the slabs is removed.' WRMATX(J)=.TRUE. OK=.FALSE. ELSEIF(XMATT(I,3).EQ.0.AND.XMATT(I,4).EQ.0.AND. - XMATT(J,3).EQ.0.AND.XMATT(J,4).EQ.0.AND. - ((XMATT(I,1)-XMATT(J,1))*(XMATT(J,1)-XMATT(I,2)).GT.0.OR. - (XMATT(I,1)-XMATT(J,2))*(XMATT(J,2)-XMATT(I,2)).GT.0))THEN PRINT *,' !!!!!! CELCHK WARNING : Two finite dielectric'// - ' x-slabs overlap (in part) ; one is removed.' WRMATX(J)=.TRUE. OK=.FALSE. ENDIF 170 CONTINUE IF(WRMATX(I))GOTO 160 IF((YNPLAN(1).AND. - (XMATT(I,3).NE.0.OR.COPLAN(1).GT.XMATT(I,1))).OR. - (YNPLAN(2).AND. - (XMATT(I,4).NE.0.OR.COPLAN(2).LT.XMATT(I,2))))THEN PRINT *,' !!!!!! CELCHK WARNING : A dielectric x-slab'// - ' covers a plane ; it is removed.' WRMATX(I)=.TRUE. OK=.FALSE. ENDIF IF(WRMATX(I))GOTO 160 IF(PERX.AND.(XMATT(I,3).NE.0.OR.XMATT(I,4).NE.0.OR. - ABS(XMATT(I,1)-XMATT(I,2)).GT.SX))THEN PRINT *,' !!!!!! CELCHK WARNING : The dielectric x-slab'// - ' from (',XMATT(I,1),' to ',XMATT(I,2),')' PRINT *,' covers more than one'// - ' x-period ; it is removed.' WRMATX(I)=.TRUE. OK=.FALSE. ENDIF 160 CONTINUE * Check overlapping y-slabs and kill slabs outside the planes. DO 180 I=1,NYMATT IF(WRMATY(I))GOTO 180 DO 190 J=I+1,NYMATT IF(WRMATY(J))GOTO 190 IF(YMATT(I,3).NE.0.AND.YMATT(J,3).NE.0)THEN PRINT *,' !!!!!! CELCHK WARNING : Two dielectric slabs'// - ' extend to -infinity in y ; one is removed.' WRMATY(J)=.TRUE. OK=.FALSE. ELSEIF(YMATT(I,4).NE.0.AND.YMATT(J,4).NE.0)THEN PRINT *,' !!!!!! CELCHK WARNING : Two dielectric slabs'// - ' extend to +infinity in y ; one is removed.' WRMATY(J)=.TRUE. OK=.FALSE. ELSEIF((YMATT(I,3).NE.0.AND.YMATT(I,2).GT.YMATT(J,1)).OR. - (YMATT(I,4).NE.0.AND.YMATT(I,1).LT.YMATT(J,2)).OR. - (YMATT(J,3).NE.0.AND.YMATT(J,2).GT.YMATT(I,1)).OR. - (YMATT(J,4).NE.0.AND.YMATT(J,1).LT.YMATT(I,2)))THEN PRINT *,' !!!!!! CELCHK WARNING : A dielectric'// - ' semi-infinite y-slab overlaps partially' PRINT *,' with another y-slab.'// - ' One of the slabs is removed.' WRMATY(J)=.TRUE. OK=.FALSE. ELSEIF(YMATT(I,3).EQ.0.AND.YMATT(I,4).EQ.0.AND. - YMATT(J,3).EQ.0.AND.YMATT(J,4).EQ.0.AND. - ((YMATT(I,1)-YMATT(J,1))*(YMATT(J,1)-YMATT(I,2)).GT.0.OR. - (YMATT(I,1)-YMATT(J,2))*(YMATT(J,2)-YMATT(I,2)).GT.0))THEN PRINT *,' !!!!!! CELCHK WARNING : Two finite dielectric'// - ' y-slabs overlap (in part) ; one is removed.' WRMATY(J)=.TRUE. OK=.FALSE. ENDIF 190 CONTINUE IF(WRMATY(I))GOTO 180 IF((YNPLAN(3).AND. - (YMATT(I,3).NE.0.OR.COPLAN(3).GT.YMATT(I,1))).OR. - (YNPLAN(4).AND. - (YMATT(I,4).NE.0.OR.COPLAN(4).LT.YMATT(I,2))))THEN PRINT *,' !!!!!! CELCHK WARNING : A dielectric y-slab'// - ' covers a plane ; it is removed.' WRMATY(I)=.TRUE. OK=.FALSE. ENDIF IF(WRMATY(I))GOTO 180 IF(PERX.AND.(YMATT(I,3).NE.0.OR.YMATT(I,4).NE.0.OR. - ABS(YMATT(I,1)-YMATT(I,2)).GT.SX))THEN PRINT *,' !!!!!! CELCHK WARNING : The dielectric y-slab'// - ' from (',YMATT(I,1),' to ',YMATT(I,2),')' PRINT *,' covers more than one'// - ' x-period ; it is removed.' WRMATY(I)=.TRUE. OK=.FALSE. ENDIF 180 CONTINUE * And finally crossing slabs with different epsilons. DO 200 I=1,NXMATT IF(WRMATX(I))GOTO 200 DO 210 J=1,NYMATT IF(WRMATY(J))GOTO 210 IF(ABS(XMATT(I,5)-YMATT(J,5)).GT.1.0E-5*(1.0+ABS(XMATT(I,5))+ - ABS(YMATT(J,5))))THEN PRINT *,' !!!!!! CELCHK WARNING : A dielectric x-slab'// - ' crosses a y-slab but has a' PRINT *,' different dielectric'// - ' constant; the x-slab is removed.' WRMATX(I)=.TRUE. OK=.FALSE. ENDIF 210 CONTINUE 200 CONTINUE * Remove slabs, first x, than y. NXOLD=NXMATT NXMATT=0 DO 220 I=1,NXOLD IF(WRMATX(I))GOTO 220 NXMATT=NXMATT+1 DO 230 J=1,5 XMATT(NXMATT,J)=XMATT(I,J) 230 CONTINUE 220 CONTINUE NYOLD=NYMATT NYMATT=0 DO 240 I=1,NYOLD IF(WRMATY(I))GOTO 240 NYMATT=NYMATT+1 DO 250 J=1,5 YMATT(NYMATT,J)=YMATT(I,J) 250 CONTINUE 240 CONTINUE *** Determine maximum and minimum coordinates and potentials. SETX=.FALSE. SETY=.FALSE. SETZ=.FALSE. SETV=.FALSE. XMIN=0 XMAX=0 YMIN=0 YMAX=0 ZMIN=0 ZMAX=0 VMIN=0 VMAX=0 * Loop over the wires. DO 120 I=1,NWIRE IF(SETX)THEN XMIN=MIN(XMIN,X(I)-D(I)/2) XMAX=MAX(XMAX,X(I)+D(I)/2) ELSE XMIN=X(I)-D(I)/2 XMAX=X(I)+D(I)/2 SETX=.TRUE. ENDIF IF(SETY)THEN YMIN=MIN(YMIN,Y(I)-D(I)/2) YMAX=MAX(YMAX,Y(I)+D(I)/2) ELSE YMIN=Y(I)-D(I)/2 YMAX=Y(I)+D(I)/2 SETY=.TRUE. ENDIF IF(SETZ)THEN ZMIN=MIN(ZMIN,-U(I)/2) ZMAX=MAX(ZMAX,+U(I)/2) ELSE ZMIN=-U(I)/2 ZMAX=+U(I)/2 SETZ=.TRUE. ENDIF IF(SETV)THEN VMIN=MIN(VMIN,V(I)) VMAX=MAX(VMAX,V(I)) ELSE VMIN=V(I) VMAX=V(I) SETV=.TRUE. ENDIF 120 CONTINUE * Consider the planes. DO 130 I=1,4 IF(YNPLAN(I))THEN IF(I.LE.2)THEN IF(SETX)THEN XMIN=MIN(XMIN,COPLAN(I)) XMAX=MAX(XMAX,COPLAN(I)) ELSE XMIN=COPLAN(I) XMAX=COPLAN(I) SETX=.TRUE. ENDIF ELSE IF(SETY)THEN YMIN=MIN(YMIN,COPLAN(I)) YMAX=MAX(YMAX,COPLAN(I)) ELSE YMIN=COPLAN(I) YMAX=COPLAN(I) SETY=.TRUE. ENDIF ENDIF IF(SETV)THEN VMIN=MIN(VMIN,VTPLAN(I)) VMAX=MAX(VMAX,VTPLAN(I)) ELSE VMIN=VTPLAN(I) VMAX=VTPLAN(I) SETV=.TRUE. ENDIF ENDIF 130 CONTINUE * Consider the dielectrica. DO 260 I=1,NXMATT IF(XMATT(I,3).EQ.0)THEN IF(SETX)THEN XMIN=MIN(XMIN,XMATT(I,1)) XMAX=MAX(XMAX,XMATT(I,1)) ELSE XMIN=XMATT(I,1) XMAX=XMATT(I,1) SETX=.TRUE. ENDIF ENDIF IF(XMATT(I,4).EQ.0)THEN IF(SETX)THEN XMIN=MIN(XMIN,XMATT(I,2)) XMAX=MAX(XMAX,XMATT(I,2)) ELSE XMIN=XMATT(I,2) XMAX=XMATT(I,2) SETX=.TRUE. ENDIF ENDIF 260 CONTINUE DO 270 I=1,NYMATT IF(YMATT(I,3).EQ.0)THEN IF(SETY)THEN YMIN=MIN(YMIN,YMATT(I,1)) YMAX=MAX(YMAX,YMATT(I,1)) ELSE YMIN=YMATT(I,1) YMAX=YMATT(I,1) SETY=.TRUE. ENDIF ENDIF IF(YMATT(I,4).EQ.0)THEN IF(SETY)THEN YMIN=MIN(YMIN,YMATT(I,2)) YMAX=MAX(YMAX,YMATT(I,2)) ELSE YMIN=YMATT(I,2) YMAX=YMATT(I,2) SETY=.TRUE. ENDIF ENDIF 270 CONTINUE * Consider the tube. IF(TUBE)THEN XMIN=-1.1*COTUBE XMAX=+1.1*COTUBE SETX=.TRUE. YMIN=-1.1*COTUBE YMAX=+1.1*COTUBE SETY=.TRUE. VMIN=MIN(VMIN,VTTUBE) VMAX=MAX(VMAX,VTTUBE) SETV=.TRUE. ENDIF ** In case of x-periodicity, XMAX-XMIN should be SX, IF(PERX.AND.SX.GT.(XMAX-XMIN))THEN XMIN=-SX/2.0 XMAX=SX/2.0 SETX=.TRUE. ENDIF * in case of y-periodicity, YMAX-YMIN should be SY, IF(PERY.AND.SY.GT.(YMAX-YMIN))THEN YMIN=-SY/2.0 YMAX=SY/2.0 SETY=.TRUE. ENDIF * in case the cell is polar, the y range should be < 2 pi. IF(POLAR.AND.YMAX-YMIN.GE.2.0*PI)THEN YMIN=-PI YMAX=+PI SETY=.TRUE. ENDIF ** Fill in missing dimensions. IF(SETX.AND.XMIN.NE.XMAX.AND.(YMIN.EQ.YMAX.OR..NOT.SETY))THEN YMIN=YMIN-ABS(XMAX-XMIN)/2 YMAX=YMAX+ABS(XMAX-XMIN)/2 SETY=.TRUE. ENDIF IF(SETY.AND.YMIN.NE.YMAX.AND.(XMIN.EQ.XMAX.OR..NOT.SETX))THEN XMIN=XMIN-ABS(YMAX-YMIN)/2 XMAX=XMAX+ABS(YMAX-YMIN)/2 SETX=.TRUE. ENDIF IF(.NOT.SETZ)THEN ZMIN=-(ABS(XMAX-XMIN)+ABS(YMAX-YMIN))/4 ZMAX=+(ABS(XMAX-XMIN)+ABS(YMAX-YMIN))/4 SETZ=.TRUE. ENDIF * Ensure that all dimensions are now set. IF(.NOT.(SETX.AND.SETY.AND.SETZ))THEN PRINT *,' !!!!!! CELCHK WARNING : Unable to establish'// - ' default dimensions in all directions; use AREA.' OK=.FALSE. ENDIF *** Check that at least some different voltages are present. IF(VMIN.EQ.VMAX.OR..NOT.SETV)THEN PRINT *,' ###### CELCHK ERROR : All potentials in the'// - ' cell are the same; there is no point in going on.' OK=.FALSE. RETURN ENDIF *** Resume here for maps. 3000 CONTINUE *** Take action on the warnings if requested. IF(JFAIL.EQ.2.AND..NOT.OK)THEN PRINT *,' ###### CELCHK ERROR : Cell declared to be'// - ' unuseable because of the above warnings.' RETURN ELSEIF(JFAIL.EQ.3.AND..NOT.OK)THEN PRINT *,' ###### CELCHK ERROR : Program terminated'// - ' because of the above warnings.' CALL QUIT RETURN ENDIF *** Cell seems to be alright since it passed all critical tests. IFAIL=0 *** Print the amount of CPU time used. CALL TIMLOG('Checking that the cell makes sense: ') END +DECK,CELCNW. SUBROUTINE CELCNW(PPXMIN,PPYMIN,PPXMAX,PPYMAX) *----------------------------------------------------------------------- * CELCNW - Generates a conductor table from the wires. * VARIABLES : NXMIN,NXMAX: Numbers of resp first and last x-period. * NYMIN,NYMAX: " " " " " " y " * (Last changed on 12/ 8/99.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,SOLIDS. +SEQ,CONSTANTS. +SEQ,PRINTPLOT. +SEQ,PARAMETERS. INTEGER I,NX,NY,NXMIN,NYMIN,NXMAX,NYMAX REAL XPOS,YPOS,PPXMIN,PPYMIN,PPXMAX,PPYMAX *** Determine the number of periods present in the cell. NXMIN=0 NXMAX=0 NYMIN=0 NYMAX=0 IF(PERX)THEN NXMIN=INT(PPXMIN/SX)-1 NXMAX=INT(PPXMAX/SX)+1 ENDIF IF(PERY)THEN NYMIN=INT(PPYMIN/SY)-1 NYMAX=INT(PPYMAX/SY)+1 ENDIF *** Initialise the conductor table. NSOLID=0 ICCURR=0 *** Loop over the wires. DO 80 I=1,NWIRE * Loop over the periods. DO 90 NX=NXMIN,NXMAX DO 70 NY=NYMIN,NYMAX * Wire location in non-tube shaped cells. IF(.NOT.TUBE)THEN XPOS=X(I)+NX*SX YPOS=Y(I)+NY*SY * Tubed shaped cells. ELSE CALL CFMCTP(X(I),Y(I),XPOS,YPOS,1) IF(PERY)YPOS=YPOS+REAL(NY*360)/REAL(MTUBE) CALL CFMPTC(XPOS,YPOS,XPOS,YPOS,1) ENDIF ** Enter in the conductor table. IF(NSOLID.GE.MXSOLI)THEN PRINT *,' !!!!!! CELCNW WARNING : Solids list is full'// - ' ; not copying some wires.' RETURN ELSEIF(ICCURR+13.GT.MXSBUF)THEN PRINT *,' !!!!!! CELCNW WARNING : Solids description'// - ' buffer is full ; not copying some wires.' RETURN ENDIF NSOLID=NSOLID+1 * Start of the record. ISTART(NSOLID)=ICCURR * Type of solid. ISOLTP(NSOLID)=1 * Material the solid is made of. ISOLMT(NSOLID)=1 * Label assigned to the solid. SOLTYP(NSOLID)=WIRTYP(I) * Diameter. CBUF(ICCURR+1)=D(I)/2 * Half length. CBUF(ICCURR+2)=U(I)/2 * Position of centre. CBUF(ICCURR+3)=XPOS CBUF(ICCURR+4)=YPOS CBUF(ICCURR+5)=0.0 * Direction vector. CBUF(ICCURR+6)=0.0 CBUF(ICCURR+7)=0.0 CBUF(ICCURR+8)=1.0 * Number of points. CBUF(ICCURR+9)=0 * Orientation cos and sin of angles. CBUF(ICCURR+10)=1.0 CBUF(ICCURR+11)=0.0 CBUF(ICCURR+12)=1.0 CBUF(ICCURR+13)=0.0 * No axial rotation. CBUF(ICCURR+14)=0 * Amount of data. ICCURR=ICCURR+14 * Next periods. 70 CONTINUE 90 CONTINUE * Next wire. 80 CONTINUE END +DECK,CELSOL. SUBROUTINE CELSOL *----------------------------------------------------------------------- * CELSOL - Reads a list of solids. * VARIABLES : NXMIN,NXMAX: Numbers of resp first and last x-period. * NYMIN,NYMAX: " " " " " " y " * (Last changed on 12/ 8/99.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,SOLIDS. +SEQ,CONSTANTS. +SEQ,PRINTPLOT. +SEQ,PARAMETERS. CHARACTER*80 STRING CHARACTER AUXTYP INTEGER I,INEXT,NWORD,IFAIL1,IFAIL2,IFAIL3,INPCMP,NC,IMAT,N,NR, - NCAUX REAL XDIR,YDIR,ZDIR,XPOS,YPOS,ZPOS,XSIZ,YSIZ,ZSIZ,R,R1,R2, - AUX1,AUX2,AUX3,THETA,PHI,AROT LOGICAL LRAD,LRAD1,LRAD2,LPOS,LSIZ,STDSTR EXTERNAL INPCMP,STDSTR *** Read the number of words. CALL INPNUM(NWORD) *** Warn if there are options. IF(NWORD.NE.1)PRINT *,' !!!!!! CELSOL WARNING : No arguments'// - ' for SOLIDS known; ignored.' *** Initialise the conductor table. NSOLID=0 ICCURR=0 *** Set the prompt. CALL INPPRM('Solids','ADD-NOPRINT') IF(STDSTR('INPUT'))PRINT *,' ====== CELSOL INPUT : Please'// - ' enter the solids, terminate with a blank line.' *** Read a line. 10 CONTINUE CALL INPWRD(NWORD) *** If empty, leave the routine. IF(NWORD.EQ.0)THEN CALL INPPRM(' ','BACK-PRINT') RETURN ENDIF *** Could be a cylinder. IF(INPCMP(1,'CYL#INDER').NE.0)THEN * Default parameters. XDIR=0 YDIR=0 ZDIR=1 AROT=0 IMAT=1 AUXTYP='C' N=0 * Required parameters. LRAD=.FALSE. LPOS=.FALSE. LSIZ=.FALSE. * Read the parameters. INEXT=2 DO 20 I=2,NWORD IF(I.LT.INEXT)GOTO 20 * Centre. IF(INPCMP(I,'CEN#TRE')+INPCMP(I,'CEN#TER').NE.0)THEN CALL INPCHK(I+1,2,IFAIL1) CALL INPCHK(I+2,2,IFAIL2) CALL INPCHK(I+3,2,IFAIL3) IF(IFAIL1.EQ.0.AND.IFAIL2.EQ.0.AND.IFAIL3.EQ.0)THEN CALL INPRDR(I+1,XPOS,0.0) CALL INPRDR(I+2,YPOS,0.0) CALL INPRDR(I+3,ZPOS,0.0) LPOS=.TRUE. ELSE CALL INPMSG(I,'Arguments not valid.') ENDIF INEXT=I+4 * Direction. ELSEIF(INPCMP(I,'DIR#ECTION').NE.0)THEN CALL INPCHK(I+1,2,IFAIL1) CALL INPCHK(I+2,2,IFAIL2) CALL INPCHK(I+3,2,IFAIL3) IF(IFAIL1.EQ.0.AND.IFAIL2.EQ.0.AND.IFAIL3.EQ.0)THEN CALL INPRDR(I+1,XDIR,0.0) CALL INPRDR(I+2,YDIR,0.0) CALL INPRDR(I+3,ZDIR,0.0) ELSE CALL INPMSG(I,'Arguments not valid.') ENDIF INEXT=I+4 * Radius. ELSEIF(INPCMP(I,'R#ADIUS').NE.0)THEN CALL INPCHK(I+1,2,IFAIL1) IF(IFAIL1.EQ.0)THEN CALL INPRDR(I+1,AUX1,-1.0) IF(AUX1.GT.0)THEN R=AUX1 LRAD=.TRUE. ELSE CALL INPMSG(I+1,'Radius not positive.') ENDIF ELSE CALL INPMSG(I,'Arguments not valid.') ENDIF INEXT=I+2 * Half-length. ELSEIF(INPCMP(I,'HALF-#LENGTH').NE.0)THEN CALL INPCHK(I+1,2,IFAIL1) IF(IFAIL1.EQ.0)THEN CALL INPRDR(I+1,AUX1,-1.0) IF(AUX1.GT.0)THEN ZSIZ=AUX1 LSIZ=.TRUE. ELSE CALL INPMSG(I+1,'Radius not positive.') ENDIF ELSE CALL INPMSG(I,'Arguments not valid.') ENDIF INEXT=I+2 * Rotation. ELSEIF(INPCMP(I,'ROT#ATE').NE.0)THEN CALL INPCHK(I+1,2,IFAIL1) IF(IFAIL1.EQ.0)THEN CALL INPRDR(I+1,AUX1,-1.0) AROT=AUX1*PI/180 ELSE CALL INPMSG(I,'Arguments not valid.') ENDIF INEXT=I+2 * Number of points. ELSEIF(INPCMP(I,'N').NE.0)THEN CALL INPCHK(I+1,1,IFAIL1) IF(IFAIL1.EQ.0)THEN CALL INPRDI(I+1,NR,-1) IF(NR.LE.1)THEN CALL INPMSG(I+1,'Should be > 1.') ELSE N=NR ENDIF ELSE CALL INPMSG(I,'Arguments not valid.') ENDIF INEXT=I+2 * Material. ELSEIF(INPCMP(I,'CON#DUCTOR')+ - INPCMP(I,'CON#DUCTOR-1').NE.0)THEN IMAT=1 ELSEIF(INPCMP(I,'CON#DUCTOR-2').NE.0)THEN IMAT=2 ELSEIF(INPCMP(I,'CON#DUCTOR-3').NE.0)THEN IMAT=3 ELSEIF(INPCMP(I,'DIEL#ECTRICUM')+ - INPCMP(I,'DIEL#ECTRICUM-1').NE.0)THEN IMAT=11 ELSEIF(INPCMP(I,'DIEL#ECTRICUM-2').NE.0)THEN IMAT=12 ELSEIF(INPCMP(I,'DIEL#ECTRICUM-3').NE.0)THEN IMAT=13 * Label. ELSEIF(INPCMP(I,'LAB#EL')+INPCMP(I,'TYPE').NE.0)THEN CALL INPSTR(I+1,I+1,AUXTYP,NCAUX) IF(INDEX('ABCDEFGHIJKLMNOPQRSTUVWXYZ',AUXTYP).EQ. - 0)THEN CALL INPMSG(1,'The label must be a letter.') AUXTYP='C' ENDIF INEXT=I+2 * Other things are not known. ELSE CALL INPMSG(I,'Not a known keyword.') ENDIF 20 CONTINUE * Print error messages. CALL INPERR * Enter in the conductor table. IF(LPOS.AND.LRAD.AND.LSIZ.AND. - (NSOLID+1.GT.MXSOLI.OR.ICCURR+13.GT.MXSBUF))THEN PRINT *,' !!!!!! CELSOL WARNING : Conductor table'// - ' is full; cylinder not stored.' ELSEIF(LPOS.AND.LRAD.AND.LSIZ)THEN NSOLID=NSOLID+1 ISTART(NSOLID)=ICCURR ISOLTP(NSOLID)=1 ISOLMT(NSOLID)=IMAT SOLTYP(NSOLID)=AUXTYP CBUF(ICCURR+1)=R CBUF(ICCURR+2)=ZSIZ CBUF(ICCURR+3)=XPOS CBUF(ICCURR+4)=YPOS CBUF(ICCURR+5)=ZPOS CBUF(ICCURR+6)=XDIR CBUF(ICCURR+7)=YDIR CBUF(ICCURR+8)=ZDIR CBUF(ICCURR+9)=DBLE(N) * Compute rotation angles. IF(XDIR**2+YDIR**2.LE.0)THEN PHI=0 IF(ZDIR.GT.0)THEN THETA=0 ELSE THETA=PI ENDIF ELSE PHI=ATAN2(YDIR,XDIR) THETA=ATAN2(SQRT(XDIR**2+YDIR**2),ZDIR) ENDIF CBUF(ICCURR+10)=COS(THETA) CBUF(ICCURR+11)=SIN(THETA) CBUF(ICCURR+12)=COS(PHI) CBUF(ICCURR+13)=SIN(PHI) * Rotation angle of the object. CBUF(ICCURR+14)=AROT * Store size. ICCURR=ICCURR+14 * Or warn that some element is missing. ELSE PRINT *,' !!!!!! CELSOL WARNING : Cylinder not'// - ' entered because the position, the radius'// - ' or the length has not been given.' ENDIF *** Cylindrical hole. ELSEIF(INPCMP(1,'HOLE').NE.0)THEN * Default parameters. XDIR=0 YDIR=0 ZDIR=1 IMAT=1 N=0 AUXTYP='H' * Required parameters. LRAD1=.FALSE. LRAD2=.FALSE. LPOS=.FALSE. LSIZ=.FALSE. * Read the parameters. INEXT=2 DO 60 I=2,NWORD IF(I.LT.INEXT)GOTO 60 * Centre. IF(INPCMP(I,'CEN#TRE')+INPCMP(I,'CEN#TER').NE.0)THEN CALL INPCHK(I+1,2,IFAIL1) CALL INPCHK(I+2,2,IFAIL2) CALL INPCHK(I+3,2,IFAIL3) IF(IFAIL1.EQ.0.AND.IFAIL2.EQ.0.AND.IFAIL3.EQ.0)THEN CALL INPRDR(I+1,XPOS,0.0) CALL INPRDR(I+2,YPOS,0.0) CALL INPRDR(I+3,ZPOS,0.0) LPOS=.TRUE. ELSE CALL INPMSG(I,'Arguments not valid.') ENDIF INEXT=I+4 * Direction. ELSEIF(INPCMP(I,'DIR#ECTION').NE.0)THEN CALL INPCHK(I+1,2,IFAIL1) CALL INPCHK(I+2,2,IFAIL2) CALL INPCHK(I+3,2,IFAIL3) IF(IFAIL1.EQ.0.AND.IFAIL2.EQ.0.AND.IFAIL3.EQ.0)THEN CALL INPRDR(I+1,XDIR,0.0) CALL INPRDR(I+2,YDIR,0.0) CALL INPRDR(I+3,ZDIR,0.0) ELSE CALL INPMSG(I,'Arguments not valid.') ENDIF INEXT=I+4 * Number of points. ELSEIF(INPCMP(I,'N').NE.0)THEN CALL INPCHK(I+1,1,IFAIL1) IF(IFAIL1.EQ.0)THEN CALL INPRDI(I+1,NR,-1) IF(NR.LE.1)THEN CALL INPMSG(I+1,'Should be > 1.') ELSE N=NR ENDIF ELSE CALL INPMSG(I,'Arguments not valid.') ENDIF INEXT=I+2 * Radius or radii. ELSEIF(INPCMP(I,'R#ADIUS')+ - INPCMP(I,'R#ADII').NE.0)THEN CALL INPCHK(I+1,2,IFAIL1) IF(IFAIL1.EQ.0)THEN CALL INPRDR(I+1,AUX1,-1.0) IF(AUX1.GT.0)THEN R1=AUX1 R2=AUX1 LRAD1=.TRUE. LRAD2=.TRUE. ELSE CALL INPMSG(I+1,'Radius not positive.') ENDIF ELSE CALL INPMSG(I,'Arguments not valid.') ENDIF INEXT=I+2 ELSEIF(INPCMP(I,'UP#PER-R#ADIUS').NE.0)THEN CALL INPCHK(I+1,2,IFAIL1) IF(IFAIL1.EQ.0)THEN CALL INPRDR(I+1,AUX1,-1.0) IF(AUX1.GT.0)THEN R2=AUX1 LRAD2=.TRUE. ELSE CALL INPMSG(I+1,'Radius not positive.') ENDIF ELSE CALL INPMSG(I,'Arguments not valid.') ENDIF INEXT=I+2 ELSEIF(INPCMP(I,'LOW#ER-R#ADIUS').NE.0)THEN CALL INPCHK(I+1,2,IFAIL1) IF(IFAIL1.EQ.0)THEN CALL INPRDR(I+1,AUX1,-1.0) IF(AUX1.GT.0)THEN R1=AUX1 LRAD1=.TRUE. ELSE CALL INPMSG(I+1,'Radius not positive.') ENDIF ELSE CALL INPMSG(I,'Arguments not valid.') ENDIF INEXT=I+2 * Half-lengths. ELSEIF(INPCMP(I,'HALF-#LENGTHS')+ - INPCMP(I,'HALF-#SIZES').NE.0)THEN CALL INPCHK(I+1,2,IFAIL1) CALL INPCHK(I+2,2,IFAIL2) CALL INPCHK(I+3,2,IFAIL3) IF(IFAIL1.EQ.0.AND.IFAIL2.EQ.0.AND.IFAIL3.EQ.0)THEN CALL INPRDR(I+1,AUX1,0.0) CALL INPRDR(I+2,AUX2,0.0) CALL INPRDR(I+3,AUX3,0.0) IF(AUX1.GT.0.AND.AUX2.GT.0.AND.AUX3.GT.0)THEN XSIZ=AUX1 YSIZ=AUX2 ZSIZ=AUX3 LSIZ=.TRUE. ELSE IF(AUX1.LE.0)CALL INPMSG(I+1,'Is not > 0.') IF(AUX2.LE.0)CALL INPMSG(I+2,'Is not > 0.') IF(AUX3.LE.0)CALL INPMSG(I+3,'Is not > 0.') ENDIF ELSE CALL INPMSG(I,'Arguments not valid.') ENDIF INEXT=I+4 * Material. ELSEIF(INPCMP(I,'CON#DUCTOR')+ - INPCMP(I,'CON#DUCTOR-1').NE.0)THEN IMAT=1 ELSEIF(INPCMP(I,'CON#DUCTOR-2').NE.0)THEN IMAT=2 ELSEIF(INPCMP(I,'CON#DUCTOR-3').NE.0)THEN IMAT=3 ELSEIF(INPCMP(I,'DIEL#ECTRICUM')+ - INPCMP(I,'DIEL#ECTRICUM-1').NE.0)THEN IMAT=11 ELSEIF(INPCMP(I,'DIEL#ECTRICUM-2').NE.0)THEN IMAT=12 ELSEIF(INPCMP(I,'DIEL#ECTRICUM-3').NE.0)THEN IMAT=13 * Label. ELSEIF(INPCMP(I,'LAB#EL')+INPCMP(I,'TYPE').NE.0)THEN CALL INPSTR(I+1,I+1,AUXTYP,NCAUX) IF(INDEX('ABCDEFGHIJKLMNOPQRSTUVWXYZ',AUXTYP).EQ. - 0)THEN CALL INPMSG(1,'The label must be a letter.') AUXTYP='H' ENDIF INEXT=I+2 * Other things are not known. ELSE CALL INPMSG(I,'Not a known keyword.') ENDIF 60 CONTINUE * Print error messages. CALL INPERR * Enter in the conductor table. IF(LPOS.AND.LRAD1.AND.LRAD2.AND.LSIZ.AND. - (NSOLID+1.GT.MXSOLI.OR.ICCURR+16.GT.MXSBUF))THEN PRINT *,' !!!!!! CELSOL WARNING : Conductor table'// - ' is full; hole not stored.' ELSEIF(LPOS.AND.LRAD1.AND.LRAD2.AND.LSIZ)THEN NSOLID=NSOLID+1 ISTART(NSOLID)=ICCURR ISOLTP(NSOLID)=2 ISOLMT(NSOLID)=IMAT SOLTYP(NSOLID)=AUXTYP CBUF(ICCURR+1)=R1 CBUF(ICCURR+2)=R2 CBUF(ICCURR+3)=XSIZ CBUF(ICCURR+4)=YSIZ CBUF(ICCURR+5)=ZSIZ CBUF(ICCURR+6)=XPOS CBUF(ICCURR+7)=YPOS CBUF(ICCURR+8)=ZPOS CBUF(ICCURR+9)=XDIR CBUF(ICCURR+10)=YDIR CBUF(ICCURR+11)=ZDIR CBUF(ICCURR+12)=DBLE(N) * Compute rotation angles. IF(XDIR**2+YDIR**2.LE.0)THEN PHI=0 IF(ZDIR.GT.0)THEN THETA=0 ELSE THETA=PI ENDIF ELSE PHI=ATAN2(YDIR,XDIR) THETA=ATAN2(SQRT(XDIR**2+YDIR**2),ZDIR) ENDIF CBUF(ICCURR+13)=COS(THETA) CBUF(ICCURR+14)=SIN(THETA) CBUF(ICCURR+15)=COS(PHI) CBUF(ICCURR+16)=SIN(PHI) ICCURR=ICCURR+16 * Or warn that some element is missing. ELSE PRINT *,' !!!!!! CELSOL WARNING : Hole not'// - ' entered because the position, the radii'// - ' or the box size has not been given.' ENDIF *** Could be a box. ELSEIF(INPCMP(1,'BOX').NE.0)THEN * Default parameters. XDIR=0 YDIR=0 ZDIR=1 IMAT=1 AUXTYP='B' * Required parameters. LSIZ=.FALSE. LPOS=.FALSE. * Read the parameters. INEXT=2 DO 40 I=2,NWORD IF(I.LT.INEXT)GOTO 40 * Centre. IF(INPCMP(I,'CEN#TRE')+INPCMP(I,'CEN#TER').NE.0)THEN CALL INPCHK(I+1,2,IFAIL1) CALL INPCHK(I+2,2,IFAIL2) CALL INPCHK(I+3,2,IFAIL3) IF(IFAIL1.EQ.0.AND.IFAIL2.EQ.0.AND.IFAIL3.EQ.0)THEN CALL INPRDR(I+1,XPOS,0.0) CALL INPRDR(I+2,YPOS,0.0) CALL INPRDR(I+3,ZPOS,0.0) LPOS=.TRUE. ELSE CALL INPMSG(I,'Arguments not valid.') ENDIF INEXT=I+4 * Direction. ELSEIF(INPCMP(I,'DIR#ECTION').NE.0)THEN CALL INPCHK(I+1,2,IFAIL1) CALL INPCHK(I+2,2,IFAIL2) CALL INPCHK(I+3,2,IFAIL3) IF(IFAIL1.EQ.0.AND.IFAIL2.EQ.0.AND.IFAIL3.EQ.0)THEN CALL INPRDR(I+1,XDIR,0.0) CALL INPRDR(I+2,YDIR,0.0) CALL INPRDR(I+3,ZDIR,0.0) ELSE CALL INPMSG(I,'Arguments not valid.') ENDIF INEXT=I+4 * Half-lengths. ELSEIF(INPCMP(I,'HALF-#LENGTHS')+ - INPCMP(I,'HALF-#SIZES').NE.0)THEN CALL INPCHK(I+1,2,IFAIL1) CALL INPCHK(I+2,2,IFAIL2) CALL INPCHK(I+3,2,IFAIL3) IF(IFAIL1.EQ.0.AND.IFAIL2.EQ.0.AND.IFAIL3.EQ.0)THEN CALL INPRDR(I+1,AUX1,0.0) CALL INPRDR(I+2,AUX2,0.0) CALL INPRDR(I+3,AUX3,0.0) IF(AUX1.GT.0.AND.AUX2.GT.0.AND.AUX3.GT.0)THEN XSIZ=AUX1 YSIZ=AUX2 ZSIZ=AUX3 LSIZ=.TRUE. ELSE IF(AUX1.LE.0)CALL INPMSG(I+1,'Is not > 0.') IF(AUX2.LE.0)CALL INPMSG(I+2,'Is not > 0.') IF(AUX3.LE.0)CALL INPMSG(I+3,'Is not > 0.') ENDIF ELSE CALL INPMSG(I,'Arguments not valid.') ENDIF INEXT=I+4 * Material. ELSEIF(INPCMP(I,'CON#DUCTOR')+ - INPCMP(I,'CON#DUCTOR-1').NE.0)THEN IMAT=1 ELSEIF(INPCMP(I,'CON#DUCTOR-2').NE.0)THEN IMAT=2 ELSEIF(INPCMP(I,'CON#DUCTOR-3').NE.0)THEN IMAT=3 ELSEIF(INPCMP(I,'DIEL#ECTRICUM')+ - INPCMP(I,'DIEL#ECTRICUM-1').NE.0)THEN IMAT=11 ELSEIF(INPCMP(I,'DIEL#ECTRICUM-2').NE.0)THEN IMAT=12 ELSEIF(INPCMP(I,'DIEL#ECTRICUM-3').NE.0)THEN IMAT=13 * Label. ELSEIF(INPCMP(I,'LAB#EL')+INPCMP(I,'TYPE').NE.0)THEN CALL INPSTR(I+1,I+1,AUXTYP,NCAUX) IF(INDEX('ABCDEFGHIJKLMNOPQRSTUVWXYZ',AUXTYP).EQ. - 0)THEN CALL INPMSG(1,'The label must be a letter.') AUXTYP='B' ENDIF INEXT=I+2 * Other things are not known. ELSE CALL INPMSG(I,'Not a known keyword.') ENDIF 40 CONTINUE * Print error messages. CALL INPERR * Enter in the conductor table. IF(LPOS.AND.LSIZ.AND. - (NSOLID+1.GT.MXSOLI.OR.ICCURR+13.GT.MXSBUF))THEN PRINT *,' !!!!!! CELSOL WARNING : Conductor table'// - ' is full; box not stored.' ELSEIF(LPOS.AND.LSIZ)THEN NSOLID=NSOLID+1 ISTART(NSOLID)=ICCURR ISOLTP(NSOLID)=3 ISOLMT(NSOLID)=IMAT SOLTYP(NSOLID)=AUXTYP CBUF(ICCURR+1)=XSIZ CBUF(ICCURR+2)=YSIZ CBUF(ICCURR+3)=ZSIZ CBUF(ICCURR+4)=XPOS CBUF(ICCURR+5)=YPOS CBUF(ICCURR+6)=ZPOS CBUF(ICCURR+7)=XDIR CBUF(ICCURR+8)=YDIR CBUF(ICCURR+9)=ZDIR * Compute rotation angles. IF(XDIR**2+YDIR**2.LE.0)THEN PHI=0 IF(ZDIR.GT.0)THEN THETA=0 ELSE THETA=PI ENDIF ELSE PHI=ATAN2(YDIR,XDIR) THETA=ATAN2(SQRT(XDIR**2+YDIR**2),ZDIR) ENDIF CBUF(ICCURR+10)=COS(THETA) CBUF(ICCURR+11)=SIN(THETA) CBUF(ICCURR+12)=COS(PHI) CBUF(ICCURR+13)=SIN(PHI) ICCURR=ICCURR+13 * Or warn that some element is missing. ELSE PRINT *,' !!!!!! CELSOL WARNING : Box not'// - ' entered because the position or the size'// - ' has not been given.' ENDIF *** Could also be sphere. ELSEIF(INPCMP(1,'SPHERE').NE.0)THEN * Required parameters. LRAD=.FALSE. LPOS=.FALSE. N=0 IMAT=1 AUXTYP='S' * Read the parameters. INEXT=2 DO 50 I=2,NWORD IF(I.LT.INEXT)GOTO 50 * Centre. IF(INPCMP(I,'CEN#TRE')+INPCMP(I,'CEN#TER').NE.0)THEN CALL INPCHK(I+1,2,IFAIL1) CALL INPCHK(I+2,2,IFAIL2) CALL INPCHK(I+3,2,IFAIL3) IF(IFAIL1.EQ.0.AND.IFAIL2.EQ.0.AND.IFAIL3.EQ.0)THEN CALL INPRDR(I+1,XPOS,0.0) CALL INPRDR(I+2,YPOS,0.0) CALL INPRDR(I+3,ZPOS,0.0) LPOS=.TRUE. ELSE CALL INPMSG(I,'Arguments not valid.') ENDIF INEXT=I+4 * Radius. ELSEIF(INPCMP(I,'R#ADIUS').NE.0)THEN CALL INPCHK(I+1,2,IFAIL1) IF(IFAIL1.EQ.0)THEN CALL INPRDR(I+1,AUX1,-1.0) IF(AUX1.GT.0)THEN R=AUX1 LRAD=.TRUE. ELSE CALL INPMSG(I+1,'Radius not positive.') ENDIF ELSE CALL INPMSG(I,'Arguments not valid.') ENDIF INEXT=I+2 * Material. ELSEIF(INPCMP(I,'CON#DUCTOR')+ - INPCMP(I,'CON#DUCTOR-1').NE.0)THEN IMAT=1 ELSEIF(INPCMP(I,'CON#DUCTOR-2').NE.0)THEN IMAT=2 ELSEIF(INPCMP(I,'CON#DUCTOR-3').NE.0)THEN IMAT=3 ELSEIF(INPCMP(I,'DIEL#ECTRICUM')+ - INPCMP(I,'DIEL#ECTRICUM-1').NE.0)THEN IMAT=11 ELSEIF(INPCMP(I,'DIEL#ECTRICUM-2').NE.0)THEN IMAT=12 ELSEIF(INPCMP(I,'DIEL#ECTRICUM-3').NE.0)THEN IMAT=13 * Number of points. ELSEIF(INPCMP(I,'N').NE.0)THEN CALL INPCHK(I+1,1,IFAIL1) IF(IFAIL1.EQ.0)THEN CALL INPRDI(I+1,NR,-1) IF(NR.LE.1)THEN CALL INPMSG(I+1,'Should be > 1.') ELSE N=NR ENDIF ELSE CALL INPMSG(I,'Arguments not valid.') ENDIF INEXT=I+2 * Label. ELSEIF(INPCMP(I,'LAB#EL')+INPCMP(I,'TYPE').NE.0)THEN CALL INPSTR(I+1,I+1,AUXTYP,NCAUX) IF(INDEX('ABCDEFGHIJKLMNOPQRSTUVWXYZ',AUXTYP).EQ. - 0)THEN CALL INPMSG(1,'The label must be a letter.') AUXTYP='S' ENDIF INEXT=I+2 * Other things are not known. ELSE CALL INPMSG(I,'Not a known keyword.') ENDIF 50 CONTINUE * Print error messages. CALL INPERR * Enter in the conductor table. IF(LPOS.AND.LRAD.AND. - (NSOLID+1.GT.MXSOLI.OR.ICCURR+5.GT.MXSBUF))THEN PRINT *,' !!!!!! CELSOL WARNING : Conductor table'// - ' is full; sphere not stored.' ELSEIF(LPOS.AND.LRAD)THEN NSOLID=NSOLID+1 ISTART(NSOLID)=ICCURR ISOLTP(NSOLID)=4 ISOLMT(NSOLID)=IMAT SOLTYP(NSOLID)=AUXTYP CBUF(ICCURR+1)=R CBUF(ICCURR+2)=XPOS CBUF(ICCURR+3)=YPOS CBUF(ICCURR+4)=ZPOS CBUF(ICCURR+5)=DBLE(N) ICCURR=ICCURR+5 * Or warn that some element is missing. ELSE PRINT *,' !!!!!! CELSOL WARNING : Sphere not'// - ' entered because the position or the radius'// - ' has not been given.' ENDIF *** Other things are not known. ELSE CALL INPSTR(1,1,STRING,NC) PRINT *,' !!!!!! CELSOL WARNING : Shape '//STRING(1:NC)// - ' is not known; ignored.' ENDIF *** Read the next line. GOTO 10 END +DECK,CELSPR. SUBROUTINE CELSPR *----------------------------------------------------------------------- * CELSPR - Prints an overview of the solids. * (Last changed on 30/11/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,SOLIDS. +SEQ,CONSTANTS. +SEQ,PRINTPLOT. INTEGER I,NCYL,NHOLE,NBOX,NSPHER,NC1,NC2,NC3,NC4,NC5,NC6,NC7,NC8, - NC9,NC10,NC11,NC12,NCNUM CHARACTER*20 MAT,AUX1,AUX2,AUX3,AUX4,AUX5,AUX6,AUX7,AUX8,AUX9, - AUX10,AUX11,AUX12,AUXNUM *** See whether there are any solids. IF(NSOLID.LT.1)THEN WRITE(LUNOUT,'('' There are currently no solids.'')') RETURN ELSE WRITE(LUNOUT,'(/'' SOLIDS'')') ENDIF *** Count the various types of solids. NCYL=0 NHOLE=0 NBOX=0 NSPHER=0 DO 10 I=1,NSOLID IF(ISOLTP(I).EQ.1)THEN NCYL=NCYL+1 ELSEIF(ISOLTP(I).EQ.2)THEN NHOLE=NHOLE+1 ELSEIF(ISOLTP(I).EQ.3)THEN NBOX=NBOX+1 ELSEIF(ISOLTP(I).EQ.4)THEN NSPHER=NSPHER+1 ELSE PRINT *,' !!!!!! CELSPR WARNING : Found a solid of'// - ' unknown type ',ISOLTP(I),'; ignored.' ENDIF 10 CONTINUE *** Print the cylinders. IF(NCYL.GE.1)THEN WRITE(LUNOUT,'(/'' Cylinders:'')') DO 20 I=1,NSOLID IF(ISOLTP(I).NE.1)GOTO 20 IF(ISOLMT(I).EQ.1)THEN MAT='Conductor 1' ELSEIF(ISOLMT(I).EQ.2)THEN MAT='Conductor 2' ELSEIF(ISOLMT(I).EQ.3)THEN MAT='Conductor 3' ELSEIF(ISOLMT(I).EQ.11)THEN MAT='Dielectricum 1' ELSEIF(ISOLMT(I).EQ.12)THEN MAT='Dielectricum 2' ELSEIF(ISOLMT(I).EQ.13)THEN MAT='Dielectricum 3' ELSE MAT='# Unknown' ENDIF CALL OUTFMT(REAL(I),2,AUXNUM,NCNUM,'LEFT') CALL OUTFMT(REAL(CBUF(ISTART(I)+1)),2,AUX1,NC1,'LEFT') CALL OUTFMT(REAL(CBUF(ISTART(I)+2)),2,AUX2,NC2,'LEFT') CALL OUTFMT(REAL(CBUF(ISTART(I)+3)),2,AUX3,NC3,'LEFT') CALL OUTFMT(REAL(CBUF(ISTART(I)+4)),2,AUX4,NC4,'LEFT') CALL OUTFMT(REAL(CBUF(ISTART(I)+5)),2,AUX5,NC5,'LEFT') CALL OUTFMT(REAL(CBUF(ISTART(I)+6)),2,AUX6,NC6,'LEFT') CALL OUTFMT(REAL(CBUF(ISTART(I)+7)),2,AUX7,NC7,'LEFT') CALL OUTFMT(REAL(CBUF(ISTART(I)+8)),2,AUX8,NC8,'LEFT') CALL OUTFMT(REAL(NINT(CBUF(ISTART(I)+9))),2,AUX9,NC9,'LEFT') WRITE(LUNOUT,'(2X,A1,A4,'' - '', - ''Radius: '',A,'' cm''/ - 10X,''Half-length: '',A,'' cm''/ - 10X,''Centre: ('',A,'', '',A,'', '',A,'') cm''/ - 10X,''Axis: ('',A,'', '',A,'', '',A,'')''/ - 10X,''Material: '',A/ - 10X,''Corners: '',A)') - SOLTYP(I),AUXNUM(1:4), - AUX1(1:NC1),AUX2(1:NC2),AUX3(1:NC3), - AUX4(1:NC4),AUX5(1:NC5),AUX6(1:NC6),AUX7(1:NC7), - AUX8(1:NC8),MAT,AUX9(1:NC9) 20 CONTINUE ENDIF *** Print the holes. IF(NHOLE.GE.1)THEN WRITE(LUNOUT,'(/'' Holes:'')') DO 30 I=1,NSOLID IF(ISOLTP(I).NE.2)GOTO 30 IF(ISOLMT(I).EQ.1)THEN MAT='Conductor 1' ELSEIF(ISOLMT(I).EQ.2)THEN MAT='Conductor 2' ELSEIF(ISOLMT(I).EQ.3)THEN MAT='Conductor 3' ELSEIF(ISOLMT(I).EQ.11)THEN MAT='Dielectricum 1' ELSEIF(ISOLMT(I).EQ.12)THEN MAT='Dielectricum 2' ELSEIF(ISOLMT(I).EQ.13)THEN MAT='Dielectricum 3' ELSE MAT='# Unknown' ENDIF CALL OUTFMT(REAL(I),2,AUXNUM,NCNUM,'LEFT') CALL OUTFMT(REAL(CBUF(ISTART(I)+ 1)),2,AUX1, NC1, 'LEFT') CALL OUTFMT(REAL(CBUF(ISTART(I)+ 2)),2,AUX2, NC2, 'LEFT') CALL OUTFMT(REAL(CBUF(ISTART(I)+ 3)),2,AUX3, NC3, 'LEFT') CALL OUTFMT(REAL(CBUF(ISTART(I)+ 4)),2,AUX4, NC4, 'LEFT') CALL OUTFMT(REAL(CBUF(ISTART(I)+ 5)),2,AUX5, NC5, 'LEFT') CALL OUTFMT(REAL(CBUF(ISTART(I)+ 6)),2,AUX6, NC6, 'LEFT') CALL OUTFMT(REAL(CBUF(ISTART(I)+ 7)),2,AUX7, NC7, 'LEFT') CALL OUTFMT(REAL(CBUF(ISTART(I)+ 8)),2,AUX8, NC8, 'LEFT') CALL OUTFMT(REAL(CBUF(ISTART(I)+ 9)),2,AUX9, NC9, 'LEFT') CALL OUTFMT(REAL(CBUF(ISTART(I)+10)),2,AUX10,NC10,'LEFT') CALL OUTFMT(REAL(CBUF(ISTART(I)+11)),2,AUX11,NC11,'LEFT') CALL OUTFMT(REAL(NINT(CBUF(ISTART(I)+12))),2,AUX12,NC12, - 'LEFT') WRITE(LUNOUT,'(2X,A1,A4,'' - '', - ''Radii: '',A,'' and '',A,'' cm''/ - 10X,''Half-lengths: ('',A,'', '',A,'', '',A,'') cm''/ - 10X,''Centre: ('',A,'', '',A,'', '',A,'') cm''/ - 10X,''Axis: ('',A,'', '',A,'', '',A,'')''/ - 10X,''Material: '',A/ - 10X,''Corners: '',A)') - SOLTYP(I),AUXNUM(1:4), - AUX1(1:NC1),AUX2(1:NC2),AUX3(1:NC3), - AUX4(1:NC4),AUX5(1:NC5),AUX6(1:NC6),AUX7(1:NC7), - AUX8(1:NC8),AUX9(1:NC9),AUX10(1:NC10),AUX11(1:NC11), - MAT,AUX12(1:NC12) 30 CONTINUE ENDIF *** Print the boxes. IF(NBOX.GE.1)THEN WRITE(LUNOUT,'(/'' Boxes:'')') DO 40 I=1,NSOLID IF(ISOLTP(I).NE.3)GOTO 40 IF(ISOLMT(I).EQ.1)THEN MAT='Conductor 1' ELSEIF(ISOLMT(I).EQ.2)THEN MAT='Conductor 2' ELSEIF(ISOLMT(I).EQ.3)THEN MAT='Conductor 3' ELSEIF(ISOLMT(I).EQ.11)THEN MAT='Dielectricum 1' ELSEIF(ISOLMT(I).EQ.12)THEN MAT='Dielectricum 2' ELSEIF(ISOLMT(I).EQ.13)THEN MAT='Dielectricum 3' ELSE MAT='# Unknown' ENDIF CALL OUTFMT(REAL(I),2,AUXNUM,NCNUM,'LEFT') CALL OUTFMT(REAL(CBUF(ISTART(I)+1)),2,AUX1,NC1,'LEFT') CALL OUTFMT(REAL(CBUF(ISTART(I)+2)),2,AUX2,NC2,'LEFT') CALL OUTFMT(REAL(CBUF(ISTART(I)+3)),2,AUX3,NC3,'LEFT') CALL OUTFMT(REAL(CBUF(ISTART(I)+4)),2,AUX4,NC4,'LEFT') CALL OUTFMT(REAL(CBUF(ISTART(I)+5)),2,AUX5,NC5,'LEFT') CALL OUTFMT(REAL(CBUF(ISTART(I)+6)),2,AUX6,NC6,'LEFT') CALL OUTFMT(REAL(CBUF(ISTART(I)+7)),2,AUX7,NC7,'LEFT') CALL OUTFMT(REAL(CBUF(ISTART(I)+8)),2,AUX8,NC8,'LEFT') CALL OUTFMT(REAL(CBUF(ISTART(I)+9)),2,AUX9,NC9,'LEFT') WRITE(LUNOUT,'(2X,A1,A4,'' - '', - ''Half-lengths: ('',A,'', '',A,'', '',A,'') cm''/ - 10X,''Centre: ('',A,'', '',A,'', '',A,'') cm''/ - 10X,''Axis: ('',A,'', '',A,'', '',A,'')''/ - 10X,''Material: '',A)') - SOLTYP(I),AUXNUM(1:4), - AUX1(1:NC1),AUX2(1:NC2),AUX3(1:NC3), - AUX4(1:NC4),AUX5(1:NC5),AUX6(1:NC6),AUX7(1:NC7), - AUX8(1:NC8),AUX9(1:NC9),MAT 40 CONTINUE ENDIF *** Print the spheres. IF(NSPHER.GE.1)THEN WRITE(LUNOUT,'(/'' Spheres:'')') DO 50 I=1,NSOLID IF(ISOLTP(I).NE.4)GOTO 50 IF(ISOLMT(I).EQ.1)THEN MAT='Conductor 1' ELSEIF(ISOLMT(I).EQ.2)THEN MAT='Conductor 2' ELSEIF(ISOLMT(I).EQ.3)THEN MAT='Conductor 3' ELSEIF(ISOLMT(I).EQ.11)THEN MAT='Dielectricum 1' ELSEIF(ISOLMT(I).EQ.12)THEN MAT='Dielectricum 2' ELSEIF(ISOLMT(I).EQ.13)THEN MAT='Dielectricum 3' ELSE MAT='# Unknown' ENDIF CALL OUTFMT(REAL(I),2,AUXNUM,NCNUM,'LEFT') CALL OUTFMT(REAL(CBUF(ISTART(I)+1)),2,AUX1,NC1,'LEFT') CALL OUTFMT(REAL(CBUF(ISTART(I)+2)),2,AUX2,NC2,'LEFT') CALL OUTFMT(REAL(CBUF(ISTART(I)+3)),2,AUX3,NC3,'LEFT') CALL OUTFMT(REAL(CBUF(ISTART(I)+4)),2,AUX4,NC4,'LEFT') CALL OUTFMT(REAL(NINT(CBUF(ISTART(I)+5))),2,AUX5,NC5,'LEFT') WRITE(LUNOUT,'(2X,A1,A4,'' - '', - ''Radius: '',A,'' cm''/ - 10X,''Centre: ('',A,'', '',A,'', '',A,'') cm''/ - 10X,''Material: '',A/ - 10X,''Corners: '',A)') - SOLTYP(I),AUXNUM(1:4), - AUX1(1:NC1),AUX2(1:NC2),AUX3(1:NC3), - AUX4(1:NC4),MAT,AUX5(1:NC5) 50 CONTINUE ENDIF END +DECK,CELLA3. SUBROUTINE CELLA3 *----------------------------------------------------------------------- * CELLA3 - This routine draws all elements of the cell inside the * box (PPXMIN,PPYMIN,PPZMIN) to (PPXMAX,PPYMAX,PPZMAX), * taking care of periodicities etc, on the plot being made. * Version used for 3D impressions of space. * VARIABLES : NXMIN,NXMAX: Numbers of resp first and last x-period. * NYMIN,NYMAX: " " " " " " y " * XPL,YPL : Used for plotting of lines. * (Last changed on 1/12/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,SOLIDS. +SEQ,CONSTANTS. +SEQ,PRINTPLOT. +SEQ,PARAMETERS. DOUBLE PRECISION XPL(5),YPL(5),WW,XPMIN,YPMIN,XPMAX,YPMAX, - X1,Y1,X2,Y2,XX1,YY1,XX2,YY2,SMIN,SMAX INTEGER NX,NXMIN,NXMAX,NY,NYMIN,NYMAX,I,ICOL,IFAIL1,NMAX PARAMETER(NMAX=100) *** Determine the number of periods present in the cell. NXMIN=0 NXMAX=0 NYMIN=0 NYMAX=0 IF(PERX)THEN NXMIN=INT(GXMIN/SX)-1 NXMAX=INT(GXMAX/SX)+1 ENDIF IF(PERY)THEN NYMIN=INT(GYMIN/SY)-1 NYMAX=INT(GYMAX/SY)+1 ENDIF *** Draw the illuminated x and y-planes, set the representations. CALL GRATTS('PLANES','AREA') CALL GRATTS('PLANES','POLYLINE') * Generate the colour table (shared with the tube). IF((YNPLAN(1).OR.YNPLAN(2).OR.YNPLAN(3).OR.YNPLAN(4)).AND. - ICOLPL.EQ.0)THEN ICOLPL=ICOL0 CALL COLSHD(ICOLPL) ICOL0=ICOL0+NPRCOL ENDIF * Ensure the planes do not hide each other. IF(YNPLAN(1))THEN XPMIN=COPLAN(1) ELSE XPMIN=GXMIN ENDIF IF(YNPLAN(2))THEN XPMAX=COPLAN(2) ELSE XPMAX=GXMAX ENDIF IF(YNPLAN(3))THEN YPMIN=COPLAN(3) ELSE YPMIN=GYMIN ENDIF IF(YNPLAN(4))THEN YPMAX=COPLAN(4) ELSE YPMAX=GYMAX ENDIF * The x-planes. DO 10 NX=NXMIN,NXMAX IF(YNPLAN(1).AND.COPLAN(1)+NX*SX.GE.GXMIN.AND. - COPLAN(1)+NX*SX.LE.GXMAX.AND.FPROJA.GT.0)THEN CALL PLACOO(DBLE(COPLAN(1)+NX*SX),YPMIN,GZMIN,XPL(1),YPL(1)) CALL PLACOO(DBLE(COPLAN(1)+NX*SX),YPMIN,GZMAX,XPL(2),YPL(2)) CALL PLACOO(DBLE(COPLAN(1)+NX*SX),YPMAX,GZMAX,XPL(3),YPL(3)) CALL PLACOO(DBLE(COPLAN(1)+NX*SX),YPMAX,GZMIN,XPL(4),YPL(4)) XPL(5)=XPL(1) YPL(5)=YPL(1) CALL COLWGT(+1.0D0,0.0D0,0.0D0,WW) IF(WW.GE.0)THEN ICOL=ICOLPL+NINT(MIN(1.0D0,WW)*(NPRCOL-1)) ELSE PRINT *,' !!!!!! CELLA3 WARNING : Request to plot'// - ' a plane seen from the back (program bug).' ICOL=ICOLPL ENDIF CALL GSFACI(ICOL) CALL GFA2(5,XPL,YPL) CALL GPL2(5,XPL,YPL) ENDIF IF(YNPLAN(2).AND.COPLAN(2)+NX*SX.GE.GXMIN.AND. - COPLAN(2)+NX*SX.LE.GXMAX.AND.FPROJA.LT.0)THEN CALL PLACOO(DBLE(COPLAN(2)+NX*SX),YPMIN,GZMIN,XPL(1),YPL(1)) CALL PLACOO(DBLE(COPLAN(2)+NX*SX),YPMIN,GZMAX,XPL(2),YPL(2)) CALL PLACOO(DBLE(COPLAN(2)+NX*SX),YPMAX,GZMAX,XPL(3),YPL(3)) CALL PLACOO(DBLE(COPLAN(2)+NX*SX),YPMAX,GZMIN,XPL(4),YPL(4)) XPL(5)=XPL(1) YPL(5)=YPL(1) CALL COLWGT(-1.0D0,0.0D0,0.0D0,WW) IF(WW.GE.0)THEN ICOL=ICOLPL+NINT(MIN(1.0D0,WW)*(NPRCOL-1)) ELSE PRINT *,' !!!!!! CELLA3 WARNING : Request to plot'// - ' a plane seen from the back (program bug).' ICOL=ICOLPL ENDIF CALL GSFACI(ICOL) CALL GFA2(5,XPL,YPL) CALL GPL2(5,XPL,YPL) ENDIF 10 CONTINUE DO 20 NY=NYMIN,NYMAX IF(YNPLAN(3).AND.COPLAN(3)+NY*SY.GE.GYMIN.AND. - COPLAN(3)+NY*SY.LE.GYMAX.AND.FPROJB.GT.0)THEN CALL PLACOO(XPMIN,DBLE(COPLAN(3)+NY*SY),GZMIN,XPL(1),YPL(1)) CALL PLACOO(XPMIN,DBLE(COPLAN(3)+NY*SY),GZMAX,XPL(2),YPL(2)) CALL PLACOO(XPMAX,DBLE(COPLAN(3)+NY*SY),GZMAX,XPL(3),YPL(3)) CALL PLACOO(XPMAX,DBLE(COPLAN(3)+NY*SY),GZMIN,XPL(4),YPL(4)) XPL(5)=XPL(1) YPL(5)=YPL(1) CALL COLWGT(0.0D0,+1.0D0,0.0D0,WW) IF(WW.GE.0)THEN ICOL=ICOLPL+NINT(MIN(1.0D0,WW)*(NPRCOL-1)) ELSE PRINT *,' !!!!!! CELLA3 WARNING : Request to plot'// - ' a plane seen from the back (program bug).' ICOL=ICOLPL ENDIF CALL GSFACI(ICOL) CALL GFA2(5,XPL,YPL) CALL GPL2(5,XPL,YPL) ENDIF IF(YNPLAN(4).AND.COPLAN(4)+NY*SY.GE.GYMIN.AND. - COPLAN(4)+NY*SY.LE.GYMAX.AND.FPROJB.LT.0)THEN CALL PLACOO(XPMIN,DBLE(COPLAN(4)+NY*SY),GZMIN,XPL(1),YPL(1)) CALL PLACOO(XPMIN,DBLE(COPLAN(4)+NY*SY),GZMAX,XPL(2),YPL(2)) CALL PLACOO(XPMAX,DBLE(COPLAN(4)+NY*SY),GZMAX,XPL(3),YPL(3)) CALL PLACOO(XPMAX,DBLE(COPLAN(4)+NY*SY),GZMIN,XPL(4),YPL(4)) XPL(5)=XPL(1) YPL(5)=YPL(1) CALL COLWGT(0.0D0,-1.0D0,0.0D0,WW) IF(WW.GE.0)THEN ICOL=ICOLPL+NINT(MIN(1.0D0,WW)*(NPRCOL-1)) ELSE PRINT *,' !!!!!! CELLA3 WARNING : Request to plot'// - ' a plane seen from the back (program bug).' ICOL=ICOLPL ENDIF CALL GSFACI(ICOL) CALL GFA2(5,XPL,YPL) CALL GPL2(5,XPL,YPL) ENDIF 20 CONTINUE *** Draw the illuminated x and y-plane strips, set the representations. CALL GRATTS('STRIPS','AREA') CALL GRATTS('STRIPS','POLYLINE') * Generate the colour table (shared with the tube). IF((YNPLAN(1).OR.YNPLAN(2).OR.YNPLAN(3).OR.YNPLAN(4)).AND. - ICOLST.EQ.0)THEN ICOLST=ICOL0 CALL COLSHD(ICOLST) ICOL0=ICOL0+NPRCOL ENDIF * Ensure the planes do not hide each other. IF(YNPLAN(1))THEN XPMIN=COPLAN(1) ELSE XPMIN=GXMIN ENDIF IF(YNPLAN(2))THEN XPMAX=COPLAN(2) ELSE XPMAX=GXMAX ENDIF IF(YNPLAN(3))THEN YPMIN=COPLAN(3) ELSE YPMIN=GYMIN ENDIF IF(YNPLAN(4))THEN YPMAX=COPLAN(4) ELSE YPMAX=GYMAX ENDIF * The x-planes. DO 110 NX=NXMIN,NXMAX IF(YNPLAN(1).AND.COPLAN(1)+NX*SX.GE.GXMIN.AND. - COPLAN(1)+NX*SX.LE.GXMAX.AND.FPROJA.GT.0)THEN DO 130 I=1,NPSTR1(1) SMIN=DBLE(PLSTR1(1,I,1)) SMAX=DBLE(PLSTR1(1,I,2)) IF(SMAX.LT.GYMIN.OR.SMIN.GT.GYMAX)GOTO 130 CALL PLACOO(DBLE(COPLAN(1)+NX*SX),SMIN,GZMIN,XPL(1),YPL(1)) CALL PLACOO(DBLE(COPLAN(1)+NX*SX),SMIN,GZMAX,XPL(2),YPL(2)) CALL PLACOO(DBLE(COPLAN(1)+NX*SX),SMAX,GZMAX,XPL(3),YPL(3)) CALL PLACOO(DBLE(COPLAN(1)+NX*SX),SMAX,GZMIN,XPL(4),YPL(4)) XPL(5)=XPL(1) YPL(5)=YPL(1) CALL COLWGT(+1.0D0,0.0D0,0.0D0,WW) IF(WW.GE.0)THEN ICOL=ICOLST+NINT(MIN(1.0D0,WW)*(NPRCOL-1)) ELSE PRINT *,' !!!!!! CELLA3 WARNING : Request to plot'// - ' a plane seen from the back (program bug).' ICOL=ICOLST ENDIF CALL GSFACI(ICOL) CALL GFA2(5,XPL,YPL) CALL GPL2(5,XPL,YPL) 130 CONTINUE DO 140 I=1,NPSTR2(1) SMIN=DBLE(PLSTR2(1,I,1)) SMAX=DBLE(PLSTR2(1,I,2)) IF(SMAX.LT.GZMIN.OR.SMIN.GT.GZMAX)GOTO 140 CALL PLACOO(DBLE(COPLAN(1)+NX*SX),YPMIN,SMIN,XPL(1),YPL(1)) CALL PLACOO(DBLE(COPLAN(1)+NX*SX),YPMIN,SMAX,XPL(2),YPL(2)) CALL PLACOO(DBLE(COPLAN(1)+NX*SX),YPMAX,SMAX,XPL(3),YPL(3)) CALL PLACOO(DBLE(COPLAN(1)+NX*SX),YPMAX,SMIN,XPL(4),YPL(4)) XPL(5)=XPL(1) YPL(5)=YPL(1) CALL COLWGT(+1.0D0,0.0D0,0.0D0,WW) IF(WW.GE.0)THEN ICOL=ICOLST+NINT(MIN(1.0D0,WW)*(NPRCOL-1)) ELSE PRINT *,' !!!!!! CELLA3 WARNING : Request to plot'// - ' a plane seen from the back (program bug).' ICOL=ICOLST ENDIF CALL GSFACI(ICOL) CALL GFA2(5,XPL,YPL) CALL GPL2(5,XPL,YPL) 140 CONTINUE ENDIF IF(YNPLAN(2).AND.COPLAN(2)+NX*SX.GE.GXMIN.AND. - COPLAN(2)+NX*SX.LE.GXMAX.AND.FPROJA.LT.0)THEN DO 150 I=1,NPSTR1(2) SMIN=DBLE(PLSTR1(2,I,1)) SMAX=DBLE(PLSTR1(2,I,2)) IF(SMAX.LT.GYMIN.OR.SMIN.GT.GYMAX)GOTO 150 CALL PLACOO(DBLE(COPLAN(2)+NX*SX),SMIN,GZMIN,XPL(1),YPL(1)) CALL PLACOO(DBLE(COPLAN(2)+NX*SX),SMIN,GZMAX,XPL(2),YPL(2)) CALL PLACOO(DBLE(COPLAN(2)+NX*SX),SMAX,GZMAX,XPL(3),YPL(3)) CALL PLACOO(DBLE(COPLAN(2)+NX*SX),SMAX,GZMIN,XPL(4),YPL(4)) XPL(5)=XPL(1) YPL(5)=YPL(1) CALL COLWGT(-1.0D0,0.0D0,0.0D0,WW) IF(WW.GE.0)THEN ICOL=ICOLST+NINT(MIN(1.0D0,WW)*(NPRCOL-1)) ELSE PRINT *,' !!!!!! CELLA3 WARNING : Request to plot'// - ' a plane seen from the back (program bug).' ICOL=ICOLST ENDIF CALL GSFACI(ICOL) CALL GFA2(5,XPL,YPL) CALL GPL2(5,XPL,YPL) 150 CONTINUE DO 160 I=1,NPSTR2(2) SMIN=DBLE(PLSTR2(2,I,1)) SMAX=DBLE(PLSTR2(2,I,2)) IF(SMAX.LT.GZMIN.OR.SMIN.GT.GZMAX)GOTO 160 CALL PLACOO(DBLE(COPLAN(2)+NX*SX),YPMIN,SMIN,XPL(1),YPL(1)) CALL PLACOO(DBLE(COPLAN(2)+NX*SX),YPMIN,SMAX,XPL(2),YPL(2)) CALL PLACOO(DBLE(COPLAN(2)+NX*SX),YPMAX,SMAX,XPL(3),YPL(3)) CALL PLACOO(DBLE(COPLAN(2)+NX*SX),YPMAX,SMIN,XPL(4),YPL(4)) XPL(5)=XPL(1) YPL(5)=YPL(1) CALL COLWGT(-1.0D0,0.0D0,0.0D0,WW) IF(WW.GE.0)THEN ICOL=ICOLST+NINT(MIN(1.0D0,WW)*(NPRCOL-1)) ELSE PRINT *,' !!!!!! CELLA3 WARNING : Request to plot'// - ' a plane seen from the back (program bug).' ICOL=ICOLST ENDIF CALL GSFACI(ICOL) CALL GFA2(5,XPL,YPL) CALL GPL2(5,XPL,YPL) 160 CONTINUE ENDIF 110 CONTINUE DO 120 NY=NYMIN,NYMAX IF(YNPLAN(3).AND.COPLAN(3)+NY*SY.GE.GYMIN.AND. - COPLAN(3)+NY*SY.LE.GYMAX.AND.FPROJB.GT.0)THEN DO 170 I=1,NPSTR1(3) SMIN=DBLE(PLSTR1(3,I,1)) SMAX=DBLE(PLSTR1(3,I,2)) IF(SMAX.LT.GXMIN.OR.SMIN.GT.GXMAX)GOTO 170 CALL PLACOO(SMIN,DBLE(COPLAN(3)+NY*SY),GZMIN,XPL(1),YPL(1)) CALL PLACOO(SMIN,DBLE(COPLAN(3)+NY*SY),GZMAX,XPL(2),YPL(2)) CALL PLACOO(SMAX,DBLE(COPLAN(3)+NY*SY),GZMAX,XPL(3),YPL(3)) CALL PLACOO(SMAX,DBLE(COPLAN(3)+NY*SY),GZMIN,XPL(4),YPL(4)) XPL(5)=XPL(1) YPL(5)=YPL(1) CALL COLWGT(0.0D0,+1.0D0,0.0D0,WW) IF(WW.GE.0)THEN ICOL=ICOLST+NINT(MIN(1.0D0,WW)*(NPRCOL-1)) ELSE PRINT *,' !!!!!! CELLA3 WARNING : Request to plot'// - ' a plane seen from the back (program bug).' ICOL=ICOLST ENDIF CALL GSFACI(ICOL) CALL GFA2(5,XPL,YPL) CALL GPL2(5,XPL,YPL) 170 CONTINUE DO 180 I=1,NPSTR2(3) SMIN=DBLE(PLSTR2(3,I,1)) SMAX=DBLE(PLSTR2(3,I,2)) IF(SMAX.LT.GZMIN.OR.SMIN.GT.GZMAX)GOTO 180 CALL PLACOO(XPMIN,DBLE(COPLAN(3)+NY*SY),SMIN,XPL(1),YPL(1)) CALL PLACOO(XPMIN,DBLE(COPLAN(3)+NY*SY),SMAX,XPL(2),YPL(2)) CALL PLACOO(XPMAX,DBLE(COPLAN(3)+NY*SY),SMAX,XPL(3),YPL(3)) CALL PLACOO(XPMAX,DBLE(COPLAN(3)+NY*SY),SMIN,XPL(4),YPL(4)) XPL(5)=XPL(1) YPL(5)=YPL(1) CALL COLWGT(0.0D0,+1.0D0,0.0D0,WW) IF(WW.GE.0)THEN ICOL=ICOLST+NINT(MIN(1.0D0,WW)*(NPRCOL-1)) ELSE PRINT *,' !!!!!! CELLA3 WARNING : Request to plot'// - ' a plane seen from the back (program bug).' ICOL=ICOLST ENDIF CALL GSFACI(ICOL) CALL GFA2(5,XPL,YPL) CALL GPL2(5,XPL,YPL) 180 CONTINUE ENDIF IF(YNPLAN(4).AND.COPLAN(4)+NY*SY.GE.GYMIN.AND. - COPLAN(4)+NY*SY.LE.GYMAX.AND.FPROJB.LT.0)THEN DO 190 I=1,NPSTR1(4) SMIN=DBLE(PLSTR1(4,I,1)) SMAX=DBLE(PLSTR1(4,I,2)) IF(SMAX.LT.GXMIN.OR.SMIN.GT.GXMAX)GOTO 190 CALL PLACOO(SMIN,DBLE(COPLAN(4)+NY*SY),GZMIN,XPL(1),YPL(1)) CALL PLACOO(SMIN,DBLE(COPLAN(4)+NY*SY),GZMAX,XPL(2),YPL(2)) CALL PLACOO(SMAX,DBLE(COPLAN(4)+NY*SY),GZMAX,XPL(3),YPL(3)) CALL PLACOO(SMAX,DBLE(COPLAN(4)+NY*SY),GZMIN,XPL(4),YPL(4)) XPL(5)=XPL(1) YPL(5)=YPL(1) CALL COLWGT(0.0D0,-1.0D0,0.0D0,WW) IF(WW.GE.0)THEN ICOL=ICOLST+NINT(MIN(1.0D0,WW)*(NPRCOL-1)) ELSE PRINT *,' !!!!!! CELLA3 WARNING : Request to plot'// - ' a plane seen from the back (program bug).' ICOL=ICOLST ENDIF CALL GSFACI(ICOL) CALL GFA2(5,XPL,YPL) CALL GPL2(5,XPL,YPL) 190 CONTINUE DO 200 I=1,NPSTR2(4) SMIN=DBLE(PLSTR2(4,I,1)) SMAX=DBLE(PLSTR2(4,I,2)) IF(SMAX.LT.GZMIN.OR.SMIN.GT.GZMAX)GOTO 200 CALL PLACOO(XPMIN,DBLE(COPLAN(4)+NY*SY),SMIN,XPL(1),YPL(1)) CALL PLACOO(XPMIN,DBLE(COPLAN(4)+NY*SY),SMAX,XPL(2),YPL(2)) CALL PLACOO(XPMAX,DBLE(COPLAN(4)+NY*SY),SMAX,XPL(3),YPL(3)) CALL PLACOO(XPMAX,DBLE(COPLAN(4)+NY*SY),SMIN,XPL(4),YPL(4)) XPL(5)=XPL(1) YPL(5)=YPL(1) CALL COLWGT(0.0D0,-1.0D0,0.0D0,WW) IF(WW.GE.0)THEN ICOL=ICOLST+NINT(MIN(1.0D0,WW)*(NPRCOL-1)) ELSE PRINT *,' !!!!!! CELLA3 WARNING : Request to plot'// - ' a plane seen from the back (program bug).' ICOL=ICOLST ENDIF CALL GSFACI(ICOL) CALL GFA2(5,XPL,YPL) CALL GPL2(5,XPL,YPL) 200 CONTINUE ENDIF 120 CONTINUE *** Draw the illuminated parts of the tube. IF(TUBE)THEN * Set the representations. CALL GRATTS('TUBE','POLYLINE') CALL GRATTS('TUBE','AREA') * Generate the colour table (shared with the planes). IF(ICOLPL.EQ.0)THEN ICOLPL=ICOL0 CALL COLSHD(ICOLPL) ICOL0=ICOL0+NPRCOL ENDIF * Case of a polygon. IF(NTUBE.GT.0)THEN X1=COTUBE*COS(2.0D0*PI*DBLE(0)/DBLE(NTUBE)) Y1=COTUBE*SIN(2.0D0*PI*DBLE(0)/DBLE(NTUBE)) DO 50 I=1,NTUBE X2=COTUBE*COS(2.0D0*PI*DBLE(I)/DBLE(NTUBE)) Y2=COTUBE*SIN(2.0D0*PI*DBLE(I)/DBLE(NTUBE)) XX1=X1 YY1=Y1 XX2=X2 YY2=Y2 CALL CLIP2D(XX1,YY1,XX2,YY2,GXMIN,GYMIN, - GXMAX,GYMAX,IFAIL1) IF(IFAIL1.NE.0)THEN X1=X2 Y1=Y2 GOTO 50 ENDIF CALL PLACOO(XX1,YY1,GZMIN,XPL(1),YPL(1)) CALL PLACOO(XX1,YY1,GZMAX,XPL(2),YPL(2)) CALL PLACOO(XX2,YY2,GZMAX,XPL(3),YPL(3)) CALL PLACOO(XX2,YY2,GZMIN,XPL(4),YPL(4)) XPL(5)=XPL(1) YPL(5)=YPL(1) CALL COLWGT(-X1-X2,-Y1-Y2,0.0D0,WW) IF(WW.GE.0)THEN ICOL=ICOLPL+NINT(MIN(1.0D0,WW)*(NPRCOL-1)) CALL GSFACI(ICOL) CALL GFA2(5,XPL,YPL) CALL GPL2(5,XPL,YPL) ENDIF X1=X2 Y1=Y2 50 CONTINUE * Case of a cylinder. ELSE X1=COTUBE*COS(2.0D0*PI*DBLE(0)/DBLE(NMAX)) Y1=COTUBE*SIN(2.0D0*PI*DBLE(0)/DBLE(NMAX)) DO 70 I=1,NMAX X2=COTUBE*COS(2.0D0*PI*DBLE(I)/DBLE(NMAX)) Y2=COTUBE*SIN(2.0D0*PI*DBLE(I)/DBLE(NMAX)) XX1=X1 YY1=Y1 XX2=X2 YY2=Y2 CALL CLIP2D(XX1,YY1,XX2,YY2,GXMIN,GYMIN, - GXMAX,GYMAX,IFAIL1) IF(IFAIL1.NE.0)THEN X1=X2 Y1=Y2 GOTO 70 ENDIF CALL PLACOO(XX1,YY1,GZMIN,XPL(1),YPL(1)) CALL PLACOO(XX1,YY1,GZMAX,XPL(2),YPL(2)) CALL PLACOO(XX2,YY2,GZMAX,XPL(3),YPL(3)) CALL PLACOO(XX2,YY2,GZMIN,XPL(4),YPL(4)) XPL(5)=XPL(1) YPL(5)=YPL(1) CALL COLWGT(-X1-X2,-Y1-Y2,0.0D0,WW) IF(WW.GE.0)THEN ICOL=ICOLPL+NINT(MIN(1.0D0,WW)*(NPRCOL-1)) CALL GSFACI(ICOL) CALL GFA2(5,XPL,YPL) ENDIF CALL GPL2(2,XPL(2),YPL(2)) CALL GPL2(2,XPL(4),YPL(4)) X1=X2 Y1=Y2 70 CONTINUE ENDIF ENDIF *** Plot the solids. CALL PLAPLT *** Draw the parts of the tube seen from the outside. IF(TUBE.AND.LFULLT)THEN * Set the representations. CALL GRATTS('TUBE','POLYLINE') * Case of a polygon. IF(NTUBE.GT.0)THEN X1=COTUBE*COS(2.0D0*PI*DBLE(0)/DBLE(NTUBE)) Y1=COTUBE*SIN(2.0D0*PI*DBLE(0)/DBLE(NTUBE)) DO 60 I=1,NTUBE X2=COTUBE*COS(2.0D0*PI*DBLE(I)/DBLE(NTUBE)) Y2=COTUBE*SIN(2.0D0*PI*DBLE(I)/DBLE(NTUBE)) XX1=X1 YY1=Y1 XX2=X2 YY2=Y2 CALL CLIP2D(XX1,YY1,XX2,YY2,GXMIN,GYMIN, - GXMAX,GYMAX,IFAIL1) IF(IFAIL1.NE.0)THEN X1=X2 Y1=Y2 GOTO 60 ENDIF CALL PLACOO(XX1,YY1,GZMIN,XPL(1),YPL(1)) CALL PLACOO(XX1,YY1,GZMAX,XPL(2),YPL(2)) CALL PLACOO(XX2,YY2,GZMAX,XPL(3),YPL(3)) CALL PLACOO(XX2,YY2,GZMIN,XPL(4),YPL(4)) XPL(5)=XPL(1) YPL(5)=YPL(1) CALL COLWGT(-X1-X2,-Y1-Y2,0.0D0,WW) IF(WW.LT.0)CALL GPL2(5,XPL,YPL) X1=X2 Y1=Y2 60 CONTINUE * Case of a cylinder. ELSE X1=COTUBE*COS(2.0D0*PI*DBLE(0)/DBLE(NMAX)) Y1=COTUBE*SIN(2.0D0*PI*DBLE(0)/DBLE(NMAX)) DO 80 I=1,NMAX X2=COTUBE*COS(2.0D0*PI*DBLE(I)/DBLE(NMAX)) Y2=COTUBE*SIN(2.0D0*PI*DBLE(I)/DBLE(NMAX)) XX1=X1 YY1=Y1 XX2=X2 YY2=Y2 CALL CLIP2D(XX1,YY1,XX2,YY2,GXMIN,GYMIN, - GXMAX,GYMAX,IFAIL1) IF(IFAIL1.NE.0)THEN X1=X2 Y1=Y2 GOTO 80 ENDIF CALL COLWGT(-X1-X2,-Y1-Y2,0.0D0,WW) IF(WW.LT.0)THEN CALL PLACOO(XX1,YY1,GZMIN,XPL(1),YPL(1)) CALL PLACOO(XX2,YY2,GZMIN,XPL(2),YPL(2)) CALL GPL2(2,XPL,YPL) CALL PLACOO(XX1,YY1,GZMAX,XPL(1),YPL(1)) CALL PLACOO(XX2,YY2,GZMAX,XPL(2),YPL(2)) CALL GPL2(2,XPL,YPL) ENDIF X1=X2 Y1=Y2 80 CONTINUE ENDIF ENDIF *** Second pass of the x and y-planes, set the representations. IF(LFULLP)THEN * Set the representation. CALL GRATTS('PLANES','POLYLINE') * The x-planes. DO 30 NX=NXMIN,NXMAX IF(YNPLAN(1).AND.COPLAN(1)+NX*SX.GE.GXMIN.AND. - COPLAN(1)+NX*SX.LE.GXMAX.AND.FPROJA.LE.0)THEN CALL PLACOO(DBLE(COPLAN(1)+NX*SX),YPMIN,GZMIN, - XPL(1),YPL(1)) CALL PLACOO(DBLE(COPLAN(1)+NX*SX),YPMIN,GZMAX, - XPL(2),YPL(2)) CALL PLACOO(DBLE(COPLAN(1)+NX*SX),YPMAX,GZMAX, - XPL(3),YPL(3)) CALL PLACOO(DBLE(COPLAN(1)+NX*SX),YPMAX,GZMIN, - XPL(4),YPL(4)) XPL(5)=XPL(1) YPL(5)=YPL(1) CALL GPL2(5,XPL,YPL) ENDIF IF(YNPLAN(2).AND.COPLAN(2)+NX*SX.GE.GXMIN.AND. - COPLAN(2)+NX*SX.LE.GXMAX.AND.FPROJA.GE.0)THEN CALL PLACOO(DBLE(COPLAN(2)+NX*SX),YPMIN,GZMIN, - XPL(1),YPL(1)) CALL PLACOO(DBLE(COPLAN(2)+NX*SX),YPMIN,GZMAX, - XPL(2),YPL(2)) CALL PLACOO(DBLE(COPLAN(2)+NX*SX),YPMAX,GZMAX, - XPL(3),YPL(3)) CALL PLACOO(DBLE(COPLAN(2)+NX*SX),YPMAX,GZMIN, - XPL(4),YPL(4)) XPL(5)=XPL(1) YPL(5)=YPL(1) CALL GPL2(5,XPL,YPL) ENDIF 30 CONTINUE DO 40 NY=NYMIN,NYMAX IF(YNPLAN(3).AND.COPLAN(3)+NY*SY.GE.GYMIN.AND. - COPLAN(3)+NY*SY.LE.GYMAX.AND.FPROJB.LE.0)THEN CALL PLACOO(XPMIN,DBLE(COPLAN(3)+NY*SY),GZMIN, - XPL(1),YPL(1)) CALL PLACOO(XPMIN,DBLE(COPLAN(3)+NY*SY),GZMAX, - XPL(2),YPL(2)) CALL PLACOO(XPMAX,DBLE(COPLAN(3)+NY*SY),GZMAX, - XPL(3),YPL(3)) CALL PLACOO(XPMAX,DBLE(COPLAN(3)+NY*SY),GZMIN, - XPL(4),YPL(4)) XPL(5)=XPL(1) YPL(5)=YPL(1) CALL GPL2(5,XPL,YPL) ENDIF IF(YNPLAN(4).AND.COPLAN(4)+NY*SY.GE.GYMIN.AND. - COPLAN(4)+NY*SY.LE.GYMAX.AND.FPROJB.GE.0)THEN CALL PLACOO(XPMIN,DBLE(COPLAN(4)+NY*SY),GZMIN, - XPL(1),YPL(1)) CALL PLACOO(XPMIN,DBLE(COPLAN(4)+NY*SY),GZMAX, - XPL(2),YPL(2)) CALL PLACOO(XPMAX,DBLE(COPLAN(4)+NY*SY),GZMAX, - XPL(3),YPL(3)) CALL PLACOO(XPMAX,DBLE(COPLAN(4)+NY*SY),GZMIN, - XPL(4),YPL(4)) XPL(5)=XPL(1) YPL(5)=YPL(1) CALL GPL2(5,XPL,YPL) ENDIF 40 CONTINUE ** Plot the strips, set the representation. CALL GRATTS('STRIPS','POLYLINE') * The x-planes. DO 210 NX=NXMIN,NXMAX IF(YNPLAN(1).AND.COPLAN(1)+NX*SX.GE.GXMIN.AND. - COPLAN(1)+NX*SX.LE.GXMAX.AND.FPROJA.LE.0)THEN DO 230 I=1,NPSTR1(1) SMIN=DBLE(PLSTR1(1,I,1)) SMAX=DBLE(PLSTR1(1,I,2)) IF(SMAX.LT.GYMIN.OR.SMIN.GT.GYMAX)GOTO 230 CALL PLACOO(DBLE(COPLAN(1)+NX*SX),SMIN,GZMIN, - XPL(1),YPL(1)) CALL PLACOO(DBLE(COPLAN(1)+NX*SX),SMIN,GZMAX, - XPL(2),YPL(2)) CALL PLACOO(DBLE(COPLAN(1)+NX*SX),SMAX,GZMAX, - XPL(3),YPL(3)) CALL PLACOO(DBLE(COPLAN(1)+NX*SX),SMAX,GZMIN, - XPL(4),YPL(4)) XPL(5)=XPL(1) YPL(5)=YPL(1) CALL GPL2(5,XPL,YPL) 230 CONTINUE DO 240 I=1,NPSTR2(1) SMIN=DBLE(PLSTR2(1,I,1)) SMAX=DBLE(PLSTR2(1,I,2)) IF(SMAX.LT.GZMIN.OR.SMIN.GT.GZMAX)GOTO 240 CALL PLACOO(DBLE(COPLAN(1)+NX*SX),YPMIN,SMIN, - XPL(1),YPL(1)) CALL PLACOO(DBLE(COPLAN(1)+NX*SX),YPMIN,SMAX, - XPL(2),YPL(2)) CALL PLACOO(DBLE(COPLAN(1)+NX*SX),YPMAX,SMAX, - XPL(3),YPL(3)) CALL PLACOO(DBLE(COPLAN(1)+NX*SX),YPMAX,SMIN, - XPL(4),YPL(4)) XPL(5)=XPL(1) YPL(5)=YPL(1) CALL GPL2(5,XPL,YPL) 240 CONTINUE ENDIF IF(YNPLAN(2).AND.COPLAN(2)+NX*SX.GE.GXMIN.AND. - COPLAN(2)+NX*SX.LE.GXMAX.AND.FPROJA.GE.0)THEN DO 250 I=1,NPSTR1(2) SMIN=DBLE(PLSTR1(2,I,1)) SMAX=DBLE(PLSTR1(2,I,2)) IF(SMAX.LT.GYMIN.OR.SMIN.GT.GYMAX)GOTO 250 CALL PLACOO(DBLE(COPLAN(2)+NX*SX),SMIN,GZMIN, - XPL(1),YPL(1)) CALL PLACOO(DBLE(COPLAN(2)+NX*SX),SMIN,GZMAX, - XPL(2),YPL(2)) CALL PLACOO(DBLE(COPLAN(2)+NX*SX),SMAX,GZMAX, - XPL(3),YPL(3)) CALL PLACOO(DBLE(COPLAN(2)+NX*SX),SMAX,GZMIN, - XPL(4),YPL(4)) XPL(5)=XPL(1) YPL(5)=YPL(1) CALL GPL2(5,XPL,YPL) 250 CONTINUE DO 260 I=1,NPSTR2(2) SMIN=DBLE(PLSTR2(2,I,1)) SMAX=DBLE(PLSTR2(2,I,2)) IF(SMAX.LT.GZMIN.OR.SMIN.GT.GZMAX)GOTO 260 CALL PLACOO(DBLE(COPLAN(2)+NX*SX),YPMIN,SMIN, - XPL(1),YPL(1)) CALL PLACOO(DBLE(COPLAN(2)+NX*SX),YPMIN,SMAX, - XPL(2),YPL(2)) CALL PLACOO(DBLE(COPLAN(2)+NX*SX),YPMAX,SMAX, - XPL(3),YPL(3)) CALL PLACOO(DBLE(COPLAN(2)+NX*SX),YPMAX,SMIN, - XPL(4),YPL(4)) XPL(5)=XPL(1) YPL(5)=YPL(1) CALL GPL2(5,XPL,YPL) 260 CONTINUE ENDIF 210 CONTINUE DO 220 NY=NYMIN,NYMAX IF(YNPLAN(3).AND.COPLAN(3)+NY*SY.GE.GYMIN.AND. - COPLAN(3)+NY*SY.LE.GYMAX.AND.FPROJB.LE.0)THEN DO 270 I=1,NPSTR1(3) SMIN=DBLE(PLSTR1(3,I,1)) SMAX=DBLE(PLSTR1(3,I,2)) IF(SMAX.LT.GXMIN.OR.SMIN.GT.GXMAX)GOTO 270 CALL PLACOO(SMIN,DBLE(COPLAN(3)+NY*SY),GZMIN, - XPL(1),YPL(1)) CALL PLACOO(SMIN,DBLE(COPLAN(3)+NY*SY),GZMAX, - XPL(2),YPL(2)) CALL PLACOO(SMAX,DBLE(COPLAN(3)+NY*SY),GZMAX, - XPL(3),YPL(3)) CALL PLACOO(SMAX,DBLE(COPLAN(3)+NY*SY),GZMIN, - XPL(4),YPL(4)) XPL(5)=XPL(1) YPL(5)=YPL(1) CALL GPL2(5,XPL,YPL) 270 CONTINUE DO 280 I=1,NPSTR2(3) SMIN=DBLE(PLSTR2(3,I,1)) SMAX=DBLE(PLSTR2(3,I,2)) IF(SMAX.LT.GZMIN.OR.SMIN.GT.GZMAX)GOTO 280 CALL PLACOO(XPMIN,DBLE(COPLAN(3)+NY*SY),SMIN, - XPL(1),YPL(1)) CALL PLACOO(XPMIN,DBLE(COPLAN(3)+NY*SY),SMAX, - XPL(2),YPL(2)) CALL PLACOO(XPMAX,DBLE(COPLAN(3)+NY*SY),SMAX, - XPL(3),YPL(3)) CALL PLACOO(XPMAX,DBLE(COPLAN(3)+NY*SY),SMIN, - XPL(4),YPL(4)) XPL(5)=XPL(1) YPL(5)=YPL(1) CALL GPL2(5,XPL,YPL) 280 CONTINUE ENDIF IF(YNPLAN(4).AND.COPLAN(4)+NY*SY.GE.GYMIN.AND. - COPLAN(4)+NY*SY.LE.GYMAX.AND.FPROJB.GE.0)THEN DO 290 I=1,NPSTR1(4) SMIN=DBLE(PLSTR1(4,I,1)) SMAX=DBLE(PLSTR1(4,I,2)) IF(SMAX.LT.GXMIN.OR.SMIN.GT.GXMAX)GOTO 290 CALL PLACOO(SMIN,DBLE(COPLAN(4)+NY*SY),GZMIN, - XPL(1),YPL(1)) CALL PLACOO(SMIN,DBLE(COPLAN(4)+NY*SY),GZMAX, - XPL(2),YPL(2)) CALL PLACOO(SMAX,DBLE(COPLAN(4)+NY*SY),GZMAX, - XPL(3),YPL(3)) CALL PLACOO(SMAX,DBLE(COPLAN(4)+NY*SY),GZMIN, - XPL(4),YPL(4)) XPL(5)=XPL(1) YPL(5)=YPL(1) CALL GPL2(5,XPL,YPL) 290 CONTINUE DO 300 I=1,NPSTR2(4) SMIN=DBLE(PLSTR2(4,I,1)) SMAX=DBLE(PLSTR2(4,I,2)) IF(SMAX.LT.GZMIN.OR.SMIN.GT.GZMAX)GOTO 300 CALL PLACOO(XPMIN,DBLE(COPLAN(4)+NY*SY),SMIN, - XPL(1),YPL(1)) CALL PLACOO(XPMIN,DBLE(COPLAN(4)+NY*SY),SMAX, - XPL(2),YPL(2)) CALL PLACOO(XPMAX,DBLE(COPLAN(4)+NY*SY),SMAX, - XPL(3),YPL(3)) CALL PLACOO(XPMAX,DBLE(COPLAN(4)+NY*SY),SMIN, - XPL(4),YPL(4)) XPL(5)=XPL(1) YPL(5)=YPL(1) CALL GPL2(5,XPL,YPL) 300 CONTINUE ENDIF 220 CONTINUE ENDIF END +DECK,CELLAC. SUBROUTINE CELLAC(VXMIN,VYMIN,VXMAX,VYMAX) *----------------------------------------------------------------------- * CELLAC - This routine draws all elements of the cell inside the * rectangle (VXMIN,VYMIN) to (VXMAX,VYMAX), taking care of * periodicities etc, on the plot being made. Basic version * for 3D impression. * VARIABLES : NXMIN,NXMAX: Numbers of resp first and last x-period. * NYMIN,NYMAX: " " " " " " y " * (Last changed on 8/10/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,CONSTANTS. +SEQ,PRINTPLOT. +SEQ,PARAMETERS. +SEQ,SOLIDS. DOUBLE PRECISION VXMIN,VYMIN,VXMAX,VYMAX INTEGER NX,NXMIN,NXMAX,NY,NYMIN,NYMAX *** Determine the number of periods present in the cell. NXMIN=0 NXMAX=0 NYMIN=0 NYMAX=0 IF(PERX)THEN NXMIN=INT(GXMIN/SX)-1 NXMAX=INT(GXMAX/SX)+1 ENDIF IF(PERY)THEN NYMIN=INT(GYMIN/SY)-1 NYMAX=INT(GYMAX/SY)+1 ENDIF *** Draw the field map if present. CALL MAPPLT(REAL(GXMIN),REAL(GYMIN),REAL(GZMIN), - REAL(GXMAX),REAL(GYMAX),REAL(GZMAX)) *** Draw the cuts. CALL PLAPLT *** Draw lines at the positions of the x and y-planes. CALL GRATTS('PLANES','POLYLINE') DO 60 NX=NXMIN,NXMAX IF(YNPLAN(1).AND.COPLAN(1)+NX*SX.GE.GXMIN.AND. - COPLAN(1)+NX*SX.LE.GXMAX)CALL PLAPLA(1.0D0,0.0D0,0.0D0, - DBLE(COPLAN(1)+NX*SX),VXMIN,VYMIN,VXMAX,VYMAX) IF(YNPLAN(2).AND.COPLAN(2)+NX*SX.GE.GXMIN.AND. - COPLAN(2)+NX*SX.LE.GXMAX)CALL PLAPLA(1.0D0,0.0D0,0.0D0, - DBLE(COPLAN(2)+NX*SX),VXMIN,VYMIN,VXMAX,VYMAX) 60 CONTINUE DO 90 NY=NYMIN,NYMAX IF(YNPLAN(3).AND.COPLAN(3)+NY*SY.GE.GYMIN.AND. - COPLAN(3)+NY*SY.LE.GYMAX)CALL PLAPLA(0.0D0,1.0D0,0.0D0, - DBLE(COPLAN(3)+NY*SY),VXMIN,VYMIN,VXMAX,VYMAX) IF(YNPLAN(4).AND.COPLAN(4)+NY*SY.GE.GYMIN.AND. - COPLAN(4)+NY*SY.LE.GYMAX)CALL PLAPLA(0.0D0,1.0D0,0.0D0, - DBLE(COPLAN(4)+NY*SY),VXMIN,VYMIN,VXMAX,VYMAX) 90 CONTINUE *** Draw the tube. IF(TUBE)THEN CALL GRATTS('TUBE','POLYLINE') CALL PLATUB(DBLE(COTUBE),NTUBE,DBLE(ZMIN),DBLE(ZMAX)) ENDIF END +DECK,CELWCH. SUBROUTINE CELWCH(IFAIL) *----------------------------------------------------------------------- * CELWCH - Subroutine checking the wire positions only, contrary * to CELCHK, this routine does not modify the cell. * (Last changed on 22/ 5/96.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,PRINTPLOT. +SEQ,PARAMETERS. +SEQ,CONSTANTS. *** Identify the routine. IF(LIDENT)PRINT *,' /// ROUTINE CELWCH ///' IFAIL=0 *** Preliminary checks, NWIRE > 0, data has to be present. IF(NWIRE.LE.0)THEN IFAIL=1 RETURN ENDIF IF(NWIRE.LE.1.AND. - .NOT.(YNPLAN(1).OR.YNPLAN(2).OR.YNPLAN(3).OR.YNPLAN(4)).AND. - .NOT.TUBE)THEN IFAIL=1 RETURN ENDIF *** Check position relative to the planes. DO 70 I=1,NWIRE IF(YNPLAN(1).AND.X(I)-0.5*D(I).LE.COPLAN(1))IFAIL=1 IF(YNPLAN(2).AND.X(I)+0.5*D(I).GE.COPLAN(2))IFAIL=1 IF(YNPLAN(3).AND.Y(I)-0.5*D(I).LE.COPLAN(3))IFAIL=1 IF(YNPLAN(4).AND.Y(I)+0.5*D(I).GE.COPLAN(4))IFAIL=1 IF(TUBE)THEN CALL INTUBE(X(I),Y(I),COTUBE,NTUBE,IOUT) IF(IOUT.NE.0)IFAIL=1 ELSEIF((PERX.AND.D(I).GE.SX).OR.(PERY.AND.D(I).GE.SY))THEN IFAIL=1 ENDIF 70 CONTINUE *** Don't continue if IFAIL is already 1. IF(IFAIL.NE.0)RETURN *** Check the wire spacing. DO 90 I=1,NWIRE DO 80 J=I+1,NWIRE IF(TUBE)THEN IF(PERY)THEN CALL CFMCTP(X(I),Y(I),XAUX1,YAUX1,1) CALL CFMCTP(X(J),Y(J),XAUX2,YAUX2,1) YAUX1=YAUX1-SY*ANINT(YAUX1/SY) YAUX2=YAUX2-SY*ANINT(YAUX2/SY) CALL CFMPTC(XAUX1,YAUX1,XAUX1,YAUX1,1) CALL CFMPTC(XAUX2,YAUX2,XAUX2,YAUX2,1) XSEPAR=XAUX1-XAUX2 YSEPAR=YAUX1-YAUX2 ELSE XSEPAR=X(I)-X(J) YSEPAR=Y(I)-Y(J) ENDIF ELSE XSEPAR=ABS(X(I)-X(J)) IF(PERX)XSEPAR=XSEPAR-SX*ANINT(XSEPAR/SX) YSEPAR=ABS(Y(I)-Y(J)) IF(PERY)YSEPAR=YSEPAR-SY*ANINT(YSEPAR/SY) ENDIF IF(XSEPAR**2+YSEPAR**2.LT.0.25*(D(I)+D(J))**2)IFAIL=1 80 CONTINUE 90 CONTINUE END +DECK,CELDEF. SUBROUTINE CELDEF(IFAIL) *----------------------------------------------------------------------- * CELDEF - Routine controling the flow of the cell-definition routines * it calls CELINP ,CELPRT, CELPLT, CELCHK, SETUP and CELTYP. * VARIABLES : IGET : 1 if cell was read from dataset, 0 else. * (Last changed on 7/12/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. +SEQ,CONSTANTS. +SEQ,CELLDATA. +SEQ,FIELDMAP. +SEQ,PARAMETERS. +SEQ,DRIFTLINE. INTEGER IFAIL,IGET,I,J *** Reset the cell data. CALL CELINT IF(LSYNCH)WRITE(6,'('' >>>>>> set cell set 0'')') *** Write the header of the cell section. WRITE(*,'(''1'')') PRINT *,' ================================================' PRINT *,' ========== Start of cell definition ==========' PRINT *,' ================================================' PRINT *,' ' *** Read the cell data, IGET tells the origin of the data. IGET=0 CALL CELINP(IGET,IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' ###### CELDEF ERROR : Your cell description'// - ' can not be processed ; no cell data.' RETURN ENDIF IF(IGET.EQ.1)GOTO 10 *** Check that the cell makes sense. CALL CELCHK(IFAIL) IF(IFAIL.EQ.1)THEN PRINT *,' ###### CELDEF ERROR : Your cell does not'// - ' meet the requirements ; no cell data.' RETURN ENDIF *** Determine the cell type. CALL CELTYP *** Calculate the charges. CALL SETUP(IFAIL) IF(IFAIL.EQ.1)THEN PRINT *,' ###### CELDEF ERROR : Cell preparation is'// - ' stopped; end of this cell section.' RETURN ENDIF *** Assign default strip widths. CALL CELSTR(IFAIL) IF(IFAIL.EQ.1)THEN PRINT *,' ###### CELDEF ERROR : Strip preparation'// - ' failed; end of this cell section.' RETURN ENDIF 10 CONTINUE *** Output the cell data to a printer or a plotter, if requested. IF(LCELPR)CALL CELPRT IF(LCELPL)CALL CELPLT *** Write the complete cell data in compact format to a dataset. CALL CELWRT(2) *** Preselect the sense wires, taking all wires with code S. NSW=0 DO 20 I=1,NWIRE IF(WIRTYP(I).EQ.'S')THEN NSW=NSW+1 INDSW(I)=NSW ELSE INDSW(I)=0 ENDIF 20 CONTINUE DO 30 I=1,5 IF(I.LE.4)THEN IF(.NOT.YNPLAN(I))GOTO 30 ENDIF IF(PLATYP(I).EQ.'S')THEN NSW=NSW+1 INDPLA(I)=NSW ELSE INDPLA(I)=0 ENDIF DO 50 J=1,NPSTR1(I) IF(PSLAB1(I,J).EQ.'S')THEN NSW=NSW+1 INDST1(I,J)=NSW ELSE INDST1(I,J)=0 ENDIF 50 CONTINUE DO 60 J=1,NPSTR2(I) IF(PSLAB2(I,J).EQ.'S')THEN NSW=NSW+1 INDST2(I,J)=NSW ELSE INDST2(I,J)=0 ENDIF 60 CONTINUE 30 CONTINUE DO 40 I=1,NWMAP IF(EWSTYP(I).EQ.'S')THEN NSW=NSW+1 INDEWS(I)=NSW ELSE INDEWS(I)=0 ENDIF 40 CONTINUE IF(NSW.GT.MXSW)THEN PRINT *,' !!!!!! CELDEF WARNING : Too many'// - ' electrodes with label S for default'// - ' selection; reducing the set.' NSW=MXSW ENDIF *** Get rid of the current track. CALL TRAINT *** Set the default field plotting area. PXMIN=XMIN-(XMAX-XMIN)*0.1 PXMAX=XMAX+(XMAX-XMIN)*0.1 PYMIN=YMIN-(YMAX-YMIN)*0.1 PYMAX=YMAX+(YMAX-YMIN)*0.1 PZMIN=ZMIN-(ZMAX-ZMIN)*0.1 PZMAX=ZMAX+(ZMAX-ZMIN)*0.1 IF(POLAR.AND.PYMAX-PYMIN.GE.2.0*PI)THEN PYMIN=-PI PYMAX=PI ENDIF *** Set the default graphics area. GXMIN=DBLE(PXMIN) GYMIN=DBLE(PYMIN) GZMIN=DBLE(PZMIN) GXMAX=DBLE(PXMAX) GYMAX=DBLE(PYMAX) GZMAX=DBLE(PZMAX) *** Define the default drift area. DXMIN=XMIN IF(YNPLAN(1))DXMIN=COPLAN(1)+0.01*(XMAX-XMIN) DXMAX=XMAX IF(YNPLAN(2))DXMAX=COPLAN(2)-0.01*(XMAX-XMIN) DYMIN=YMIN IF(YNPLAN(3))DYMIN=COPLAN(3)+0.01*(YMAX-YMIN) DYMAX=YMAX IF(YNPLAN(4))DYMAX=COPLAN(4)-0.01*(YMAX-YMIN) DZMIN=ZMIN DZMAX=ZMAX IF(POLAR.AND.DYMAX-DYMIN.GE.2.0*PI)THEN PYMIN=-PI PYMAX=+PI ENDIF *** Set the default projection method. CALL PLAINT IF(POLAR)THEN PRVIEW='R-PHI' ELSE PRVIEW='X-Y' ENDIF *** Seems to have worked. CELSET=.TRUE. *** Output for synchronisation. IF(LSYNCH)CALL CELSYN END +DECK,CELRES. SUBROUTINE CELRES(IFAIL) *----------------------------------------------------------------------- * CELRES - Recomputes the current cell after modification. * VARIABLES : * (Last changed on 5/12/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. +SEQ,CONSTANTS. +SEQ,CELLDATA. +SEQ,FIELDMAP. +SEQ,PARAMETERS. +SEQ,DRIFTLINE. INTEGER IFAIL,I,J *** Tracing output. IF(LIDENT)PRINT *,' /// ROUTINE CELRES ///' *** Reset the cell flag. CELSET=.FALSE. IF(LSYNCH)WRITE(6,'('' >>>>>> set cell set 0'')') *** Check that the cell makes sense. CALL CELCHK(IFAIL) IF(IFAIL.EQ.1)THEN PRINT *,' ###### CELRES ERROR : Your cell does not'// - ' meet the requirements ; no cell data.' RETURN ENDIF *** Determine the cell type. CALL CELTYP *** Calculate the charges. CALL SETUP(IFAIL) IF(IFAIL.EQ.1)THEN PRINT *,' ###### CELRES ERROR : Cell preparation is'// - ' stopped; end of this cell-section' PRINT *,' slightly varying the'// - ' wire diameters might help.' RETURN ENDIF 10 CONTINUE *** Preselect the sense wires, taking all wires with code S. NSW=0 DO 20 I=1,NWIRE IF(WIRTYP(I).EQ.'S')THEN NSW=NSW+1 INDSW(I)=NSW ELSE INDSW(I)=0 ENDIF 20 CONTINUE DO 30 I=1,5 IF(I.LE.4)THEN IF(.NOT.YNPLAN(I))GOTO 30 ENDIF IF(PLATYP(I).EQ.'S')THEN NSW=NSW+1 INDPLA(I)=NSW ELSE INDPLA(I)=0 ENDIF DO 50 J=1,NPSTR1(I) IF(PSLAB1(I,J).EQ.'S')THEN NSW=NSW+1 INDST1(I,J)=NSW ELSE INDST1(I,J)=0 ENDIF 50 CONTINUE DO 60 J=1,NPSTR2(I) IF(PSLAB2(I,J).EQ.'S')THEN NSW=NSW+1 INDST2(I,J)=NSW ELSE INDST2(I,J)=0 ENDIF 60 CONTINUE 30 CONTINUE DO 40 I=1,NWMAP IF(EWSTYP(I).EQ.'S')THEN NSW=NSW+1 INDEWS(I)=NSW ELSE INDEWS(I)=0 ENDIF 40 CONTINUE IF(NSW.GT.MXSW)THEN PRINT *,' !!!!!! CELRES WARNING : Too many'// - ' electrodes with label S for default'// - ' selection; reducing the set.' NSW=MXSW ENDIF *** Get rid of the current track. CALL TRAINT *** Set the default field plotting area. PXMIN=XMIN-(XMAX-XMIN)*0.1 PXMAX=XMAX+(XMAX-XMIN)*0.1 PYMIN=YMIN-(YMAX-YMIN)*0.1 PYMAX=YMAX+(YMAX-YMIN)*0.1 PZMIN=ZMIN-(ZMAX-ZMIN)*0.1 PZMAX=ZMAX+(ZMAX-ZMIN)*0.1 IF(POLAR.AND.PYMAX-PYMIN.GE.2.0*PI)THEN PYMIN=-PI PYMAX=PI ENDIF *** Set the default graphics area. GXMIN=DBLE(PXMIN) GYMIN=DBLE(PYMIN) GZMIN=DBLE(PZMIN) GXMAX=DBLE(PXMAX) GYMAX=DBLE(PYMAX) GZMAX=DBLE(PZMAX) *** Define the default drift area. DXMIN=XMIN IF(YNPLAN(1))DXMIN=COPLAN(1)+0.01*(XMAX-XMIN) DXMAX=XMAX IF(YNPLAN(2))DXMAX=COPLAN(2)-0.01*(XMAX-XMIN) DYMIN=YMIN IF(YNPLAN(3))DYMIN=COPLAN(3)+0.01*(YMAX-YMIN) DYMAX=YMAX IF(YNPLAN(4))DYMAX=COPLAN(4)-0.01*(YMAX-YMIN) DZMIN=ZMIN DZMAX=ZMAX IF(POLAR.AND.DYMAX-DYMIN.GE.2.0*PI)THEN PYMIN=-PI PYMAX=+PI ENDIF *** Seems to have worked. CELSET=.TRUE. *** Output for synchronisation. IF(LSYNCH)CALL CELSYN END +DECK,CELGET. SUBROUTINE CELGET(IFAIL) *----------------------------------------------------------------------- * CELGET - This routine reads all cell information from an external * dataset. It checks that the dataset exists and that it is * of the correct type. * VARIABLES : STRING : Character string that should contain a * description of the dataset being read. * (Last changed on 29/11/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,SOLIDS. +SEQ,PRINTPLOT. CHARACTER*(MXINCH) STRING CHARACTER*8 MEMBER CHARACTER*(MXNAME) FILE CHARACTER*1 DUMMY INTEGER IFAIL,IFAIL1,NCFILE,NCMEMB,NWORD,I,J,K,IOS LOGICAL DSNCMP,EXIS EXTERNAL DSNCMP *** Identify the routine, if requested. IF(LIDENT)PRINT *,' /// ROUTINE CELGET ///' *** Initialise IFAIL on 1 (i.e. fail). IFAIL=1 FILE=' ' MEMBER='*' NCFILE=8 NCMEMB=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.2)THEN CALL INPSTR(2,2,STRING,NCFILE) FILE=STRING ENDIF * If there's a second argument, it is the member name. IF(NWORD.GE.3)THEN CALL INPSTR(3,3,STRING,NCMEMB) MEMBER=STRING ENDIF * Check the various lengths. IF(NCFILE.GT.MXNAME)THEN PRINT *,' !!!!!! CELGET WARNING : The file name is'// - ' truncated to MXNAME (=',MXNAME,') characters.' NCFILE=MIN(NCFILE,MXNAME) ENDIF IF(NCMEMB.GT.8)THEN PRINT *,' !!!!!! CELGET WARNING : The member name is'// - ' shortened to ',MEMBER,', first 8 characters.' NCMEMB=MIN(NCMEMB,8) ELSEIF(NCMEMB.LE.0)THEN PRINT *,' !!!!!! CELGET 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 *,' !!!!!! CELGET WARNING : GET must be at least'// - ' followed by a dataset name ; no data are read.' RETURN ENDIF * If there are even more args, warn because they are ignored. IF(NWORD.GT.3)PRINT *,' !!!!!! CELGET WARNING : GET takes'// - ' at most two arguments (dataset and member); rest ignored.' *** Open the dataset and inform DSNLOG. CALL DSNOPN(FILE(1:NCFILE),NCFILE,12,'READ-LIBRARY',IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! CELGET WARNING : Opening ',FILE(1:NCFILE), - ' failed ; cell data are not read.' RETURN ENDIF CALL DSNLOG(FILE,'Cell data ','Sequential','Read only ') IF(LDEBUG)PRINT *,' ++++++ CELGET 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,'CELL ',12,EXIS,'RESPECT') IF(.NOT.EXIS)THEN CALL DSNLOC(MEMBER,NCMEMB,'CELL ',12,EXIS,'IGNORE') IF(EXIS)THEN PRINT *,' ###### CELGET ERROR : Cell description ', - MEMBER(1:NCMEMB),' has been deleted from ', - FILE(1:NCFILE),'; not read.' ELSE PRINT *,' ###### CELGET ERROR : Cell description ', - 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. READ(12,'(A80)',END=2000,IOSTAT=IOS,ERR=2010) STRING IF(LDEBUG)THEN PRINT *,' ++++++ CELGET DEBUG : Dataset header', - ' record follows:' PRINT *,STRING ENDIF * Print member information. WRITE(LUNOUT,'('' Member '',A8,'' was created on '',A8, - '' at '',A8/'' Remarks: '',A29)') - STRING(32:39),STRING(11:18),STRING(23:30),STRING(51:79) * Check the version. READ(12,'(A14)',END=2000,IOSTAT=IOS,ERR=2010) STRING IF(STRING(1:14).NE.' Version : 1')THEN PRINT *,' !!!!!! CELGET WARNING : This member can not'// - ' be read because of a change in format.' CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) RETURN ENDIF *** Execute read operations if a valid name is available. READ(12,'(9X,A)',END=2000,IOSTAT=IOS,ERR=2010) CELLID READ(12,'(9X,I10,7X,A3,I2,8X,L1,7X,L1)', - END=2000,IOSTAT=IOS,ERR=2010) - NWIRE,TYPE,ICTYPE,POLAR,TUBE * Cell-data cannot be used if MXWIRE < NWIRE. IF(NWIRE.GT.MXWIRE)THEN PRINT *,' ###### CELGET ERROR : Program not suitably', - ' compiled to use member ',MEMBER(1:NCMEMB),' on ', - FILE(1:NCFILE),' ; increase MXWIRE to ',NWIRE CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) RETURN ENDIF READ(12,'(7X,6E15.8,/,10X,2E15.8)',END=2000,IOSTAT=IOS,ERR=2010) - XMIN,XMAX,YMIN,YMAX,ZMIN,ZMAX,VMIN,VMAX READ(12,'(A1)',END=2000,IOSTAT=IOS,ERR=2010) DUMMY DO 210 I=1,NWIRE READ(12,'(1X,A1,6E15.8/2X,5E15.8)',END=2000,IOSTAT=IOS,ERR=2010) - WIRTYP(I),X(I),Y(I),V(I),E(I),D(I),W(I),U(I),DENS(I), - B2SIN(I),WMAP(I) 210 CONTINUE READ(12,'(10X,3E15.8)',END=2000,IOSTAT=IOS,ERR=2010) - (DOWN(I),I=1,3) READ(12,'(8X,3E15.8,5X,E15.8)',END=2000,IOSTAT=IOS,ERR=2010) - CORVTA,CORVTB,CORVTC,V0 READ(12,'(11X,2(L1,2E15.8,A1))',END=2000,IOSTAT=IOS,ERR=2010) - (YNPLAN(I),COPLAN(I),VTPLAN(I),PLATYP(I),I=1,2) READ(12,'(11X,2(L1,2E15.8,A1))',END=2000,IOSTAT=IOS,ERR=2010) - (YNPLAN(I),COPLAN(I),VTPLAN(I),PLATYP(I),I=3,4) READ(12,'(21X,2L1,2E15.8)',END=2000,IOSTAT=IOS,ERR=2010) - YNPLAX,YNPLAY,COPLAX,COPLAY READ(12,'(9X,5I10/9X,5I10)',END=2000,IOSTAT=IOS,ERR=2010) - (NPSTR1(I),NPSTR2(I),I=1,5) DO 240 I=1,5 DO 250 J=1,NPSTR1(I) READ(12,'(1X,A1,1X,3E15.8)',END=2000,IOSTAT=IOS,ERR=2010) - PSLAB1(I,J),(PLSTR1(I,J,K),K=1,3) 250 CONTINUE DO 260 J=1,NPSTR2(I) READ(12,'(1X,A1,1X,3E15.8)',END=2000,IOSTAT=IOS,ERR=2010) - PSLAB2(I,J),(PLSTR2(I,J,K),K=1,3) 260 CONTINUE 240 CONTINUE READ(12,'(15X,2(L1,E15.8))',END=2000,IOSTAT=IOS,ERR=2010) - PERX,SX,PERY,SY IF(TYPE(1:1).EQ.'C')READ(12,'(14X,5E15.8,I10)',END=2000, - IOSTAT=IOS,ERR=2010) ZMULT,P1,P2,C1,MODE IF(TYPE.EQ.'D3 '.OR.TYPE.EQ.'D4 ') - READ(12,'(13X,E15.8)',END=2000,IOSTAT=IOS,ERR=2010) KAPPA READ(12,'(17X,I3,5X,I3)',END=2000,IOSTAT=IOS,ERR=2010) - NXMATT,NYMATT IF(NXMATT.GT.MXMATT.OR.NYMATT.GT.MXMATT)THEN PRINT *,' ###### CELGET ERROR : Program not suitably', - ' compiled to use member ',MEMBER(1:NCMEMB),' on ', - FILE(1:NCFILE),' ; increase MXMATT to ', - MAX(NXMATT,NYMATT) CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) RETURN ENDIF DO 220 I=1,NXMATT READ(12,'(1X,5E15.8)',END=2000,IOSTAT=IOS,ERR=2010) - (XMATT(I,J),J=1,5) 220 CONTINUE DO 230 I=1,NYMATT READ(12,'(1X,5E15.8)',END=2000,IOSTAT=IOS,ERR=2010) - (YMATT(I,J),J=1,5) 230 CONTINUE IF(TUBE)READ(12,'(7X,2E15.8,2I10,A1)',END=2000,IOSTAT=IOS, - ERR=2010) COTUBE,VTTUBE,NTUBE,MTUBE,PLATYP(5) READ(12,'(9X,2I10)',END=2000,IOSTAT=IOS,ERR=2010) - NSOLID,ICCURR IF(NSOLID.GT.0)READ(12,'(1X,3I10)',END=2000,IOSTAT=IOS,ERR=2010) - (ISTART(I),ISOLTP(I),ISOLMT(I),I=1,NSOLID) IF(ICCURR.GT.0)READ(12,'(1X,8E15.8)',END=2000,IOSTAT=IOS, - ERR=2010) (CBUF(I),I=1,ICCURR) * Close the file after the operation. CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) IFAIL=0 *** Register the amount of CPU time used for reading. CALL TIMLOG('Reading the cell data from a dataset: ') RETURN *** Handle the I/O error conditions. 2000 CONTINUE PRINT *,' ###### CELGET ERROR : EOF encountered while reading', - ' ',FILE(1:NCFILE),' from unit 12 ; no cell data read.' CALL INPIOS(IOS) CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) RETURN 2010 CONTINUE PRINT *,' ###### CELGET ERROR : Error while reading', - ' ',FILE(1:NCFILE),' from unit 12 ; no cell data read.' CALL INPIOS(IOS) CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) RETURN 2030 CONTINUE PRINT *,' ###### CELGET ERROR : Dataset ',FILE(1:NCFILE),' on', - ' unit 12 cannot be closed ; results not predictable.' CALL INPIOS(IOS) END +DECK,CELINP. SUBROUTINE CELINP(IGET,IFAIL) *----------------------------------------------------------------------- * CELINP - Subroutine reading the cell data from the input file. It * fills the common block wire in part. * VARIABLES : DX : The x-increment in the present row. * DY : The y-increment in the present row. * DV : The voltage increment in the present row. * NX,NY : Number of x,y planes read so far. * IGET : 1 if data comes from dataset, 0 else. * (Last changed on 15/ 1/01.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,PRINTPLOT. +SEQ,CONSTANTS. +SEQ,SOLIDS. CHARACTER*(MXINCH) STRING,FUNCT CHARACTER*10 VARLIS(MXVAR),USER CHARACTER DIR,PLATPR,STRTPR,WIRTPR REAL VAR(MXVAR),RES(8),DOWNXR,DOWNYR,DOWNZR,DNORM, - DR,SR,UR,VR,WR,XR,YR,VARVAL,EPSR,CMIN,CMAX,S,COOR,VOLT, - RADIUS,SMIN,SMAX,SAUX,GAP LOGICAL USE(MXVAR),CCART,CPOLAR,CTUBE,STDSTR,OK,DELETE INTEGER INPCMP,INPTYP,MODVAR(MXVAR),MODRES(8),NVAR,IENTRY,NRES, - IFAIL1,IFAIL2,IFAIL3,IFAIL4,IFAIL5,IFAIL6,IFAIL7,IFAIL, - IFOUND,MODTMP,IVAR,IDTYPE, - INEXT,NR,NFUNCT,NTUBER,NX,NY,IGET,NWORD,I,J,NC EXTERNAL STDSTR,INPCMP,INPTYP +SELF,IF=AST. EXTERNAL ASTCCH +SELF. *** Preset error flag and indicator for file reading. IFAIL=0 IGET=0 *** Initial number of DEFINE variables. NVAR=0 *** Initialise number of planes and coordinate system flags. NX=0 NY=2 CCART=.FALSE. CPOLAR=.FALSE. CTUBE=.FALSE. * Initialise the solids. NSOLID=0 ICCURR=0 * Release the matrix, will be reallocated by SETUP. CALL BOOK('INQUIRE','MATRIX',USER,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! CELINP WARNING : Unable to obtain'// - ' capacitance allocation information ; wire and'// - ' plane based fields probably not possible.' ELSEIF(USER.EQ.'CELL')THEN CALL BOOK('RELEASE','MATRIX','CELL',IFAIL1) ELSEIF(USER.NE.' ')THEN CALL BOOK('RELEASE','MATRIX',USER,IFAIL1) PRINT *,' ------ CELINP MESSAGE : Capacitance matrix'// - ' was not released by ',USER,'; release forced.' ENDIF * Release CELL use of the field map. CALL BOOK('INQUIRE','MAP',USER,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! CELINP WARNING : Unable to obtain'// - ' field map allocation information ; field map'// - ' probably not useable.' ELSEIF(USER.EQ.'CELL')THEN CALL MAPINT CALL BOOK('RELEASE','MAP','CELL',IFAIL1) ELSEIF(USER.EQ.' ')THEN CALL MAPINT ELSE PRINT *,' !!!!!! CELINP WARNING : Field map is in use'// - ' by ',USER,'; field map probably not useable.' ENDIF *** Read a line from input. CALL INPPRM('Cell','NEW-PRINT') 10 CONTINUE CALL INPWRD(NWORD) +SELF,IF=AST. *** Set up ASTCCH as the condition handler. CALL LIB$ESTABLISH(ASTCCH) +SELF. *** Skip this line if there are no words. CALL INPSTR(1,MXWORD,STRING,NC) IF(NWORD.EQ.0)GOTO 10 *** If an '&' is the first letter of the instr, it is the next section. IF(STRING(1:1).EQ.'&')THEN GOTO 50 *** If CELL-ID is a keyword: store CELLID. ELSEIF(INPCMP(1,'C#ELL-#IDENTIFIER').NE.0)THEN IF(NWORD.EQ.1.AND.CELLID.EQ.' ')THEN WRITE(LUNOUT,'(2X/''No cell identification set at'', - '' the moment.''/)') ELSEIF(NWORD.EQ.1)THEN WRITE(LUNOUT,'(2X/''The current cell identification'', - '' is: '',A/)') CELLID ELSE CALL INPSTR(2,2,STRING,NC) IF(NC.GT.40)PRINT *,' !!!!!! CELINP WARNING : The'// - ' cell identifier is truncated to 40 characters.' CELLID=STRING(1:MIN(NC,80)) ENDIF *** Add a new variable to the list, if DEFINE is a keyword. ELSEIF(INPCMP(1,'DEF#INE').NE.0)THEN * Display all variables if no arguments have been provided. IF(NWORD.EQ.1)THEN IF(NVAR.EQ.0)THEN WRITE(LUNOUT,'(/, - '' No variables have been set sofar.''/)') ELSE WRITE(LUNOUT,'(/, - '' Variable name Value'')') DO 13 I=1,NVAR WRITE(LUNOUT,'(2X,A10,5X,F15.5)') VARLIS(I),VAR(I) 13 CONTINUE WRITE(LUNOUT,'('' '')') ENDIF * Display only the value of the variable, if value is omitted. ELSEIF(NWORD.EQ.2)THEN CALL INPSTR(2,2,STRING,NC) IF(NC.LT.1)THEN PRINT *,' !!!!!! CELINP WARNING : A variable'// - ' name must have at least some characters.' ELSE IFOUND=0 DO 18 I=1,NVAR IF(VARLIS(I).EQ.STRING(1:NC))THEN IF(IFOUND.EQ.0)WRITE(LUNOUT,'(/, - '' Variable name Value'')') WRITE(LUNOUT,'(2X,A10,5X,F15.5)') - VARLIS(I),VAR(I) IFOUND=1 ENDIF 18 CONTINUE IF(IFOUND.EQ.1)WRITE(LUNOUT,'('' '')') IF(IFOUND.EQ.0)PRINT *,' !!!!!! CELINP WARNING'// - ' : The variable '//STRING(1:NC)//' has not', - ' yet been defined.' ENDIF * Apparently a true define request, study it in detail. ELSEIF(NWORD.EQ.3)THEN CALL INPSTR(3,3,STRING,NC) CALL ALGPRE(STRING,NC,VARLIS,NVAR,NRES,USE,IENTRY, - IFAIL1) CALL ALGEXE(IENTRY,VAR,MODVAR,NVAR, - RES,MODRES,1,IFAIL2) CALL ALGCLR(IENTRY) IF(IFAIL1+IFAIL2.NE.0)THEN PRINT *,' !!!!!! CELINP WARNING : Variable'// - ' is not stored (syntax errors).' GOTO 10 ENDIF VARVAL=RES(1) MODTMP=MODRES(1) * Extract the name of the variable. CALL INPSTR(2,2,STRING,NC) IF(NC.GT.10)THEN PRINT *,' !!!!!! CELINP WARNING : '//STRING(1:NC) - //' is longer than 10 characters,' PRINT *,' shortened to '// - STRING(1:10)//'.' ENDIF * Check that the name is legal. IFAIL1=0 DO 15 I=1,NC IF(INDEX('+-*/&|<=#>^ ,.:;([{)]}''"`', - STRING(I:I)).NE.0)THEN PRINT *,' !!!!!! CELINP WARNING : '//STRING(1:NC) - //' contains illegal characters; not stored.' GOTO 10 ENDIF 15 CONTINUE IF(INDEX('ABCDEFGHIJKLMNOPQRSTUVWXYZ',STRING(1:1)) - .EQ.0)THEN PRINT *,' !!!!!! CELINP WARNING : The first'// - ' character of '//STRING(1:NC)//' is not'// - ' alphabetic; variable not stored.' GOTO 10 ENDIF * Make sure it is not the reserved loop variable I. IF(STRING(1:NC).EQ.'I'.AND.NC.EQ.1)THEN PRINT *,' !!!!!! CELINP WARNING : I is reserved'// - ' as the ROW loop variable; not added.' GOTO 10 ENDIF * See whether it duplicates an older variable, IVAR=NVAR+1 DO 16 I=1,NVAR IF(STRING(1:10).EQ.VARLIS(I))IVAR=I 16 CONTINUE * check that there is still room for new variables, IF(IVAR+1.GE.MXVAR)THEN PRINT *,' !!!!!! CELINP WARNING : No room for'// - ' new variables ; increase MXVAR.' GOTO 10 ENDIF * and store it along with its value. IF(IVAR.EQ.NVAR+1)THEN NVAR=NVAR+1 VARLIS(NVAR)=STRING(1:10) ELSE IF(LDEBUG)PRINT *,' !!!!!! CELINP WARNING : '// - ' variable '//STRING(1:NC)//' is redefined.' IF(LDEBUG)PRINT *,' '// - ' old value=',VAR(IVAR),' new value=',VARVAL ENDIF VAR(IVAR)=VARVAL MODVAR(IVAR)=MODTMP * Incorrect number of arguments. ELSE PRINT *,' !!!!!! CELINP WARNING : DEFINE needs 2'// - ' arguments ; instruction is ignored.' ENDIF *** Dielectrica. ELSEIF(INPCMP(1,'DIEL#ECTRICUM').NE.0)THEN PRINT *,' !!!!!! CELINP WARNING : Instruction not released.' * Initial values. EPSR=-1.0 CMIN=0.0 CMAX=0.0 DIR=' ' IDTYPE=2 IFAIL1=1 IFAIL2=1 IFAIL3=1 * Loop over the input string. INEXT=2 DO 19 I=2,NWORD IF(I.LT.INEXT)GOTO 19 * The extent and direction of the dielectricum. IF(INPCMP(I,'X-#RANGE')+INPCMP(I,'Y-#RANGE').NE.0)THEN IF(I+2.GT.NWORD)THEN CALL INPMSG(I,'RANGE needs two values. ') ELSEIF((INPTYP(I+1).LE.0.AND. - INPCMP(I+1,'-INF#INITY')+ - INPCMP(I+1,'+INF#INITY')+ - INPCMP(I+1,'INF#INITY').EQ.0).OR. - (INPTYP(I+2).LE.0.AND. - INPCMP(I+2,'-INF#INITY')+ - INPCMP(I+2,'+INF#INITY')+ - INPCMP(I+2,'INF#INITY').EQ.0))THEN CALL INPMSG(I,'Invalid range specification. ') INEXT=I+3 ELSEIF(INPCMP(I+1,'INF#INITY')+ - INPCMP(I+1,'+INF#INITY').NE.0)THEN CALL INPMSG(I+1,'Should be -INF or a number. ') INEXT=I+3 ELSEIF(INPCMP(I+2,'-INF#INITY').NE.0)THEN CALL INPMSG(I+2,'Should be +INF or a number. ') INEXT=I+3 ELSEIF(INPCMP(I+1,'-INF#INITY').NE.0.AND. - INPCMP(I+2,'INF#INITY')+ - INPCMP(I+2,'+INF#INITY').NE.0)THEN CALL INPMSG(I,'Full coverage is not allowed. ') INEXT=I+3 ELSE IF(INPCMP(I+1,'-INF#INITY').NE.0)THEN IFAIL1=0 CALL INPCHK(I+2,2,IFAIL2) IF(IFAIL2.EQ.0)CALL INPRDR(I+2,CMAX,0.0) IDTYPE=-1 ELSEIF(INPCMP(I+2,'INF#INITY')+ - INPCMP(I+2,'+INF#INITY').NE.0)THEN CALL INPCHK(I+1,2,IFAIL1) IF(IFAIL1.EQ.0)CALL INPRDR(I+1,CMIN,0.0) IFAIL2=0 IDTYPE=+1 ELSE CALL INPCHK(I+1,2,IFAIL1) IF(IFAIL1.EQ.0)CALL INPRDR(I+1,CMIN,0.0) CALL INPCHK(I+2,2,IFAIL2) IF(IFAIL2.EQ.0)CALL INPRDR(I+2,CMAX,0.0) IDTYPE=0 ENDIF IF(IDTYPE.EQ.0.AND.CMIN.EQ.CMAX)THEN CALL INPMSG(I+1, - 'Zero range not permitted. ') CALL INPMSG(I+2, - 'See the preceding message. ') ENDIF IF(INPCMP(I,'X-#RANGE').NE.0)THEN DIR='X' ELSEIF(INPCMP(I,'Y-#RANGE').NE.0)THEN DIR='Y' ENDIF INEXT=I+3 ENDIF * The dielectric constant. ELSEIF(INPCMP(I,'EPS#ILON').NE.0)THEN IF(I+1.GT.NWORD.OR.INPTYP(I+1).LE.0)THEN CALL INPMSG(I,'Epsilon must be specified. ') ELSE CALL INPCHK(I+1,2,IFAIL3) CALL INPRDR(I+1,EPSR,-1.0) INEXT=I+2 IF(EPSR.LE.0.0)CALL INPMSG(I, - 'Epsilon must be positive. ') ENDIF * Anything else: not valid. ELSE CALL INPMSG(I,'Unrecognised keyword. ') ENDIF 19 CONTINUE CALL INPERR * Store the dielectricum. IF(DIR.EQ.' '.OR.IDTYPE.EQ.2.OR.(IDTYPE.EQ.0.AND. - CMIN.EQ.CMAX).OR.EPSR.LE.0.0.OR. - IFAIL1.NE.0.OR.IFAIL2.NE.0.OR.IFAIL3.NE.0)THEN PRINT *,' !!!!!! CELINP WARNING : The DIELECTRICUM'// - ' statement is either invalid or incomplete:' PRINT *,' It is skipped,'// - ' check the documentation for proper syntax.' ELSEIF((NXMATT.GE.MXMATT.AND.DIR.EQ.'X').OR. - (NYMATT.GE.MXMATT.AND.DIR.EQ.'Y'))THEN PRINT *,' !!!!!! CELINP WARNING : No room to store'// - ' further dielectrica ; increase MXMATT.' ELSEIF(DIR.EQ.'X')THEN NXMATT=NXMATT+1 IF(IDTYPE.EQ.+1)THEN XMATT(NXMATT,1)=CMIN XMATT(NXMATT,2)=0.0 XMATT(NXMATT,3)=0 XMATT(NXMATT,4)=1 ELSEIF(IDTYPE.EQ.0)THEN XMATT(NXMATT,1)=MIN(CMIN,CMAX) XMATT(NXMATT,2)=MAX(CMIN,CMAX) XMATT(NXMATT,3)=0 XMATT(NXMATT,4)=0 ELSEIF(IDTYPE.EQ.-1)THEN XMATT(NXMATT,1)=0.0 XMATT(NXMATT,2)=CMAX XMATT(NXMATT,3)=1 XMATT(NXMATT,4)=0 ENDIF XMATT(NXMATT,5)=EPSR ELSEIF(DIR.EQ.'Y')THEN NYMATT=NYMATT+1 IF(IDTYPE.EQ.+1)THEN YMATT(NYMATT,1)=CMIN YMATT(NYMATT,2)=0.0 YMATT(NYMATT,3)=0 YMATT(NYMATT,4)=1 ELSEIF(IDTYPE.EQ.0)THEN YMATT(NYMATT,1)=MIN(CMIN,CMAX) YMATT(NYMATT,2)=MAX(CMIN,CMAX) YMATT(NYMATT,3)=0 YMATT(NYMATT,4)=0 ELSEIF(IDTYPE.EQ.-1)THEN YMATT(NYMATT,1)=0.0 YMATT(NYMATT,2)=CMAX YMATT(NYMATT,3)=1 YMATT(NYMATT,4)=0 ENDIF YMATT(NYMATT,5)=EPSR ENDIF *** Read a field map. ELSEIF(INPCMP(1,'FIELD-MAP')+ - INPCMP(1,'READ-FIELD-MAP').NE.0)THEN * Obtain the field map for main-field use. CALL BOOK('INQUIRE','MAP',USER,IFAIL1) IF(NWORD.EQ.1)THEN IFAIL1=0 ELSEIF(USER.EQ.'OPTIMISE')THEN PRINT *,' ------ CELINP MESSAGE : Deleting the'// - ' background field map to make space for the'// - ' main field map.' CALL MAPINT CALL BOOK('RELEASE','MAP','OPTIMISE',IFAIL2) IF(LBGFMP)THEN PRINT *,' ------ CELINP MESSAGE : Background'// - ' field deleted because of dependence on'// - ' the field map.' IF(IENBGF.NE.0)CALL ALGCLR(IENBGF) IENBGF=0 ENDIF CALL BOOK('BOOK','MAP','CELL',IFAIL3) IF(IFAIL2.EQ.0.AND.IFAIL3.EQ.0)THEN IFAIL1=0 ELSE PRINT *,' !!!!!! CELINP WARNING : Change of'// - ' field map allocation failed; field'// - ' map not useable.' IFAIL1=1 ENDIF ELSEIF(USER.EQ.' ')THEN CALL BOOK('BOOK','MAP','CELL',IFAIL1) ELSE IFAIL1=0 ENDIF IF(IFAIL1.NE.0)PRINT *,' !!!!!! CELINP WARNING : Unable'// - ' to obtain control of the field map for use as'// - ' main field.' * Read the field map. IF(IFAIL1.EQ.0)THEN IF(INPCMP(1,'FIELD-MAP').NE.0)THEN CALL MAPREA(IFAIL1) ELSE CALL MAPFMF(IFAIL1) ENDIF ENDIF * Check the error flag from map reading. IF(IFAIL1.EQ.0.AND.NWORD.GT.1)THEN IF(CPOLAR)THEN PRINT *,' !!!!!! CELINP WARNING : Description'// - ' started in polar coordinates; field'// - ' map ignored.' GOTO 10 ENDIF IF(.NOT.CTUBE)CCART=.TRUE. IF(NWIRE.NE.0)PRINT *,' ------ CELINP MESSAGE :'// - ' Deleted the wires when reading field map.' IF(NX.NE.0.OR.NY.NE.2)PRINT *,' ------ CELINP'// - ' MESSAGE : Deleted the planes when reading'// - ' the field map.' IF(NXMATT.NE.0.OR.NYMATT.NE.0) - PRINT *,' ------ CELINP MESSAGE : Deleted'// - ' the dielectrics when reading the field map.' NWIRE=0 NX=0 NY=2 YNPLAN(1)=.FALSE. YNPLAN(2)=.FALSE. YNPLAN(3)=.FALSE. YNPLAN(4)=.FALSE. NXMATT=0 NYMATT=0 ELSEIF(NWORD.GT.1)THEN PRINT *,' !!!!!! CELINP WARNING : Reading a field'// - ' map failed.' ENDIF *** Write the field map in binary format. ELSEIF(INPCMP(1,'SAVE-F#IELD-#MAP').NE.0)THEN CALL MAPFMS *** Read the cell from dataset, if GET is a keyword ELSEIF(INPCMP(1,'G#ET').NE.0)THEN CALL CELGET(IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! CELINP WARNING : New cell data must'// - ' be entered.' IGET=0 NX=0 NY=2 CCART=.FALSE. CPOLAR=.FALSE. CTUBE=.FALSE. CALL CELINT NSOLID=0 ICCURR=0 CALL MAPINT IFAIL=0 ELSE IGET=1 IF(POLAR)THEN CPOLAR=.TRUE. CCART=.FALSE. CTUBE=.FALSE. ELSEIF(TUBE)THEN CPOLAR=.FALSE. CCART=.FALSE. CTUBE=.TRUE. ELSE CPOLAR=.FALSE. CCART=.TRUE. CTUBE=.FALSE. ENDIF ENDIF *** Gravity orientation. ELSEIF(INPCMP(1,'GRAV#ITY').NE.0)THEN IF(NWORD.EQ.1)THEN WRITE(LUNOUT,'('' Gravity works along the axis ('', - F6.3,'','',F6.3,'','',F6.3,'') [g].'')') - (DOWN(I),I=1,3) ELSEIF(NWORD.NE.4)THEN PRINT *,' !!!!!! CELINP WARNING : The GRAVITY'// - ' command takes 3 arguments; ignored.' ELSE CALL INPCHK(2,2,IFAIL1) CALL INPCHK(3,2,IFAIL2) CALL INPCHK(4,2,IFAIL3) CALL INPRDR(2,DOWNXR,DOWN(1)) CALL INPRDR(3,DOWNYR,DOWN(2)) CALL INPRDR(4,DOWNZR,DOWN(3)) DNORM=SQRT(DOWNXR**2+DOWNYR**2+DOWNZR**2) IF(DNORM.GT.0)THEN DOWN(1)=DOWNXR/DNORM DOWN(2)=DOWNYR/DNORM DOWN(3)=DOWNZR/DNORM ELSE PRINT *,' !!!!!! CELINP WARNING : The gravity'// - ' vector has 0 norm ; ignored.' ENDIF ENDIF *** If OPTION is a keyword, find out what the options are, ELSEIF(INPCMP(1,'OPT#IONS').NE.0)THEN IF(NWORD.EQ.1)WRITE(LUNOUT,'(/ - '' LOCAL OPTIONS CURRENTLY IN EFFECT:''// - '' Plotting the layout of the cell (LAYOUT): '', - L1/ - '' Printing a cell summary table (CELL-PRINT): '', - L1/ - '' Plot wires by markers (WIRE-MARKERS): '', - L1/ - '' Layout plotted isometrically (ISOMETRIC): '', - L1/ - '' Check charge calculation (CHARGE-CHECK): '', - L1)') LCELPL,LCELPR,LWRMRK,LISOCL,LCHGCH DO 11 I=2,NWORD * check the plotting-of-layout option, IF(INPCMP(I,'NOLAY#OUT').NE.0)THEN LCELPL=.FALSE. ELSEIF(INPCMP(I,'LAY#OUT').NE.0)THEN LCELPL=.TRUE. * check the printing-of-layout option, ELSEIF(INPCMP(I,'NOC#ELL-PR#INT').NE.0)THEN LCELPR=.FALSE. ELSEIF(INPCMP(I,'C#ELL-PR#INT').NE.0)THEN LCELPR=.TRUE. * check the wire markers option, ELSEIF(INPCMP(I,'NOW#IRE-M#ARKERS').NE.0)THEN LWRMRK=.FALSE. ELSEIF(INPCMP(I,'W#IRE-M#ARKERS').NE.0)THEN LWRMRK=.TRUE. * check the isometric option, ELSEIF(INPCMP(I,'NOTISO#METRIC').NE.0)THEN LISOCL=.FALSE. ELSEIF(INPCMP(I,'ISO#METRIC').NE.0)THEN LISOCL=.TRUE. * check charge calculation. ELSEIF(INPCMP(I,'NOCH#ARGE-#CHECK').NE.0)THEN LCHGCH=.FALSE. ELSEIF(INPCMP(I,'CH#ARGE-#CHECK').NE.0)THEN LCHGCH=.TRUE. * option not known. ELSE CALL INPMSG(I,'The option is not known. ') ENDIF 11 CONTINUE CALL INPERR *** If PERIOD is a keyword: ELSEIF(INPCMP(1,'PER#IODICITY').NE.0)THEN * check the syntax, IF(NWORD.NE.3)THEN PRINT *,' !!!!!! CELINP WARNING : PERIOD requires'// - ' 2 arguments (direction and length) ; ignored.' GOTO 10 ENDIF * Try to read the periodicity. CALL INPCHK(3,2,IFAIL1) CALL INPRDR(3,S,-1.0) * Check that the periodicity direction makes sense. IF(INPCMP(2,'X')+INPCMP(2,'Y')+INPCMP(2,'PHI').EQ.0) - CALL INPMSG(2,'Should be either X, Y or PHI. ') IF(S.LE.0.0)CALL INPMSG(3,'Periods should be > than 0. ') * Dump error messages. CALL INPERR * No further processing in case of invalid periodicities. IF((INPCMP(2,'X')+INPCMP(2,'Y')+ - INPCMP(2,'PHI').EQ.0).OR.IFAIL1.NE.0.OR.S.LE.0.0)THEN PRINT *,' !!!!!! CELINP WARNING : PERIOD statement'// - ' ignored because of syntax or argument errors.' * Make sure no mixed coordinates are used. ELSEIF((INPCMP(2,'X')+INPCMP(2,'Y').NE.0.AND. - (CTUBE.OR.CPOLAR)).OR. - (INPCMP(2,'PHI')+INPCMP(2,'R').NE.0.AND.CCART))THEN PRINT *,' !!!!!! CELINP WARNING : Use of mixed'// - ' coordinates not permitted ; PERIOD is ignored.' * Assign the periodicity to SX or to SY. ELSE * If it is a x or a r periodicity: IF(INPCMP(2,'X')+INPCMP(2,'R').NE.0)THEN IF(PERX)PRINT *,' !!!!!! CELINP WARNING :'// - ' previous x period (',SX,') replaced.' PERX=.TRUE. IF(INPCMP(2,'X').NE.0)THEN SX=S CCART=.TRUE. ELSE SX=LOG(S) IF(.NOT.(CTUBE.OR.CPOLAR))CPOLAR=.TRUE. ENDIF * if it is a y or a phi periodicity: ELSE IF(INPCMP(2,'PHI').NE.0.AND. - ABS(360.0-S*ANINT(360.0/S)).GT.1.0E-4)THEN PRINT *,' !!!!!! CELINP WARNING : Phi'// - ' periods must divide 360 ; ignored.' ELSE IF(PERY.AND.CCART)PRINT *,' !!!!!! CELINP'// - ' WARNING : The previous y period (', - SY,') is replaced.' IF(PERY.AND.CPOLAR)PRINT *,' !!!!!! CELINP'// - ' WARNING : The previous phi period (', - SY*180.0/PI,') is replaced.' PERY=.TRUE. IF(INPCMP(2,'Y').NE.0)THEN SY=S CCART=.TRUE. ELSE SY=PI*S/180.0 MTUBE=NINT(360.0/S) IF(.NOT.(CTUBE.OR.CPOLAR))CPOLAR=.TRUE. ENDIF ENDIF ENDIF * reset the get condition. IGET=0 ENDIF *** Define a plane if PLANE is a keyword. ELSEIF(INPCMP(1,'PL#ANE').NE.0)THEN ** Ensure that planes are not entered in a tube geometry. IF(CTUBE)THEN PRINT *,' !!!!!! CELINP WARNING : Planes can not'// - ' be used with a TUBE; plane ignored.' OK=.FALSE. GOTO 10 ENDIF ** Determine the direction of the plane. DIR=' ' INEXT=2 DO 100 I=2,NWORD IF(I.LT.INEXT)GOTO 100 IF(INPCMP(I,'X')+INPCMP(I,'R').NE.0)THEN IF(INPCMP(I,'X').NE.0)DIR='X' IF(INPCMP(I,'R').NE.0)DIR='R' INEXT=I+2 ELSEIF(INPCMP(I,'Y')+INPCMP(I,'PHI').NE.0)THEN IF(INPCMP(I,'Y').NE.0)DIR='Y' IF(INPCMP(I,'PHI').NE.0)DIR='P' INEXT=I+2 ELSEIF(INPCMP(I,'V#OLTAGE')+INPCMP(I,'LAB#EL')+ - INPCMP(I,'GAP').NE.0)THEN INEXT=I+2 ELSEIF(INPCMP(I,'X-STRIP')+INPCMP(I,'Y-STRIP')+ - INPCMP(I,'R-STRIP')+INPCMP(I,'PHI-STRIP')+ - INPCMP(I,'Z-STRIP').NE.0)THEN INEXT=I+3 ENDIF 100 CONTINUE ** Make sure a direction is indicated. IF(DIR.EQ.' ')THEN PRINT *,' !!!!!! CELINP WARNING : Direction of the'// - ' plane not indicated; plane ignored.' OK=.FALSE. GOTO 10 * Make sure we can store this plane. ELSEIF((DIR.EQ.'X'.OR.DIR.EQ.'R').AND.NX.GE.2)THEN PRINT *,' !!!!!! CELINP WARNING : At most 2 planes'// - ' at constant x or r permitted; plane ignored.' OK=.FALSE. GOTO 10 ELSEIF((DIR.EQ.'Y'.OR.DIR.EQ.'P').AND.NY.GE.4)THEN PRINT *,' !!!!!! CELINP WARNING : At most 2 planes'// - ' at constant y or phi permitted; plane ignored.' OK=.FALSE. GOTO 10 * Make sure no mixed coordinates are used. ELSEIF(((DIR.EQ.'X'.OR.DIR.EQ.'Y').AND.CPOLAR).OR. - ((DIR.EQ.'R'.OR.DIR.EQ.'P').AND.CCART))THEN PRINT *,' !!!!!! CELINP WARNING : Use of mixed'// - ' coordinates not permitted ; plane ignored.' OK=.FALSE. GOTO 10 ENDIF ** We now start modifying the cell. IGET=0 ** Maintain a flag to be able to delete faulty planes. DELETE=.FALSE. * Set coordinate system flags. IF(DIR.EQ.'X'.OR.DIR.EQ.'R')THEN NX=NX+1 YNPLAN(NX)=.TRUE. NPSTR1(NX)=0 NPSTR2(NX)=0 ELSEIF(DIR.EQ.'Y'.OR.DIR.EQ.'P')THEN NY=NY+1 YNPLAN(NY)=.TRUE. NPSTR1(NY)=0 NPSTR2(NY)=0 ENDIF IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ CELINP DEBUG :'', - '' Plane direction: '',A,'' NX, NY='',2I2)') DIR, - NX,NY ** Read command in detail. INEXT=2 PLATPR='?' COOR=0.0 VOLT=0.0 DO 110 I=2,NWORD IF(I.LT.INEXT)GOTO 110 ** Plane at constant x or constant r, accept at most 2 planes. IF(INPCMP(I,'X')+INPCMP(I,'R').NE.0)THEN * Read coordinate. CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,COOR,0.0) * Reject syntax errors. IF(IFAIL1.NE.0)THEN DELETE=.TRUE. OK=.FALSE. * Make sure a radial plane has r>0. ELSEIF(COOR.LE.0.AND.DIR.EQ.'R')THEN PRINT *,' !!!!!! CELINP WARNING : The radius of'// - ' constant r planes must be larger than'// - ' zero; plane ignored.' DELETE=.TRUE. OK=.FALSE. ENDIF * Next word. INEXT=I+2 ** Plane at constant y or constant phi, accept at most 2 planes. ELSEIF(INPCMP(I,'Y')+INPCMP(I,'PHI').NE.0)THEN * Read coordinate. CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,COOR,0.0) * Reject syntax errors. IF(IFAIL1.NE.0)THEN OK=.FALSE. DELETE=.TRUE. ENDIF * Next word. INEXT=I+2 ** Voltage definition, ELSEIF(INPCMP(I,'V#OLTAGE').NE.0)THEN * Read voltage. CALL INPCHK(I+1,2,IFAIL2) CALL INPRDR(I+1,VOLT,0.0) * Reject syntax errors. IF(IFAIL2.NE.0)THEN OK=.FALSE. DELETE=.TRUE. ENDIF * Next word. INEXT=I+2 ** Global plane label. ELSEIF(INPCMP(I,'LAB#EL').NE.0)THEN * Read label. CALL INPSTR(I+1,I+1,STRING,NC) PLATPR=STRING(1:1) * Reject syntax errors. IF(INDEX('ABCDEFGHIJKLMNOPQRSTUVWXYZ',PLATPR).EQ. - 0)THEN CALL INPMSG(I+1,'The label must be a letter.') OK=.FALSE. DELETE=.TRUE. ENDIF * Next word. INEXT=I+2 ** Strips. ELSEIF(INPCMP(I,'X-STRIP')+INPCMP(I,'Y-STRIP')+ - INPCMP(I,'R-STRIP')+INPCMP(I,'PHI-STRIP')+ - INPCMP(I,'Z-STRIP').NE.0)THEN * Ensure there is no coordinate system conflict. IF((INPCMP(I,'X-STRIP')+INPCMP(I,'Y-STRIP').NE.0.AND. - (DIR.EQ.'R'.OR.DIR.EQ.'P')).OR. - (INPCMP(I,'R-STRIP')+ - INPCMP(I,'PHI-STRIP').NE.0.AND. - (DIR.EQ.'X'.OR.DIR.EQ.'Y')))THEN PRINT *,' !!!!!! CELINP WARNING : Use of mixed'// - ' coordinates not permitted ; strip ignored.' OK=.FALSE. DELETE=.TRUE. ENDIF * Initial values. SMIN=0.0 SMAX=0.0 GAP=-1.0 STRTPR='?' * Read range. CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,SMIN,0.0) CALL INPCHK(I+2,2,IFAIL2) CALL INPRDR(I+2,SMAX,0.0) * Coordinate transformations for polar coordinates. IF(INPCMP(I,'PHI-STRIP').NE.0)THEN SMIN=PI*SMIN/180 SMAX=PI*SMAX/180 SMIN=MOD(SMIN,2*PI) IF(SMIN.GT.PI)SMIN=SMIN-2*PI IF(SMIN.LT.-PI)SMIN=SMIN+2*PI SMAX=MOD(SMAX,2*PI) IF(SMAX.GT.PI)SMAX=SMAX-2*PI IF(SMAX.LT.-PI)SMAX=SMAX+2*PI ELSEIF(INPCMP(I,'R-STRIP').NE.0)THEN IF(SMIN.LE.0.OR.SMAX.LE.0)THEN CALL INPMSG(I+1,'Strip must be in r > 0.') CALL INPMSG(I+2,'Strip must be in r > 0.') OK=.FALSE. DELETE=.TRUE. SMIN=1 SMAX=2 ELSE SMIN=LOG(SMIN) SMAX=LOG(SMAX) ENDIF ENDIF * Order the coordinates if required. IF(ABS(SMIN-SMAX).LT.1E-4)THEN CALL INPMSG(I+1,'Zero range not permitted.') CALL INPMSG(I+2,'Zero range not permitted.') OK=.FALSE. DELETE=.TRUE. SMIN=1 SMAX=1 ELSEIF(SMIN.GT.SMAX)THEN SAUX=SMIN SMIN=SMAX SMAX=SAUX ENDIF * Make sure strips and plane are perpendicular. IF((DIR.EQ.'X'.AND.INPCMP(I,'X-STRIP').NE.0).OR. - (DIR.EQ.'R'.AND.INPCMP(I,'R-STRIP').NE.0).OR. - (DIR.EQ.'Y'.AND.INPCMP(I,'Y-STRIP').NE.0).OR. - (DIR.EQ.'P'.AND.INPCMP(I,'PHI-STRIP').NE.0))THEN CALL INPMSG(I,'Same direction strip and plane') OK=.FALSE. DELETE=.TRUE. * Reject syntax errors. ELSEIF(IFAIL1.NE.0.OR.IFAIL2.NE.0)THEN OK=.FALSE. DELETE=.TRUE. ENDIF * Next word. INEXT=I+3 ** Search for optional arguments, first initialise them. DO 120 J=I+3,NWORD IF(J.LT.INEXT)GOTO 120 * Gap width. IF(INPCMP(J,'GAP').NE.0)THEN CALL INPCHK(J+1,2,IFAIL2) CALL INPRDR(J+1,GAP,0.0) IF(IFAIL2.NE.0)THEN OK=.FALSE. DELETE=.TRUE. GAP=-1.0 ELSEIF(GAP.LE.0)THEN CALL INPMSG(J+1,'Gap must be > 0') OK=.FALSE. DELETE=.TRUE. GAP=-1.0 ENDIF INEXT=J+2 * Strip label. ELSEIF(INPCMP(J,'LAB#EL').NE.0)THEN CALL INPSTR(J+1,J+1,STRING,NC) STRTPR=STRING(1:1) IF(INDEX('ABCDEFGHIJKLMNOPQRSTUVWXYZ',STRTPR).EQ. - 0)THEN CALL INPMSG(J+1, - 'The label must be a letter.') OK=.FALSE. DELETE=.TRUE. STRTPR='?' ENDIF INEXT=J+2 * Otherwise, leave the loop. ELSE GOTO 130 ENDIF 120 CONTINUE 130 CONTINUE ** Store the strip. IF(INPCMP(I,'R-STRIP')+INPCMP(I,'PHI-STRIP')+ - INPCMP(I,'X-STRIP')+INPCMP(I,'Y-STRIP').NE.0)THEN IF(DIR.EQ.'X'.OR.DIR.EQ.'R')THEN IF(NPSTR1(NX).GE.MXPSTR)THEN CALL INPMSG(I,'Maximum number of'// - ' strips reached.') OK=.FALSE. DELETE=.TRUE. ELSE NPSTR1(NX)=NPSTR1(NX)+1 PLSTR1(NX,NPSTR1(NX),1)=SMIN PLSTR1(NX,NPSTR1(NX),2)=SMAX PLSTR1(NX,NPSTR1(NX),3)=GAP PSLAB1(NX,NPSTR1(NX))=STRTPR ENDIF ELSE IF(NPSTR1(NY).GE.MXPSTR)THEN CALL INPMSG(I,'Maximum number of'// - ' strips reached.') OK=.FALSE. DELETE=.TRUE. ELSE NPSTR1(NY)=NPSTR1(NY)+1 PLSTR1(NY,NPSTR1(NY),1)=SMIN PLSTR1(NY,NPSTR1(NY),2)=SMAX PLSTR1(NY,NPSTR1(NY),3)=GAP PSLAB1(NY,NPSTR1(NY))=STRTPR ENDIF ENDIF ELSEIF(INPCMP(I,'Z-STRIP').NE.0)THEN IF(DIR.EQ.'X'.OR.DIR.EQ.'R')THEN IF(NPSTR2(NX).GE.MXPSTR)THEN CALL INPMSG(I,'Maximum number of'// - ' strips reached.') OK=.FALSE. DELETE=.TRUE. ELSE NPSTR2(NX)=NPSTR2(NX)+1 PLSTR2(NX,NPSTR2(NX),1)=SMIN PLSTR2(NX,NPSTR2(NX),2)=SMAX PLSTR2(NX,NPSTR2(NX),3)=GAP PSLAB2(NX,NPSTR2(NX))=STRTPR ENDIF ELSE IF(NPSTR2(NY).GE.MXPSTR)THEN CALL INPMSG(I,'Maximum number of'// - ' strips reached.') OK=.FALSE. DELETE=.TRUE. ELSE NPSTR2(NY)=NPSTR2(NY)+1 PLSTR2(NY,NPSTR2(NY),1)=SMIN PLSTR2(NY,NPSTR2(NY),2)=SMAX PLSTR2(NY,NPSTR2(NY),3)=GAP PSLAB2(NY,NPSTR2(NY))=STRTPR ENDIF ENDIF ENDIF * Unknown field. ELSE CALL INPMSG(I,'Not a known parameter. ') CALL INPMSG(I+1,'See the previous message. ') ENDIF 110 CONTINUE ** Print the errors generated so far. CALL INPERR * Delete in case of errors. IF(DELETE)THEN PRINT *,' !!!!!! CELINP WARNING : Plane ignored'// - ' because of syntax or value errors.' IF(DIR.EQ.'X'.OR.DIR.EQ.'R')THEN YNPLAN(NX)=.FALSE. NPSTR1(NX)=0 NPSTR2(NX)=0 NX=NX-1 ELSE YNPLAN(NY)=.FALSE. NPSTR1(NY)=0 NPSTR2(NY)=0 NY=NY-1 ENDIF * Skip the rest. GOTO 10 ENDIF ** Store the data. IF(DIR.EQ.'Y')THEN CCART=.TRUE. COPLAN(NY)=COOR VTPLAN(NY)=VOLT PLATYP(NY)=PLATPR ELSEIF(DIR.EQ.'P')THEN CPOLAR=.TRUE. COPLAN(NY)=PI*COOR/180.0 VTPLAN(NY)=VOLT PLATYP(NY)=PLATPR ELSEIF(DIR.EQ.'X')THEN CCART=.TRUE. COPLAN(NX)=COOR VTPLAN(NX)=VOLT PLATYP(NX)=PLATPR ELSEIF(DIR.EQ.'R')THEN CPOLAR=.TRUE. COPLAN(NX)=LOG(COOR) VTPLAN(NX)=VOLT PLATYP(NX)=PLATPR ELSE PRINT *,' ###### CELINP ERROR : Direction not'// - ' recognised; program error - please report.' OK=.FALSE. GOTO 10 ENDIF *** Provide a reset. ELSEIF(INPCMP(1,'RES#ET').NE.0)THEN DO 12 I=2,NWORD * Coordinate system. IF(INPCMP(I,'COOR#DINATES').NE.0)THEN CCART=.FALSE. CPOLAR=.FALSE. CTUBE=.FALSE. * Local variables. ELSEIF(INPCMP(I,'DEF#INITIONS').NE.0)THEN NVAR=0 * Dielectrica. ELSEIF(INPCMP(I,'DIEL#ECTRICA').NE.0)THEN NXMATT=0 NYMATT=0 * Field map. ELSEIF(INPCMP(I,'F#IELD-M#AP').NE.0)THEN CALL MAPINT * Solids. ELSEIF(INPCMP(I,'SOL#IDS').NE.0)THEN NSOLID=0 ICCURR=0 * Periodicities. ELSEIF(INPCMP(I,'PER#IODICITIES').NE.0)THEN PERX=.FALSE. PERY=.FALSE. PERZ=.FALSE. PERMX=.FALSE. PERMY=.FALSE. PERMZ=.FALSE. PERAX=.FALSE. PERAY=.FALSE. PERAZ=.FALSE. PERRX=.FALSE. PERRY=.FALSE. PERRZ=.FALSE. * Planes. ELSEIF(INPCMP(I,'PL#ANES').NE.0)THEN NX=0 NY=2 YNPLAN(1)=.FALSE. YNPLAN(2)=.FALSE. YNPLAN(3)=.FALSE. YNPLAN(4)=.FALSE. * Tube. ELSEIF(INPCMP(I,'TUB#E').NE.0)THEN CTUBE=.FALSE. * Wires. ELSEIF(INPCMP(I,'ROW#S')+INPCMP(I,'WIR#ES').NE.0)THEN NWIRE=0 * Something unknown. ELSE CALL INPMSG(I,'Is not known, can not be reset') ENDIF 12 CONTINUE * Everything. IF(NWORD.EQ.1)THEN CALL CELINT NX=0 NY=2 CCART=.FALSE. CPOLAR=.FALSE. CTUBE=.FALSE. CALL MAPINT NSOLID=0 ICCURR=0 ENDIF * Dump error messages. CALL INPERR * Reset error flag. IFAIL=0 * Reset data origin flag. IGET=0 *** If ROW is a keyword, read the next few lines as rows. ELSEIF(INPCMP(1,'RO#WS')+INPCMP(1,'WIR#ES').NE.0)THEN * First find out whether they are in a polar or in a Cartesian system. IF(NWORD.EQ.1)THEN IF(.NOT.(CPOLAR.OR.CCART.OR.CTUBE))CCART=.TRUE. ELSEIF(NWORD.EQ.2)THEN IF(INPCMP(2,'CART#ESIAN').NE.0)THEN IF(CPOLAR.OR.CTUBE)THEN PRINT *,' !!!!!! CELINP WARNING : Mixed'// - ' coordinates not permitted ;'// - ' polar coordinates assumed.' ELSE CCART=.TRUE. ENDIF ELSEIF(INPCMP(2,'POL#AR').NE.0)THEN IF(CCART)THEN PRINT *,' !!!!!! CELINP WARNING : Mixed'// - ' coordinates not permitted ;'// - ' Cartesian coordinates assumed.' ELSE CPOLAR=.TRUE. CTUBE=.FALSE. ENDIF ELSEIF(INPCMP(2,'TUBE').NE.0)THEN IF(CCART)THEN PRINT *,' !!!!!! CELINP WARNING : Mixed'// - ' coordinates not permitted ;'// - ' Cartesian coordinates assumed.' ELSE CTUBE=.TRUE. CPOLAR=.FALSE. ENDIF ELSE CALL INPSTR(2,2,STRING,NC) PRINT *,' !!!!!! CELINP WARNING : '//STRING(1:NC) - //' is not known as a coordinate system'// - ' to ROWS ; it is ignored.' IF(.NOT.(CPOLAR.OR.CCART))CCART=.TRUE. ENDIF ELSE PRINT *,' !!!!!! CELINP WARNING : ROWS has at most'// - ' one argument ; arguments ignored.' IF(.NOT.(CPOLAR.OR.CCART.OR.CTUBE))CCART=.TRUE. ENDIF * Add the loop variable to the list. IF(NVAR+1.GT.MXVAR)THEN PRINT *,' !!!!!! CELINP WARNING : Variable stack'// - ' exhausted, no room for a loop variable.' ELSE NVAR=NVAR+1 VARLIS(NVAR)='I' VAR(NVAR)=0.0 ENDIF * Print a prompt for interactive mode reading of cell data IF(STDSTR('INPUT'))PRINT *,' ====== CELINP INPUT :'// - ' Please enter the rows, terminate with a blank line.' CALL INPPRM('Rows','ADD-NOPRINT') * Initialise number of wires. NWIRE=0 20 CONTINUE * Input a line and make some preliminary checks. CALL INPWRD(NWORD) CALL INPSTR(1,1,STRING,NC) IF(STRING(1:1).EQ.'&')THEN PRINT *,' !!!!!! CELINP WARNING : The section can'// - ' not be left at this point ; line ignored.' GOTO 20 ENDIF IF(NWORD.GT.9)PRINT *,' !!!!!! CELINP WARNING : At most 9'// - ' items expected on a wire line ; excess is ignored.' IF(NWORD.EQ.0)GOTO 60 * Read wire codes, checking that they are letters, WIRTPR=STRING(1:1) IF(INDEX('ABCDEFGHIJKLMNOPQRSTUVWXYZ',WIRTPR).EQ.0)THEN CALL INPMSG(1,'The wire code must be a letter') IFAIL1=1 ELSE IFAIL1=0 ENDIF * Read n which may be symbolic but should not contain a loop-variable. NFUNCT=0 IF(NWORD.GE.2.AND.INPCMP(2,'*').EQ.0)THEN CALL INPSTR(2,2,STRING,NC) FUNCT(1:NC)=STRING(1:NC) NFUNCT=NC ELSE FUNCT(1:3)='1.0' NFUNCT=3 ENDIF CALL ALGPRE(FUNCT,NFUNCT,VARLIS,NVAR,NRES,USE,IENTRY,IFAIL4) IF(USE(NVAR).AND.IFAIL4.EQ.0)THEN CALL INPMSG(2,'Invalid use of loop variable I') IFAIL4=1 IFAIL5=1 RES(1)=0 ELSEIF(NRES.NE.1.AND.IFAIL4.EQ.0)THEN CALL INPMSG(2,'Returns more than 1 result. ') IFAIL4=1 IFAIL5=1 RES(1)=0 ELSEIF(IFAIL4.EQ.0)THEN CALL ALGEXE(IENTRY,VAR,MODVAR,NVAR,RES,MODRES,1,IFAIL5) ELSE IFAIL5=1 ENDIF NR=NINT(RES(1)) CALL ALGCLR(IENTRY) * Check that the number of wires in the row is positive and integer. IF(NR.LE.0.AND.IFAIL4.EQ.0)THEN CALL INPMSG(2,'Number of wires should be > 0.') IFAIL2=1 ELSEIF(ABS(NR-RES(1)).GT.1.0E-3.AND.IFAIL4.EQ.0)THEN CALL INPMSG(2,'Does not evaluate to integer. ') IFAIL2=1 ELSE IFAIL2=0 ENDIF * Translate d, x, y, V, W, l, s - symbolic, loop variable permitted. NFUNCT=0 DO 21 I=3,9 IF(I.EQ.9.AND.INPCMP(I,'CU-BE#RYLLIUM')+ - INPCMP(I,'C#OPPER-BE#RYLLIUM')+ - INPCMP(I,'BE#RYLLIUM-#CU')+ - INPCMP(I,'BE#RYLLIUM-#COPPER').NE.0)THEN FUNCT(NFUNCT+1:NFUNCT+4)=',8.7' NFUNCT=NFUNCT+4 ELSEIF(I.EQ.9.AND.INPCMP(I,'W')+ - INPCMP(I,'TUNG#STEN').NE.0)THEN FUNCT(NFUNCT+1:NFUNCT+5)=',19.3' NFUNCT=NFUNCT+5 ELSEIF(NWORD.GE.I.AND.INPCMP(I,'*').EQ.0)THEN CALL INPSTR(I,I,STRING,NC) FUNCT(NFUNCT+1:NFUNCT+NC+1)=','//STRING(1:NC) NFUNCT=NFUNCT+NC+1 ELSE IF(I.EQ.3)THEN FUNCT(NFUNCT+1:NFUNCT+5)=',0.01' NFUNCT=NFUNCT+5 ELSEIF(I.EQ.7)THEN FUNCT(NFUNCT+1:NFUNCT+5)=',50.0' NFUNCT=NFUNCT+5 ELSEIF(I.EQ.8)THEN FUNCT(NFUNCT+1:NFUNCT+6)=',100.0' NFUNCT=NFUNCT+6 ELSEIF(I.EQ.9)THEN FUNCT(NFUNCT+1:NFUNCT+5)=',19.3' NFUNCT=NFUNCT+5 ELSE FUNCT(NFUNCT+1:NFUNCT+4)=',0.0' NFUNCT=NFUNCT+4 ENDIF ENDIF 21 CONTINUE FUNCT(1:1)=' ' CALL ALGPRE(FUNCT,NFUNCT,VARLIS,NVAR,NRES,USE,IENTRY,IFAIL6) * Dump messages and skip the row if not meaningful. CALL INPERR IF(IFAIL1+IFAIL2+IFAIL4+IFAIL5+IFAIL6.NE.0)THEN PRINT *,' !!!!!! CELINP WARNING : Row skipped'// - ' because of syntax or value errors.' CALL ALGCLR(IENTRY) GOTO 20 ENDIF * Add the new wires to the list, making sure that # is not > MXWIRE. DO 30 J=0,NR-1 VAR(NVAR)=J MODVAR(NVAR)=2 CALL ALGEXE(IENTRY,VAR,MODVAR,NVAR,RES,MODRES,7,IFAIL7) DR=RES(1) XR=RES(2) YR=RES(3) VR=RES(4) WR=RES(5) UR=RES(6) SR=RES(7) IF(IFAIL7.NE.0)THEN PRINT '('' !!!!!! CELINP WARNING : Algebra errors;'', - '' wire '',I3,'' of this row is skipped.'')',J+1 GOTO 30 ELSEIF(DR.LE.0.0)THEN PRINT '('' !!!!!! CELINP WARNING : Wire '',I3,'' of'', - '' this row is skipped because its diameter is'', - '' not positive.'')',J+1 GOTO 30 ELSEIF(WR.LE.0.0)THEN PRINT '('' !!!!!! CELINP WARNING : Wire '',I3,'' of'', - '' this row is skipped because its tension is'', - '' not positive.'')',J+1 GOTO 30 ELSEIF(UR.LE.0.0)THEN PRINT '('' !!!!!! CELINP WARNING : Wire '',I3,'' of'', - '' this row is skipped because its length is'', - '' not positive.'')',J+1 GOTO 30 ELSEIF(SR.LE.0.0)THEN PRINT '('' !!!!!! CELINP WARNING : Wire '',I3,'' of'', - '' this row is skipped because its density is'', - '' not positive.'')',J+1 GOTO 30 ENDIF NWIRE=NWIRE+1 IF(NWIRE.GT.MXWIRE)GOTO 30 X(NWIRE)=XR Y(NWIRE)=YR V(NWIRE)=VR W(NWIRE)=WR U(NWIRE)=UR DENS(NWIRE)=SR D(NWIRE)=DR WIRTYP(NWIRE)=WIRTPR INDSW(NWIRE)=0 * Convert from polar to internal coordinates if the cell is polar. IF(CPOLAR.AND..NOT.CTUBE)THEN IF(X(NWIRE).LE.D(I))THEN PRINT '('' !!!!!! CELINP WARNING : Wire '',I3, - '' of this row is too close to the origin;'', - '' the wire is skipped.'')',J+1 NWIRE=NWIRE-1 ELSE D(NWIRE)=DR/X(NWIRE) CALL CFMPTR(X(NWIRE),Y(NWIRE),X(NWIRE),Y(NWIRE),1, - IFAIL1) ENDIF ENDIF 30 CONTINUE * Release the algebra entry point. CALL ALGCLR(IENTRY) GOTO 20 60 CONTINUE * Reset the prompt. CALL INPPRM(' ','BACK-PRINT') * Reset the loop variable. NVAR=NVAR-1 * Warn if no wires are found. IF(NWIRE.EQ.0)THEN PRINT *,' !!!!!! CELINP WARNING : No rows found'// - ' after the instruction ROW.' * Warn if NWIRE > MXWIRE. ELSEIF(NWIRE.GT.MXWIRE)THEN PRINT *,' ###### CELINP ERROR : The number of wires' - //' found in the input is larger than MXWIRE'// - ' for the present compilation' PRINT *,' a correct value may' - //' be obtained by inserting the following'// - ' cards in the Patchy cradle before +PAM.' PRINT *,' ' PRINT *,'+REP,P=COMMONS,C=.' PRINT *,' PARAMETER(MXWIRE=',NWIRE, - ', MXSW=',MXSW,')' PRINT *,' ' NWIRE=MXWIRE IFAIL=1 ENDIF * Proceed with next input line in this section (reset GET condition). IGET=0 *** Listing of solids. ELSEIF(INPCMP(1,'SOL#IDS').NE.0)THEN CALL CELSOL *** TUBE statement. ELSEIF(INPCMP(1,'TUBE').NE.0)THEN * Can not be handled if the cell has started to be Cartesian. IF(CCART)THEN PRINT *,' !!!!!! CELINP WARNING : Cell description'// - ' started in Cartesian coordinates; tube ignored.' GOTO 10 ENDIF * Check for the presence of planes. IF(NY.NE.2.OR.NX.NE.0)THEN PRINT *,' !!!!!! CELINP WARNING : You have already'// - ' defined one or more planes; they are deleted.' NX=0 NY=2 ENDIF * Reset the origin flag. IGET=0 * Check the input syntax and extract the parameters. RADIUS=0 NTUBER=0 VOLT=0.0 PLATPR='?' DELETE=.FALSE. * Preset the tube data. COTUBE=1 VTTUBE=0 NTUBE=0 MTUBE=0 NPSTR1(5)=0 NPSTR2(5)=0 PLATYP(5)='?' * Read the command line. INEXT=2 DO 40 I=2,NWORD IF(I.LT.INEXT)GOTO 40 * Look for the radius. IF(INPCMP(I,'R#ADIUS').NE.0)THEN CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,RADIUS,0.0) IF(IFAIL1.NE.0)THEN DELETE=.TRUE. OK=.FALSE. ELSEIF(RADIUS.LE.0.0)THEN CALL INPMSG(I,'Tube radius must be > 0.') CALL INPMSG(I+1,'See the previous message.') DELETE=.TRUE. OK=.FALSE. ELSE COTUBE=RADIUS ENDIF INEXT=I+2 * Voltage definition, ELSEIF(INPCMP(I,'V#OLTAGE').NE.0)THEN CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,VOLT,0.0) IF(IFAIL1.NE.0)THEN DELETE=.TRUE. OK=.FALSE. ELSE VTTUBE=VOLT ENDIF INEXT=I+2 * Number of edges. ELSEIF(INPCMP(I,'E#DGES').NE.0)THEN CALL INPCHK(I+1,1,IFAIL1) CALL INPRDI(I+1,NTUBER,0) IF(IFAIL1.NE.0)THEN DELETE=.TRUE. OK=.FALSE. ELSEIF((NTUBER.NE.0.AND.NTUBER.LT.3).OR. - NTUBER.GT.8)THEN CALL INPMSG(I+1,'Number of edges not valid. ') DELETE=.TRUE. OK=.FALSE. ELSE NTUBE=NTUBER ENDIF INEXT=I+2 ELSEIF(INPCMP(I,'CIRC#LE')+ - INPCMP(I,'CIRC#ULAR')+ - INPCMP(I,'CYL#INDER')+ - INPCMP(I,'CYL#INDRICAL').NE.0)THEN NTUBE=0 ELSEIF(INPCMP(I,'TRI#ANGLE')+ - INPCMP(I,'TRI#ANGULAR').NE.0)THEN NTUBE=3 ELSEIF(INPCMP(I,'SQU#ARE').NE.0)THEN NTUBE=4 ELSEIF(INPCMP(I,'PENT#AGONAL').NE.0)THEN NTUBE=5 ELSEIF(INPCMP(I,'HEX#AGONAL').NE.0)THEN NTUBE=6 ELSEIF(INPCMP(I,'HEPT#AGONAL').NE.0)THEN NTUBE=7 ELSEIF(INPCMP(I,'OCT#AGONAL').NE.0)THEN NTUBE=8 * Label. ELSEIF(INPCMP(I,'LAB#EL').NE.0)THEN CALL INPSTR(I+1,I+1,STRING,NC) PLATPR=STRING(1:1) IF(INDEX('ABCDEFGHIJKLMNOPQRSTUVWXYZ',PLATPR).EQ. - 0)THEN CALL INPMSG(I+1,'The label must be a letter.') DELETE=.TRUE. OK=.FALSE. ELSE PLATYP(5)=PLATPR ENDIF INEXT=I+2 ** Strips. ELSEIF(INPCMP(I,'PHI-STRIP')+INPCMP(I,'Z-STRIP').NE.0)THEN * Initial values. SMIN=0.0 SMAX=0.0 GAP=-1.0 STRTPR='?' * Read range. CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,SMIN,0.0) CALL INPCHK(I+2,2,IFAIL2) CALL INPRDR(I+2,SMAX,0.0) * Reject syntax errors. IF(IFAIL1.NE.0.OR.IFAIL2.NE.0)THEN OK=.FALSE. DELETE=.TRUE. ENDIF * Coordinate transformations for polar coordinates. IF(INPCMP(I,'PHI-STRIP').NE.0)THEN SMIN=PI*SMIN/180 SMAX=PI*SMAX/180 SMIN=MOD(SMIN,2*PI) IF(SMIN.GT.PI)SMIN=SMIN-2*PI IF(SMIN.LT.-PI)SMIN=SMIN+2*PI SMAX=MOD(SMAX,2*PI) IF(SMAX.GT.PI)SMAX=SMAX-2*PI IF(SMAX.LT.-PI)SMAX=SMAX+2*PI ENDIF * Order the coordinates if required. IF(ABS(SMIN-SMAX).LT.1E-4)THEN CALL INPMSG(I+1,'Zero range not permitted.') CALL INPMSG(I+2,'Zero range not permitted.') OK=.FALSE. DELETE=.TRUE. SMIN=1 SMAX=1 ELSEIF(SMIN.GT.SMAX)THEN SAUX=SMIN SMIN=SMAX SMAX=SAUX ENDIF * Next word. INEXT=I+3 ** Search for optional arguments, first initialise them. DO 140 J=I+3,NWORD IF(J.LT.INEXT)GOTO 140 * Gap width. IF(INPCMP(J,'GAP').NE.0)THEN CALL INPCHK(J+1,2,IFAIL2) CALL INPRDR(J+1,GAP,0.0) IF(IFAIL2.NE.0)THEN OK=.FALSE. DELETE=.TRUE. GAP=-1.0 ELSEIF(GAP.LE.0)THEN CALL INPMSG(J+1,'Gap must be > 0') OK=.FALSE. DELETE=.TRUE. GAP=-1.0 ENDIF INEXT=J+2 * Strip label. ELSEIF(INPCMP(J,'LAB#EL').NE.0)THEN CALL INPSTR(J+1,J+1,STRING,NC) STRTPR=STRING(1:1) IF(INDEX('ABCDEFGHIJKLMNOPQRSTUVWXYZ',STRTPR).EQ. - 0)THEN CALL INPMSG(J+1, - 'The label must be a letter.') OK=.FALSE. DELETE=.TRUE. STRTPR='?' ENDIF INEXT=J+2 * Otherwise, leave the loop. ELSE GOTO 150 ENDIF 140 CONTINUE 150 CONTINUE ** Store the strip. IF(INPCMP(I,'PHI-STRIP').NE.0)THEN IF(NPSTR1(5).GE.MXPSTR)THEN CALL INPMSG(I,'Maximum number of'// - ' strips reached.') OK=.FALSE. DELETE=.TRUE. ELSE NPSTR1(5)=NPSTR1(5)+1 PLSTR1(5,NPSTR1(5),1)=SMIN PLSTR1(5,NPSTR1(5),2)=SMAX PLSTR1(5,NPSTR1(5),3)=GAP PSLAB1(5,NPSTR1(5))=STRTPR ENDIF ELSEIF(INPCMP(I,'Z-STRIP').NE.0)THEN IF(NPSTR2(5).GE.MXPSTR)THEN CALL INPMSG(I,'Maximum number of'// - ' strips reached.') OK=.FALSE. DELETE=.TRUE. ELSE NPSTR2(5)=NPSTR2(5)+1 PLSTR2(5,NPSTR2(5),1)=SMIN PLSTR2(5,NPSTR2(5),2)=SMAX PLSTR2(5,NPSTR2(5),3)=GAP PSLAB2(5,NPSTR2(5))=STRTPR ENDIF ENDIF * Unknown field. ELSE CALL INPMSG(I,'Not known as a valid keyword. ') ENDIF 40 CONTINUE * Print the errors generated so far, return if errors are serious. CALL INPERR * Delete tube in case of errors. IF(DELETE)THEN PRINT *,' !!!!!! CELINP WARNING : Tube ignored'// - ' because of syntax or value errors.' NPSTR1(5)=0 NPSTR2(5)=0 CTUBE=.FALSE. GOTO 10 ENDIF * Update the coordinate system flags. CCART=.FALSE. CTUBE=.TRUE. CPOLAR=.FALSE. *** Call CELWRT with the name of the data set. ELSEIF(INPCMP(1,'WR#ITE').NE.0)THEN CALL CELWRT(1) *** It is not possible to get here if a keyword is found. ELSE CALL INPSTR(1,1,STRING,NC) PRINT *,' !!!!!! CELINP WARNING : '//STRING(1:NC)//' is'// - ' not a valid instruction ; line is skipped.' ENDIF *** Finish reading loop. GOTO 10 50 CONTINUE *** Set POLAR if the cell has cylindrical symmetry. IF(CCART)THEN POLAR=.FALSE. TUBE=.FALSE. * Tubes. ELSEIF(CTUBE)THEN POLAR=.FALSE. TUBE=.TRUE. * True polar cells, set phi period if neither periodic nor planes. ELSEIF(CPOLAR)THEN POLAR=.TRUE. TUBE=.FALSE. IF(.NOT.(PERY.OR.(YNPLAN(3).AND.YNPLAN(4))))THEN SY=2.0*PI PERY=.TRUE. ENDIF ENDIF *** Register the amount of CPU time used by this routine. CALL TIMLOG('Reading the cell definition: ') *** Normaly the routine should end at this point. END +DECK,CELINT. SUBROUTINE CELINT *----------------------------------------------------------------------- * CELINT - Initialises cell data. * (Last changed on 5/12/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. INTEGER I,J *** Overall flag for cell data. CELSET =.FALSE. *** Coordinate system. POLAR =.FALSE. TUBE =.FALSE. *** Cell type. TYPE ='A ' ICTYPE =1 *** Identifier. CELLID =' ' *** Wires. NWIRE =0 NSW =0 KAPPA =0.0 DO 40 I=1,MXWIRE X(I) =0.0 Y(I) =0.0 D(I) =0.0 E(I) =0.0 V(I) =0.0 W(I) =50.0 U(I) =100.0 DENS(I) =19.3 B2SIN(I) =0.0 WMAP(I) =CMPLX(0.0,0.0) WIRTYP(I)='?' CNALSO(I)=.TRUE. 40 CONTINUE *** 3D charges. N3D =0 DO 90 I=1,MX3D X3D(I) =0.0 Y3D(I) =0.0 Z3D(I) =0.0 E3D(I) =0.0 90 CONTINUE NTERMB =10 NTERMP =100 *** Planes and tube. DO 20 I=1,5 IF(I.LE.4)THEN YNPLAN(I)=.FALSE. COPLAN(I)=0.0 VTPLAN(I)=0.0 ENDIF * Strips. NPSTR1(I)=0 NPSTR2(I)=0 DO 100 J=1,MXPSTR PLSTR1(I,J,1)=0 PLSTR1(I,J,2)=0 PLSTR1(I,J,3)=0 PLSTR2(I,J,1)=0 PLSTR2(I,J,2)=0 PLSTR2(I,J,3)=0 PSLAB1(I,J)='?' PSLAB2(I,J)='?' INDST1(I,J)=0 INDST2(I,J)=0 100 CONTINUE 20 CONTINUE * Plane labels and references. DO 80 I=1,5 PLATYP(I)='?' INDPLA(I)=0 80 CONTINUE * Plane shorthand. YNPLAX =.FALSE. YNPLAY =.FALSE. COPLAX =1.0 COPLAY =1.0 * Tube properties. NTUBE =0 MTUBE =0 *** Dielectrica. NXMATT =0 NYMATT =0 *** Periodicities. PERX =.FALSE. PERY =.FALSE. PERZ =.FALSE. PERMX =.FALSE. PERMY =.FALSE. PERMZ =.FALSE. PERAX =.FALSE. PERAY =.FALSE. PERAZ =.FALSE. PERRX =.FALSE. PERRY =.FALSE. PERRZ =.FALSE. SX =1.0 SY =1.0 SZ =1.0 *** Gravity. DOWN(1) =0 DOWN(2) =0 DOWN(3) =1 END +DECK,CELLAY. SUBROUTINE CELLAY(PXMIN,PYMIN,PXMAX,PYMAX) *----------------------------------------------------------------------- * CELLAY - This routine draws all elements of the cell inside the * rectangle (PXMIN,PYMIN) to (PXMAX,PYMAX), taking care of * periodicities etc, on the plot being made. * VARIABLES : NXMIN,NXMAX: Numbers of resp first and last x-period. * NYMIN,NYMAX: " " " " " " y " * (XPOS,YPOS): Used for plotting (like XPL and YPL). * CHAR : Used because WIRTYP(I) may start in the * middle of a word. * XPL,YPL : Used for plotting of lines. * (Last changed on 1/12/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,CONSTANTS. +SEQ,PRINTPLOT. REAL XPL(101),YPL(101),XPOS(1),YPOS(1),PXMIN,PYMIN,PXMAX,PYMAX INTEGER NX,NXMIN,NXMAX,NY,NYMIN,NYMAX,I,J,K *** Determine the number of periods present in the cell. NXMIN=0 NXMAX=0 NYMIN=0 NYMAX=0 IF(PERX)THEN NXMIN=INT(PXMIN/SX)-1 NXMAX=INT(PXMAX/SX)+1 ENDIF IF(PERY)THEN NYMIN=INT(PYMIN/SY)-1 NYMAX=INT(PYMAX/SY)+1 ENDIF *** Draw the field map if present. CALL MAPPLT(PXMIN,PYMIN,0.0,PXMAX,PYMAX,0.0) *** Plot the wires as MARKERS. IF(LWRMRK)THEN * Loop over the wires. DO 130 I=1,NWIRE * Loop over the periods. DO 140 NX=NXMIN,NXMAX DO 150 NY=NYMIN,NYMAX * Non-tube shaped cells. IF(.NOT.TUBE)THEN XPOS(1)=X(I)+NX*SX IF(XPOS(1)+0.5*D(I).LE.PXMIN.OR. - XPOS(1)-0.5*D(I).GE.PXMAX)GOTO 140 YPOS(1)=Y(I)+NY*SY IF(YPOS(1)+0.5*D(I).LE.PYMIN.OR. - YPOS(1)-0.5*D(I).GE.PYMAX)GOTO 150 IF(POLAR)CALL CFMRTC(XPOS,YPOS,XPOS,YPOS,1) * Tubed shaped cells. ELSE CALL CFMCTP(X(I),Y(I),XPOS,YPOS,1) IF(PERY)YPOS(1)=YPOS(1)+REAL(NY*360)/REAL(MTUBE) CALL CFMPTC(XPOS,YPOS,XPOS,YPOS,1) IF(XPOS(1)+0.5*D(I).LE.PXMIN.OR. - XPOS(1)-0.5*D(I).GE.PXMAX.OR. - YPOS(1)+0.5*D(I).LE.PYMIN.OR. - YPOS(1)-0.5*D(I).GE.PYMAX)GOTO 150 ENDIF * Choose the appropriate representation. IF(WIRTYP(I).EQ.'S')THEN CALL GRATTS('S-WIRE','POLYMARKER') ELSEIF(WIRTYP(I).EQ.'P')THEN CALL GRATTS('P-WIRE','POLYMARKER') ELSEIF(WIRTYP(I).EQ.'C')THEN CALL GRATTS('C-WIRE','POLYMARKER') ELSE CALL GRATTS('OTHER-WIRE','POLYMARKER') ENDIF CALL GRMARK(1,XPOS,YPOS) 150 CONTINUE 140 CONTINUE 130 CONTINUE *** Plot the wires as AREAS. ELSE * Set fill area style, by default hollow to make GFA look like GPL. CALL GRATTS('WIRES','AREA') * Open a segment so that we can later on pick out the wires. CALL GCRSG(1) * Make the wires detectable. CALL GSDTEC(1,1) * Loop over all wires. DO 40 I=1,NWIRE * Set a pick identifier for each wire separately. CALL GSPKID(I) * Loop over the periods. DO 30 NX=NXMIN,NXMAX DO 20 NY=NYMIN,NYMAX * Non-tube shaped cells. IF(.NOT.TUBE)THEN XPOS(1)=X(I)+NX*SX IF(XPOS(1)+0.5*D(I).LE.PXMIN.OR. - XPOS(1)-0.5*D(I).GE.PXMAX)GOTO 30 YPOS(1)=Y(I)+NY*SY IF(YPOS(1)+0.5*D(I).LE.PYMIN.OR. - YPOS(1)-0.5*D(I).GE.PYMAX)GOTO 20 IF(POLAR)CALL CFMRTC(XPOS,YPOS,XPOS,YPOS,1) * Tubed shaped cells. ELSE CALL CFMCTP(X(I),Y(I),XPOS,YPOS,1) IF(PERY)YPOS(1)=YPOS(1)+REAL(NY*360)/REAL(MTUBE) CALL CFMPTC(XPOS,YPOS,XPOS,YPOS,1) IF(XPOS(1)+0.5*D(I).LE.PXMIN.OR. - XPOS(1)-0.5*D(I).GE.PXMAX.OR. - YPOS(1)+0.5*D(I).LE.PYMIN.OR. - YPOS(1)-0.5*D(I).GE.PYMAX)GOTO 20 ENDIF * Calculate 20 points on each of the wires to make a circle. DO 10 J=1,21 XPL(J)=XPOS(1)+0.5*D(I)*COS(PI*J/10.0) YPL(J)=YPOS(1)+0.5*D(I)*SIN(PI*J/10.0) IF(XPL(J).LT.PXMIN)XPL(J)=PXMIN IF(XPL(J).GT.PXMAX)XPL(J)=PXMAX IF(YPL(J).LT.PYMIN)YPL(J)=PYMIN IF(YPL(J).GT.PYMAX)YPL(J)=PYMAX 10 CONTINUE * Plots as fill areas. CALL GRAREA(21,XPL,YPL) * Next periods. 20 CONTINUE 30 CONTINUE * Next wire. 40 CONTINUE * Close the segment for the wires. CALL GCLSG ENDIF *** Draw lines at the positions of the x (or r)-planes. DO 70 I=1,2 DO 60 NX=NXMIN,NXMAX IF(YNPLAN(I))THEN CALL GRATTS('PLANES','POLYLINE') XPOS(1)=COPLAN(I)+NX*SX IF(XPOS(1).LE.PXMIN.OR.XPOS(1).GE.PXMAX)GOTO 60 DO 50 J=1,101 XPL(J)=XPOS(1) YPL(J)=PYMIN+(J-1)*(PYMAX-PYMIN)/100 50 CONTINUE IF(POLAR)CALL CFMRTC(XPL,YPL,XPL,YPL,101) CALL GRLINE(101,XPL,YPL) CALL GRATTS('STRIPS','POLYLINE') DO 160 J=1,NPSTR1(I) DO 170 K=1,101 XPL(K)=XPOS(1) YPL(K)=MAX(PLSTR1(I,J,1),PYMIN)+(K-1)* - (MIN(PLSTR1(I,J,2),PYMAX)-MAX(PLSTR1(I,J,1),PYMIN))/100 170 CONTINUE IF(POLAR)CALL CFMRTC(XPL,YPL,XPL,YPL,101) CALL GRLINE(101,XPL,YPL) 160 CONTINUE ENDIF 60 CONTINUE 70 CONTINUE *** Draw lines at the positions of the y-planes. DO 100 I=3,4 DO 90 NY=NYMIN,NYMAX IF(YNPLAN(I))THEN CALL GRATTS('PLANES','POLYLINE') YPOS(1)=COPLAN(I)+NY*SY IF(YPOS(1).LE.PYMIN.OR.YPOS(1).GE.PYMAX)GOTO 90 DO 80 J=1,101 XPL(J)=PXMIN+(J-1)*(PXMAX-PXMIN)/100 YPL(J)=YPOS(1) 80 CONTINUE IF(POLAR)CALL CFMRTC(XPL,YPL,XPL,YPL,101) CALL GRLINE(101,XPL,YPL) CALL GRATTS('STRIPS','POLYLINE') DO 180 J=1,NPSTR1(I) DO 190 K=1,101 XPL(K)=MAX(PLSTR1(I,J,1),PXMIN)+(K-1)* - (MIN(PLSTR1(I,J,2),PXMAX)-MAX(PLSTR1(I,J,1),PXMIN))/100 YPL(K)=YPOS(1) 190 CONTINUE IF(POLAR)CALL CFMRTC(XPL,YPL,XPL,YPL,101) CALL GRLINE(101,XPL,YPL) 180 CONTINUE ENDIF 90 CONTINUE 100 CONTINUE *** Draw the dielectrica, first switch to fill are style hatched. CALL GRATTS('DIELECTRICA-1','AREA') DO 110 I=1,NXMATT XPL(1)=PXMIN IF(XMATT(I,3).EQ.0)XPL(1)=MIN(PXMAX,MAX(PXMIN,XMATT(I,1))) YPL(1)=PYMIN XPL(2)=XPL(1) YPL(2)=PYMAX XPL(3)=PXMAX IF(XMATT(I,4).EQ.0)XPL(3)=MIN(PXMAX,MAX(PXMIN,XMATT(I,2))) YPL(3)=PYMAX XPL(4)=XPL(3) YPL(4)=PYMIN XPL(5)=XPL(1) YPL(5)=YPL(1) CALL GRLINE(5,XPL,YPL) CALL GRAREA(5,XPL,YPL) 110 CONTINUE DO 120 I=1,NYMATT XPL(1)=PXMIN YPL(1)=PYMIN IF(YMATT(I,3).EQ.0)YPL(1)=MIN(PYMAX,MAX(PYMIN,YMATT(I,1))) XPL(2)=PXMAX YPL(2)=YPL(1) XPL(3)=PXMAX YPL(3)=PYMAX IF(YMATT(I,4).EQ.0)YPL(3)=MIN(PYMAX,MAX(PYMIN,YMATT(I,2))) XPL(4)=PXMIN YPL(4)=YPL(3) XPL(5)=XPL(1) YPL(5)=YPL(1) CALL GRLINE(5,XPL,YPL) CALL GRAREA(5,XPL,YPL) 120 CONTINUE *** Draw the tube. CALL GRATTS('TUBE','POLYLINE') IF(TUBE.AND.NTUBE.EQ.0)THEN DO 200 I=1,101 XPL(I)=COTUBE*COS(PI*REAL(I)/50.0) YPL(I)=COTUBE*SIN(PI*REAL(I)/50.0) 200 CONTINUE CALL GRLINE(101,XPL,YPL) ELSEIF(TUBE)THEN XPL(1)=COTUBE*COS(2*PI*REAL(0)/REAL(NTUBE)) YPL(1)=COTUBE*SIN(2*PI*REAL(0)/REAL(NTUBE)) DO 210 I=1,NTUBE XPL(2)=COTUBE*COS(2*PI*REAL(I)/REAL(NTUBE)) YPL(2)=COTUBE*SIN(2*PI*REAL(I)/REAL(NTUBE)) CALL GRLINE(2,XPL,YPL) XPL(1)=XPL(2) YPL(1)=YPL(2) 210 CONTINUE ENDIF END +DECK,CELPLT. SUBROUTINE CELPLT *----------------------------------------------------------------------- * CELPLT - This routine produces a plotted layout of the cell * VARIABLES : PXMIN,PXMAX: x-range of layout plot * PYMIN,PYMAX: y-range of layout plot * (Last changed on 14/ 2/97.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,CONSTANTS. +SEQ,PARAMETERS. +SEQ,GRAPHICS. +SEQ,PRINTPLOT. REAL DIFF,DX,XPOS,YPOS,XPL,YPL INTEGER NX,NXMIN,NXMAX,NY,NYMIN,NYMAX,I *** Set plotting area. PXMIN=XMIN-0.1*(XMAX-XMIN) PXMAX=XMAX+0.1*(XMAX-XMIN) PYMIN=YMIN-0.1*(YMAX-YMIN) PYMAX=YMAX+0.1*(YMAX-YMIN) IF(POLAR.AND.PYMAX-PYMIN.GE.2.0*PI)THEN PYMIN=-PI PYMAX=PI ENDIF *** Determine the number of periods present in the cell. NXMIN=0 NXMAX=0 NYMIN=0 NYMAX=0 IF(PERX)THEN NXMIN=INT(PXMIN/SX)-2 NXMAX=INT(PXMAX/SX)+1 ENDIF IF(PERY)THEN NYMIN=INT(PYMIN/SY)-2 NYMAX=INT(PYMAX/SY)+1 ENDIF *** Plot the axes, the wires, the planes and the dielectrica. IF(LISOCL.AND.PXMAX-PXMIN.GT.PYMAX-PYMIN)THEN DIFF=(PXMAX-PXMIN)-(PYMAX-PYMIN) CALL GRAXIS(PXMIN,PYMIN-DIFF/2,PXMAX,PYMAX+DIFF/2, - 'LAYOUT OF THE CELL ') CALL CELLAY(PXMIN,PYMIN-DIFF/2,PXMAX,PYMAX+DIFF/2) ELSEIF(LISOCL)THEN DIFF=(PYMAX-PYMIN)-(PXMAX-PXMIN) CALL GRAXIS(PXMIN-DIFF/2,PYMIN,PXMAX+DIFF/2,PYMAX, - 'LAYOUT OF THE CELL ') CALL CELLAY(PXMIN-DIFF/2,PYMIN,PXMAX+DIFF/2,PYMAX) ELSE CALL GRAXIS(PXMIN,PYMIN,PXMAX,PYMAX, - 'LAYOUT OF THE CELL ') CALL CELLAY(PXMIN,PYMIN,PXMAX,PYMAX) ENDIF *** Put the cell label in. IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) *** Switch to unscaled mode to get normal letters. CALL GSELNT(0) *** Calculate reasonable positions for the wire-code-labels, set DX. DX=(USERX1-USERX0)/50.0 DO 10 I=1,NWIRE DO 20 NX=NXMIN,NXMAX XPOS=X(I)+NX*SX IF(XPOS.LT.PXMIN.OR.XPOS.GT.PXMAX)GOTO 20 DO 30 NY=NYMIN,NYMAX YPOS=Y(I)+NY*SY IF(YPOS.LT.PYMIN.OR.YPOS.GT.PYMAX)GOTO 30 * If polar, convert to cartesian coordinates. XPL=XPOS YPL=YPOS IF(POLAR)CALL CFMRTC(XPL,YPL,XPL,YPL,1) * Shift the location of the label slightly in x within the area. IF(XPL+5.0*MAX(D(I),DX).LT.USERX1)THEN XPL=XPL+2.0*MAX(D(I),DX) ELSEIF(XPL+5.0*MAX(D(I),DX).GT.USERX0)THEN XPL=XPL-2.0*MAX(D(I),DX) ELSE GOTO 20 ENDIF * Plot, transforming to display coordinates (NDC). IF(.NOT.LWRMRK)CALL GRTX( - DISPX0+(DISPX1-DISPX0)*(XPL-USERX0)/(USERX1-USERX0), - DISPY0+(DISPY1-DISPY0)*(YPL-USERY0)/(USERY1-USERY0), - WIRTYP(I)) 30 CONTINUE 20 CONTINUE 10 CONTINUE CALL GSELNT(1) *** Clear the screen to allow the next plot to start. CALL GRNEXT *** Register the plot and the amount of CPU time used. CALL TIMLOG('Plotting the cell layout: ') CALL GRALOG('Layout of the drift cell. ') END +DECK,CELPRT. SUBROUTINE CELPRT *----------------------------------------------------------------------- * CELPRT - Subroutine printing all available information on the cell. * VARIABLES : Only trivial local variables. * (Last changed on 29/11/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,SOLIDS. +SEQ,FIELDMAP. +SEQ,PRINTPLOT. +SEQ,CONSTANTS. CHARACTER*30 AUX1,AUX2,AUX3,AUX4,AUX5,AUX6,AUX7,AUX8,AUX9 CHARACTER*120 OUTSTR INTEGER I,J,NCAUX,NC1,NC2,NC3,NC4,NC5,NC6,NC7,NC8,NC9,NCOUT, - LMIN,RMAX REAL XPRT,YPRT,DPRT,SUMCH,XMINP,YMINP,XMAXP,YMAXP *** Identify the procedure. IF(LIDENT)PRINT *,' /// ROUTINE CELPRT ///' *** Write a heading for the summary, including the cell id WRITE(LUNOUT,'(''1 SUMMARY OF THE CELL DATA''/ - '' ========================'')') IF(CELLID.NE.' ')WRITE(LUNOUT,'(/'' Cell identification : '', - A)') CELLID *** Print positions of wires, applied voltages and resulting charges. IF(POLAR.AND.NWIRE.GE.1)THEN WRITE(LUNOUT,'(/'' TABLE OF THE WIRES''// - '' Nr Diameter r phi Voltage'', - '' Charge Tension Length Density Label''/ - '' [micron] [cm] [deg] [Volt]'', - '' [pC/cm] [g] [cm] [g/cm3]''/)') ELSEIF(NWIRE.GE.1)THEN WRITE(LUNOUT,'(/'' TABLE OF THE WIRES''// - '' Nr Diameter x y Voltage'', - '' Charge Tension Length Density Label''/ - '' [micron] [cm] [cm] [Volt]'', - '' [pC/cm] [g] [cm] [g/cm3]''/)') ELSE WRITE(LUNOUT,'('' TABLE OF THE WIRES''// - '' There are no wires in this cell.'')') ENDIF DO 10 I=1,NWIRE XPRT=X(I) YPRT=Y(I) DPRT=D(I) IF(POLAR)THEN CALL CFMRTP(XPRT,YPRT,XPRT,YPRT,1) DPRT=D(I)*XPRT ENDIF CALL OUTFMT(REAL(I),2,AUX9,NC9,'RIGHT') CALL OUTFMT(DPRT*10000.0,2,AUX1,NC1,'RIGHT') CALL OUTFMT(XPRT,2,AUX2,NC2,'RIGHT') CALL OUTFMT(YPRT,2,AUX3,NC3,'RIGHT') CALL OUTFMT(V(I),2,AUX4,NC4,'RIGHT') CALL OUTFMT(2.0E12*PI*EPS0*E(I),2,AUX5,NC5,'RIGHT') CALL OUTFMT(W(I),2,AUX6,NC6,'RIGHT') CALL OUTFMT(U(I),2,AUX7,NC7,'RIGHT') CALL OUTFMT(DENS(I),2,AUX8,NC8,'RIGHT') WRITE(LUNOUT,'(2X,A4,A9,A9,A9,A9,A12,A9,A9,A9,5X,A1)') - AUX9(27:),AUX1(22:),AUX2(22:),AUX3(22:),AUX4(22:), - AUX5(19:),AUX6(22:),AUX7(22:),AUX8(22:),WIRTYP(I) 10 CONTINUE *** Field map perhaps ? IF(NMAP.GE.1)THEN WRITE(LUNOUT,'(/'' FIELD MAP'')') CALL MAPPRT ENDIF IF(NSOLID.GE.1)CALL CELSPR *** Print information on the tube if present. IF(TUBE)THEN CALL OUTFMT(VTTUBE,2,AUX1,NC1,'LEFT') CALL OUTFMT(COTUBE,2,AUX2,NC2,'LEFT') IF(NTUBE.EQ.0)THEN AUX3='Circular' NC3=8 ELSEIF(NTUBE.EQ.3)THEN AUX3='Triangular' NC3=10 ELSEIF(NTUBE.EQ.4)THEN AUX3='Square' NC3=6 ELSEIF(NTUBE.EQ.5)THEN AUX3='Pentagonal' NC3=10 ELSEIF(NTUBE.EQ.6)THEN AUX3='Hexagonal' NC3=9 ELSEIF(NTUBE.EQ.7)THEN AUX3='Heptagonal' NC3=10 ELSEIF(NTUBE.EQ.8)THEN AUX3='Octagonal' NC3=9 ELSE CALL OUTFMT(REAL(NTUBE),2,AUX5,NC5,'LEFT') AUX3='polygonal with '//AUX5(1:NC5)//' corners' NC3=23+NC5 ENDIF IF(PLATYP(5).EQ.'?')THEN AUX4='Not labeled' NC4=11 ELSE AUX4=PLATYP(5) NC4=1 ENDIF WRITE(LUNOUT,'(/'' ENCLOSING TUBE''// - '' Potential: '',A,'' V''/ - '' Radius: '',A,'' cm''/ - '' Shape: '',A/ - '' Label: '',A)') - AUX1(1:NC1),AUX2(1:NC2),AUX3(1:NC3),AUX4(1:NC4) IF(NPSTR1(5).GT.0)THEN WRITE(LUNOUT,'('' phi-Strips:'')') DO 110 I=1,NPSTR1(5) CALL OUTFMT(180*PLSTR1(5,I,1)/PI,2,AUX1,NC1,'LEFT') CALL OUTFMT(180*PLSTR1(5,I,2)/PI,2,AUX2,NC2,'LEFT') CALL OUTFMT(PLSTR1(5,I,3),2,AUX3,NC3,'LEFT') IF(PSLAB1(5,I).EQ.'?')THEN AUX4=' not labeled' NC4=12 ELSE AUX4=' label = '//PSLAB1(5,I) NC4=10 ENDIF WRITE(LUNOUT,'(14X,A)') AUX1(1:NC1)//' < phi < '// - AUX2(1:NC2)//' degrees, gap = '//AUX3(1:NC3)// - ' cm,'//AUX4(1:NC4) 110 CONTINUE ELSE WRITE(LUNOUT,'('' phi-Strips: None'')') ENDIF IF(NPSTR2(5).GT.0)THEN WRITE(LUNOUT,'('' z-Strips:'')') DO 120 I=1,NPSTR2(5) CALL OUTFMT(PLSTR2(5,I,1),2,AUX1,NC1,'LEFT') CALL OUTFMT(PLSTR2(5,I,2),2,AUX2,NC2,'LEFT') CALL OUTFMT(PLSTR2(5,I,3),2,AUX3,NC3,'LEFT') IF(PSLAB2(5,I).EQ.'?')THEN AUX4=' not labeled' NC4=12 ELSE AUX4=' label = '//PSLAB2(5,I) NC4=10 ENDIF WRITE(LUNOUT,'(14X,A)') AUX1(1:NC1)//' < z < '// - AUX2(1:NC2)//' cm, gap = '//AUX3(1:NC3)// - ' cm,'//AUX4(1:NC4) 120 CONTINUE ELSE WRITE(LUNOUT,'('' z-Strips: None'')') ENDIF *** Print data on the equipotential planes, first those at const x or r ELSEIF(YNPLAN(1).OR.YNPLAN(2).OR.YNPLAN(3).OR.YNPLAN(4))THEN WRITE(LUNOUT,'(/'' EQUIPOTENTIAL PLANES'')') IF(YNPLAN(1).AND.YNPLAN(2).AND..NOT.POLAR)WRITE(LUNOUT, - '(/'' There are two planes at constant x:'')') IF(YNPLAN(1).AND.YNPLAN(2).AND.POLAR)WRITE(LUNOUT, - '(/'' There are two planes at constant r:'')') IF(((YNPLAN(1).AND..NOT.YNPLAN(2)).OR.(YNPLAN(2).AND..NOT. - YNPLAN(1))).AND..NOT.POLAR)WRITE(LUNOUT, - '(/'' There is one plane at constant x:'')') IF(((YNPLAN(1).AND..NOT.YNPLAN(2)).OR.(YNPLAN(2).AND..NOT. - YNPLAN(1))).AND.POLAR)WRITE(LUNOUT, - '(/'' There is one plane at constant r:'')') DO 20 I=1,2 IF(.NOT.YNPLAN(I))GOTO 20 NCOUT=0 IF(POLAR)THEN CALL OUTFMT(EXP(COPLAN(I)),2,AUX1,NC1,'LEFT') OUTSTR(NCOUT+1:NCOUT+NC1+13)= - ' r = '//AUX1(1:NC1)//' cm,' NCOUT=NCOUT+NC1+13 ELSE CALL OUTFMT(COPLAN(I),2,AUX1,NC1,'LEFT') OUTSTR(NCOUT+1:NCOUT+NC1+13)= - ' x = '//AUX1(1:NC1)//' cm,' NCOUT=NCOUT+NC1+13 ENDIF IF(ABS(VTPLAN(I)).GT.1E-4)THEN CALL OUTFMT(VTPLAN(I),2,AUX1,NC1,'LEFT') OUTSTR(NCOUT+1:NCOUT+NC1+16)= - ' potential = '//AUX1(1:NC1)//' V,' NCOUT=NCOUT+NC1+16 ELSE OUTSTR(NCOUT+1:NCOUT+9)=' earthed,' NCOUT=NCOUT+9 ENDIF IF(PLATYP(I).NE.'?')THEN OUTSTR(NCOUT+1:NCOUT+11)=' label = '//PLATYP(I)//',' NCOUT=NCOUT+11 ELSE OUTSTR(NCOUT+1:NCOUT+13)=' not labeled,' NCOUT=NCOUT+13 ENDIF IF(NPSTR1(I).EQ.0.AND.NPSTR2(I).EQ.0)THEN OUTSTR(NCOUT+1:NCOUT+11)=' no strips.' NCOUT=NCOUT+11 ELSE OUTSTR(NCOUT+1:NCOUT+21)=' divided into strips:' NCOUT=NCOUT+21 ENDIF WRITE(LUNOUT,'(A)') OUTSTR(1:NCOUT) DO 70 J=1,NPSTR1(I) CALL OUTFMT(PLSTR1(I,J,3),2,AUX4,NC4,'LEFT') IF(PSLAB1(I,J).EQ.'?')THEN AUX5=' not labeled' NC5=12 ELSE AUX5=' label = '//PSLAB1(I,J) NC5=10 ENDIF IF(POLAR)THEN CALL OUTFMT(180*PLSTR1(I,J,1)/PI,2,AUX2,NC2,'LEFT') CALL OUTFMT(180*PLSTR1(I,J,2)/PI,2,AUX3,NC3,'LEFT') WRITE(LUNOUT,'(8X,A)') AUX2(1:NC2)//' < phi < '// - AUX3(1:NC3)//' degrees, gap = '//AUX4(1:NC4)// - ' cm,'//AUX5(1:NC5) ELSE CALL OUTFMT(PLSTR1(I,J,1),2,AUX2,NC2,'LEFT') CALL OUTFMT(PLSTR1(I,J,2),2,AUX3,NC3,'LEFT') WRITE(LUNOUT,'(8X,A)') AUX2(1:NC2)//' < y < '// - AUX3(1:NC3)//' cm, gap = '//AUX4(1:NC4)//' cm,'// - AUX5(1:NC5) ENDIF 70 CONTINUE DO 80 J=1,NPSTR2(I) CALL OUTFMT(PLSTR2(I,J,1),2,AUX2,NC2,'LEFT') CALL OUTFMT(PLSTR2(I,J,2),2,AUX3,NC3,'LEFT') CALL OUTFMT(PLSTR2(I,J,3),2,AUX4,NC4,'LEFT') IF(PSLAB2(I,J).EQ.'?')THEN AUX5=' not labeled' NC5=12 ELSE AUX5=' label = '//PSLAB2(I,J) NC5=10 ENDIF WRITE(LUNOUT,'(8X,A)') AUX2(1:NC2)//' < z < '// - AUX3(1:NC3)//' cm, gap = '//AUX4(1:NC4)//' cm,'// - AUX5(1:NC5) 80 CONTINUE 20 CONTINUE * Next the planes at constant y or phi IF(YNPLAN(3).AND.YNPLAN(4).AND..NOT.POLAR)WRITE(LUNOUT, - '(/'' There are two planes at constant y:'')') IF(YNPLAN(3).AND.YNPLAN(4).AND.POLAR)WRITE(LUNOUT, - '(/'' There are two planes at constant phi:'')') IF(((YNPLAN(3).AND..NOT.YNPLAN(4)).OR.(YNPLAN(4).AND..NOT. - YNPLAN(3))).AND..NOT.POLAR)WRITE(LUNOUT, - '(/'' There is one plane at constant y:'')') IF(((YNPLAN(3).AND..NOT.YNPLAN(4)).OR.(YNPLAN(4).AND..NOT. - YNPLAN(3))).AND.POLAR)WRITE(LUNOUT, - '(/'' There is one plane at constant phi:'')') DO 30 I=3,4 IF(.NOT.YNPLAN(I))GOTO 30 NCOUT=0 IF(POLAR)THEN CALL OUTFMT(180*COPLAN(I)/PI,2,AUX1,NC1,'LEFT') OUTSTR(NCOUT+1:NCOUT+NC1+20)= - ' phi = '//AUX1(1:NC1)//' degrees,' NCOUT=NCOUT+NC1+20 ELSE CALL OUTFMT(COPLAN(I),2,AUX1,NC1,'LEFT') OUTSTR(NCOUT+1:NCOUT+NC1+13)= - ' y = '//AUX1(1:NC1)//' cm,' NCOUT=NCOUT+NC1+13 ENDIF IF(ABS(VTPLAN(I)).GT.1E-4)THEN CALL OUTFMT(VTPLAN(I),2,AUX1,NC1,'LEFT') OUTSTR(NCOUT+1:NCOUT+NC1+16)= - ' potential = '//AUX1(1:NC1)//' V,' NCOUT=NCOUT+NC1+16 ELSE OUTSTR(NCOUT+1:NCOUT+9)=' earthed,' NCOUT=NCOUT+9 ENDIF IF(PLATYP(I).NE.'?')THEN OUTSTR(NCOUT+1:NCOUT+11)=' label = '//PLATYP(I)//',' NCOUT=NCOUT+11 ELSE OUTSTR(NCOUT+1:NCOUT+13)=' not labeled,' NCOUT=NCOUT+13 ENDIF IF(NPSTR1(I).EQ.0.AND.NPSTR2(I).EQ.0)THEN OUTSTR(NCOUT+1:NCOUT+11)=' no strips.' NCOUT=NCOUT+11 ELSE OUTSTR(NCOUT+1:NCOUT+21)=' divided into strips:' NCOUT=NCOUT+21 ENDIF WRITE(LUNOUT,'(A)') OUTSTR(1:NCOUT) DO 90 J=1,NPSTR1(I) CALL OUTFMT(PLSTR1(I,J,3),2,AUX4,NC4,'LEFT') IF(PSLAB1(I,J).EQ.'?')THEN AUX5=' not labeled' NC5=12 ELSE AUX5=' label = '//PSLAB1(I,J) NC5=10 ENDIF IF(POLAR)THEN CALL OUTFMT(EXP(PLSTR1(I,J,1)),2,AUX2,NC2,'LEFT') CALL OUTFMT(EXP(PLSTR1(I,J,2)),2,AUX3,NC3,'LEFT') WRITE(LUNOUT,'(8X,A)') AUX2(1:NC2)//' < r < '// - AUX3(1:NC3)//' cm, gap = '//AUX4(1:NC4)// - ' cm,'//AUX5(1:NC5) ELSE CALL OUTFMT(PLSTR1(I,J,1),2,AUX2,NC2,'LEFT') CALL OUTFMT(PLSTR1(I,J,2),2,AUX3,NC3,'LEFT') WRITE(LUNOUT,'(8X,A)') AUX2(1:NC2)//' < x < '// - AUX3(1:NC3)//' cm, gap = '//AUX4(1:NC4)//' cm,'// - AUX5(1:NC5) ENDIF 90 CONTINUE DO 100 J=1,NPSTR2(I) CALL OUTFMT(PLSTR2(I,J,1),2,AUX2,NC2,'LEFT') CALL OUTFMT(PLSTR2(I,J,2),2,AUX3,NC3,'LEFT') CALL OUTFMT(PLSTR2(I,J,3),2,AUX4,NC4,'LEFT') IF(PSLAB2(I,J).EQ.'?')THEN AUX5=' not labeled' NC5=12 ELSE AUX5=' label = '//PSLAB2(I,J) NC5=10 ENDIF WRITE(LUNOUT,'(8X,A)') AUX2(1:NC2)//' < z < '// - AUX3(1:NC3)//' cm, gap = '//AUX4(1:NC4)//' cm,'// - AUX5(1:NC5) 100 CONTINUE 30 CONTINUE ENDIF *** Print the type of periodicity, first header and x direction. IF(NMAP.LT.1)THEN WRITE(LUNOUT,'(/'' PERIODICITY'')') IF(PERX.AND.POLAR)THEN CALL OUTFMT(EXP(SX),2,AUX1,NC1,'LEFT') WRITE(LUNOUT,'(/'' The cell is repeated every '',A, - '' cm in r.'')') AUX1(1:NC1) ELSEIF(PERMX.AND.POLAR)THEN CALL OUTFMT(EXP(SX),2,AUX1,NC1,'LEFT') WRITE(LUNOUT,'(/'' The cell has mirror periodicity'', - '' in r with a length of '',A,'' cm.'')') - AUX1(1:NC1) ELSEIF(PERX)THEN CALL OUTFMT(SX,2,AUX1,NC1,'LEFT') WRITE(LUNOUT,'(/'' The cell is repeated every '',A, - '' cm in x.'')') AUX1(1:NC1) ELSEIF(PERMX)THEN CALL OUTFMT(SX,2,AUX1,NC1,'LEFT') WRITE(LUNOUT,'(/'' The cell has mirror periodicity'', - '' in x with a length of '',A,'' cm.'')') - AUX1(1:NC1) ELSEIF(POLAR)THEN WRITE(LUNOUT,'(/'' The cell is not periodic in r.'')') ELSE WRITE(LUNOUT,'(/'' The cell has no translation'', - '' periodicity in x.'')') ENDIF IF(PERAX)THEN CALL OUTFMT((XAMAX-XAMIN)*180/PI,2,AUX1,NC1,'LEFT') WRITE(LUNOUT,'('' The cell has axial periodicity'', - '' around x with a length of '',A, - '' degrees.'')') AUX1(1:NC1) ELSEIF(PERRX)THEN WRITE(LUNOUT,'('' The cell is rotationally'', - '' symmetric around the x-axis.'')') ELSE WRITE(LUNOUT,'('' The cell has no axial'', - '' periodicity around the x axis.'')') ENDIF * In y. IF(PERY.AND.(POLAR.OR.TUBE))THEN CALL OUTFMT(180*SY/PI,2,AUX1,NC1,'LEFT') WRITE(LUNOUT,'('' The cell is repeated in phi'', - '' every '',A,'' degrees.'')') AUX1(1:NC1) ELSEIF(PERMY.AND.(POLAR.OR.TUBE))THEN CALL OUTFMT(180*SY/PI,2,AUX1,NC1,'LEFT') WRITE(LUNOUT,'('' The cell has mirror periodicity'', - '' in phi with a length of '',A,'' degrees.'')') - AUX1(1:NC1) ELSEIF(PERY)THEN CALL OUTFMT(SY,2,AUX1,NC1,'LEFT') WRITE(LUNOUT,'('' The cell is repeated every '',A, - '' cm in y.'')') AUX1(1:NC1) ELSEIF(PERMY)THEN CALL OUTFMT(SY,2,AUX1,NC1,'LEFT') WRITE(LUNOUT,'('' The cell has mirror periodicity'', - '' in y with a length of '',A,'' cm.'')') - AUX1(1:NC1) ELSEIF(POLAR)THEN WRITE(LUNOUT,'('' The cell is not periodic in'', - '' phi.'')') ELSE WRITE(LUNOUT,'('' The cell has no translation'', - '' periodicity in y.'')') ENDIF IF(PERAY)THEN CALL OUTFMT((YAMAX-YAMIN)*180/PI,2,AUX1,NC1,'LEFT') WRITE(LUNOUT,'('' The cell has axial periodicity'', - '' around y with a length of '',A,'' degrees.'')') - AUX1(1:NC1) ELSEIF(PERRY)THEN WRITE(LUNOUT,'('' The cell is rotationally'', - '' symmetric around the y-axis.'')') ELSE WRITE(LUNOUT,'('' The cell has no axial'', - '' periodicity around the y axis.'')') ENDIF * In z. IF(PERZ)THEN CALL OUTFMT(SZ,2,AUX1,NC1,'LEFT') WRITE(LUNOUT,'('' The cell is repeated every '',A, - '' cm in z.'')') AUX1(1:NC1) ELSEIF(PERMZ)THEN CALL OUTFMT(SZ,2,AUX1,NC1,'LEFT') WRITE(LUNOUT,'('' The cell has mirror periodicity'', - '' in z with a length of '',A,'' cm.'')') - AUX1(1:NC1) ELSE WRITE(LUNOUT,'('' The cell has no translation'', - '' periodicity in z.'')') ENDIF IF(PERAZ)THEN CALL OUTFMT((ZAMAX-ZAMIN)*180/PI,2,AUX1,NC1,'LEFT') WRITE(LUNOUT,'('' The cell has axial periodicity'', - '' around z with a length of '',A,'' degrees.'')') - AUX1(1:NC1) ELSEIF(PERRZ)THEN WRITE(LUNOUT,'('' The cell is rotationally'', - '' symmetric around the z-axis.'')') ELSE WRITE(LUNOUT,'('' The cell has no axial'', - '' periodicity around the z axis.'')') ENDIF ENDIF *** List the dielectrica. IF(NXMATT.NE.0.OR.NYMATT.NE.0)THEN WRITE(LUNOUT,'(/'' LIST OF DIELECTRICA''// - '' Direction From To Epsilon''/ - '' [cm] [cm] [relative]''/ - )') DO 50 I=1,NXMATT IF(XMATT(I,3).NE.0)THEN AUX1=' -infinity' ELSE CALL OUTFMT(XMATT(I,1),2,AUX1,NCAUX,'RIGHT') ENDIF IF(XMATT(I,4).NE.0)THEN AUX2=' +infinity' ELSE CALL OUTFMT(XMATT(I,2),2,AUX2,NCAUX,'RIGHT') ENDIF CALL OUTFMT(XMATT(I,5),2,AUX3,NCAUX,'RIGHT') WRITE(LUNOUT,'(10X,A1,A13,1X,A13,1X,A13)') - 'x',AUX1,AUX2,AUX3 50 CONTINUE DO 60 I=1,NYMATT IF(YMATT(I,3).NE.0)THEN AUX1=' -infinity' ELSE CALL OUTFMT(YMATT(I,1),2,AUX1,NCAUX,'RIGHT') ENDIF IF(YMATT(I,4).NE.0)THEN AUX2=' +infinity' ELSE CALL OUTFMT(YMATT(I,2),2,AUX2,NCAUX,'RIGHT') ENDIF CALL OUTFMT(YMATT(I,5),2,AUX3,NCAUX,'RIGHT') WRITE(LUNOUT,'(10X,A1,A13,1X,A13,1X,A13)') - 'y',AUX1,AUX2,AUX3 60 CONTINUE ENDIF *** Print cell size, type and various other things. WRITE(LUNOUT,'(/'' OTHER DATA'')') CALL OUTFMT(DOWN(1),2,AUX1,NC1,'LEFT') CALL OUTFMT(DOWN(2),2,AUX2,NC2,'LEFT') CALL OUTFMT(DOWN(3),2,AUX3,NC3,'LEFT') WRITE(LUNOUT,'(/'' Gravity vector: ('',A,'','',A,'','',A, - '') g.'')') AUX1(1:NC1),AUX2(1:NC2),AUX3(1:NC3) CALL OUTFMT(VMIN,2,AUX7,NC7,'RIGHT') CALL OUTFMT(VMAX,2,AUX8,NC8,'LEFT') IF(.NOT.POLAR)THEN CALL OUTFMT(XMIN,2,AUX1,NC1,'RIGHT') CALL OUTFMT(XMAX,2,AUX2,NC2,'LEFT') CALL OUTFMT(YMIN,2,AUX3,NC3,'RIGHT') CALL OUTFMT(YMAX,2,AUX4,NC4,'LEFT') CALL OUTFMT(ZMIN,2,AUX5,NC5,'RIGHT') CALL OUTFMT(ZMAX,2,AUX6,NC6,'LEFT') LMIN=LEN(AUX1)-MAX(NC1,NC3,NC5,NC7)+1 RMAX=MAX(NC2,NC4,NC6,NC8) WRITE(LUNOUT,'(/'' Cell dimensions: '', - A,'' < x < '',A,'' cm,''/19X, - A,'' < y < '',A,'' cm,''/19X, - A,'' < z < '',A,'' cm.''// - '' Potential range: '', - A,'' < V < '',A,'' V.'')') - AUX1(LMIN:),AUX2(1:RMAX),AUX3(LMIN:),AUX4(1:RMAX), - AUX5(LMIN:),AUX6(1:RMAX),AUX7(LMIN:),AUX8(1:RMAX) ELSE CALL CFMRTP(XMIN,YMIN,XMINP,YMINP,1) CALL CFMRTP(XMAX,YMAX,XMAXP,YMAXP,1) CALL OUTFMT(XMINP,2,AUX1,NC1,'RIGHT') CALL OUTFMT(XMAXP,2,AUX2,NC2,'LEFT') CALL OUTFMT(YMINP,2,AUX3,NC3,'RIGHT') CALL OUTFMT(YMAXP,2,AUX4,NC4,'LEFT') CALL OUTFMT(ZMIN,2,AUX5,NC5,'RIGHT') CALL OUTFMT(ZMAX,2,AUX6,NC6,'LEFT') LMIN=LEN(AUX1)-MAX(NC1,NC3,NC5,NC7)+1 RMAX=MAX(NC2,NC4,NC6,NC8) WRITE(LUNOUT,'(/'' Cell dimensions: '', - A,'' < r < '',A,'' cm,''/19X, - A,'' < phi < '',A,'' degrees,''/19X, - A,'' < z < '',A,'' cm.''// - '' Potential range: '', - A,'' < V < '',A,'' V.'')') - AUX1(LMIN:),AUX2(1:RMAX),AUX3(LMIN:),AUX4(1:RMAX), - AUX5(LMIN:),AUX6(1:RMAX),AUX7(LMIN:),AUX8(1:RMAX) ENDIF WRITE(LUNOUT,'(/'' The cell is of type '',A3,'' (code '',I2, - '', details can be found in the writeup.)'')') TYPE,ICTYPE * Print voltage shift in case no equipotential planes are present, IF(.NOT.(YNPLAN(1).OR.YNPLAN(2).OR. - YNPLAN(3).OR.YNPLAN(4).OR.TUBE))THEN CALL OUTFMT(V0,2,AUX1,NC1,'LEFT') WRITE(LUNOUT,'(/'' All voltages have been shifted by '', - A,'' V to avoid net wire charge.'')') AUX1(1:NC1) ELSE * else print the net charge on the wires. SUMCH=0.0 DO 40 I=1,NWIRE SUMCH=SUMCH+E(I) 40 CONTINUE CALL OUTFMT(2.0E12*PI*EPS0*SUMCH,2,AUX1,NC1,'LEFT') WRITE(LUNOUT,'(/'' The net charge on the wires is '',A, - '' pC/cm.'')') AUX1(1:NC1) ENDIF *** Register the amount of CPU time used. CALL TIMLOG('Printing the cell properties: ') END +DECK,CELTYP. SUBROUTINE CELTYP *----------------------------------------------------------------------- * CELTYP - Determines the cell type, see the writeup for explanations. * VARIABLES : no local variables. * (Last changed on 20/ 1/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,CONSTANTS. CHARACTER*10 USER INTEGER IFAIL *** Identify field maps. CALL BOOK('INQUIRE','MAP',USER,IFAIL) * Unable to tell: assume this isn't a field map. IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! CELTYP WARNING : Unable to obtain'// - ' field map allocation information ; assumed to'// - ' be a non-field map cell.' * Field map chamber: ensure that there are no other elements. ELSEIF(USER.EQ.'CELL')THEN TYPE='MAP' GOTO 10 ENDIF *** Provisionally handle all TUBE type cells via D00. IF(TUBE)THEN IF(NTUBE.EQ.0)THEN IF(PERY)THEN TYPE='D2 ' ELSE TYPE='D1 ' ENDIF ELSEIF(NTUBE.GE.3.AND.NTUBE.LE.8)THEN IF(PERY)THEN TYPE='D4 ' ELSE TYPE='D3 ' ENDIF ELSE PRINT *,' !!!!!! CELTYP WARNING : Potentials not yet'// - ' available, using a round tube.' NTUBE=0 TYPE='D3 ' ENDIF GOTO 10 ENDIF *** Find the 'A' type cell. IF(.NOT.(PERX.OR.PERY).AND. - .NOT.(YNPLAN(1).AND.YNPLAN(2)).AND. - .NOT.(YNPLAN(3).AND.YNPLAN(4)))THEN TYPE='A ' GOTO 10 ENDIF *** Find the 'B1X' type cell. IF(PERX.AND..NOT.PERY.AND. - .NOT.(YNPLAN(1).OR.YNPLAN(2)).AND. - .NOT.(YNPLAN(3).AND.YNPLAN(4)))THEN TYPE='B1X' GOTO 10 ENDIF *** Find the 'B1Y' type cell. IF(PERY.AND..NOT.PERX.AND. - .NOT.(YNPLAN(1).AND.YNPLAN(2)).AND. - .NOT.(YNPLAN(3).OR.YNPLAN(4)))THEN TYPE='B1Y' GOTO 10 ENDIF *** Find the 'B2X' type cell. IF(PERX.AND..NOT.PERY.AND. - .NOT.(YNPLAN(3).AND.YNPLAN(4)))THEN TYPE='B2X' GOTO 10 ENDIF IF(.NOT.(PERX.OR.PERY).AND. - .NOT.(YNPLAN(3).AND.YNPLAN(4)).AND. - (YNPLAN(1).AND.YNPLAN(2)))THEN SX=ABS(COPLAN(2)-COPLAN(1)) TYPE='B2X' GOTO 10 ENDIF *** Find the 'B2Y' type cell. IF(PERY.AND..NOT.PERX.AND. - .NOT.(YNPLAN(1).AND.YNPLAN(2)))THEN TYPE='B2Y' GOTO 10 ENDIF IF(.NOT.(PERX.OR.PERY).AND. - .NOT.(YNPLAN(1).AND.YNPLAN(2)).AND. - (YNPLAN(3).AND.YNPLAN(4)))THEN SY=ABS(COPLAN(4)-COPLAN(3)) TYPE='B2Y' GOTO 10 ENDIF *** Find the 'C1 ' type cell. IF(.NOT.(YNPLAN(1).OR.YNPLAN(2).OR.YNPLAN(3).OR.YNPLAN(4)).AND. - PERX.AND.PERY)THEN TYPE='C1 ' GOTO 10 ENDIF *** Find the 'C2X' type cell. IF(.NOT.((YNPLAN(3).AND.PERY).OR.(YNPLAN(3).AND.YNPLAN(4))))THEN IF(YNPLAN(1).AND.YNPLAN(2))THEN SX=ABS(COPLAN(2)-COPLAN(1)) TYPE='C2X' GOTO 10 ENDIF IF(PERX.AND.YNPLAN(1))THEN TYPE='C2X' GOTO 10 ENDIF ENDIF *** Find the 'C2Y' type cell. IF(.NOT.((YNPLAN(1).AND.PERX).OR.(YNPLAN(1).AND.YNPLAN(2))))THEN IF(YNPLAN(3).AND.YNPLAN(4))THEN SY=ABS(COPLAN(4)-COPLAN(3)) TYPE='C2Y' GOTO 10 ENDIF IF(PERY.AND.YNPLAN(3))THEN TYPE='C2Y' GOTO 10 ENDIF ENDIF *** Find the 'C3 ' type cell. IF(PERX.AND.PERY)THEN TYPE='C3 ' GOTO 10 ENDIF IF(PERX)THEN TYPE='C3 ' SY=ABS(COPLAN(4)-COPLAN(3)) GOTO 10 ENDIF IF(PERY)THEN TYPE='C3 ' SX=ABS(COPLAN(2)-COPLAN(1)) GOTO 10 ENDIF IF(YNPLAN(1).AND.YNPLAN(2).AND.YNPLAN(3).AND.YNPLAN(4))THEN TYPE='C3 ' SX=ABS(COPLAN(2)-COPLAN(1)) SY=ABS(COPLAN(4)-COPLAN(3)) GOTO 10 ENDIF *** Fatal error if the cell is not recognised. PRINT *,' ###### CELTYP ERROR : Cell type not recognised ;', - ' fatal program bug - please send a message.' CALL QUIT 10 CONTINUE *** Make sure the periodicities are positive numbers. SX=ABS(SX) SY=ABS(SY) *** Store a numerical code for the cell type for greater efficiency. IF(TYPE.EQ.'MAP')ICTYPE=0 IF(TYPE.EQ.'A ')ICTYPE=1 IF(TYPE.EQ.'B1X')ICTYPE=2 IF(TYPE.EQ.'B1Y')ICTYPE=3 IF(TYPE.EQ.'B2X')ICTYPE=4 IF(TYPE.EQ.'B2Y')ICTYPE=5 IF(TYPE.EQ.'C1 ')ICTYPE=6 IF(TYPE.EQ.'C2X')ICTYPE=7 IF(TYPE.EQ.'C2Y')ICTYPE=8 IF(TYPE.EQ.'C3 ')ICTYPE=9 IF(TYPE.EQ.'D1 ')ICTYPE=10 IF(TYPE.EQ.'D2 ')ICTYPE=11 IF(TYPE.EQ.'D3 ')ICTYPE=12 IF(TYPE.EQ.'D4 ')ICTYPE=13 *** Store the amount of CPU time used for cell identification. CALL TIMLOG('Finding the cell type (A, B1X etc): ') END +DECK,CELVIE. SUBROUTINE CELVIE(QXMIN,QYMIN,QZMIN,QXMAX,QYMAX,QZMAX) *----------------------------------------------------------------------- * CELVIE - Establishes viewing angles for the chamber. * (Last changed on 30/11/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,PRINTPLOT. +SEQ,PARAMETERS. +SEQ,CONSTANTS. +SEQ,SOLIDS. +SEQ,FIELDMAP. CHARACTER*(MXCHAR) STRING,STRAUX CHARACTER*13 AUX1,AUX2,AUX3,AUX4,AUX5,AUX6 CHARACTER*10 VARLIS(MXVAR) INTEGER MODVAR(MXVAR),MODRES(1),NCAUX,NRES,IENTRY,I,J,K,NWORD,NC, - IFAIL,IFAIL1,IFAIL2,IFAIL3,IFAIL4,IFAIL5,IFAIL6,NCOLR, - INEXT,INPCMP,IEQ,IREF,IVOL,IERR,ICOL,NC1,NC2,NC3,NC4,NC5,NC6 REAL VAR(MXVAR),RES(1),FRES(3,3,3),FXR,FYR,FZR,FNORM,AUXU(3), - AUXV(3),REFR,ABSR, - QXMIN,QYMIN,QZMIN,QXMAX,QYMAX,QZMAX, - QXMIND,QYMIND,QZMIND,QXMAXD,QYMAXD,QZMAXD, - QXMINR,QYMINR,QZMINR,QXMAXR,QYMAXR,QZMAXR DOUBLE PRECISION XPL(MXEDGE),YPL(MXEDGE),ZPL(MXEDGE),DET, - XAUX,YAUX,ZAUX LOGICAL USE(MXVAR),OK,FLAG(MXWORD+6),VIEW,PROJEC EXTERNAL INPCMP *** Find current number of arguments. CALL INPNUM(NWORD) *** Set default AREA parameters, in a format useful for printing. QXMIND=QXMIN QYMIND=QYMIN QZMIND=QZMIN QXMAXD=QXMAX QYMAXD=QYMAX QZMAXD=QZMAX IF(POLAR)CALL CFMRTP(QXMIND,QYMIND,QXMIND,QYMIND,1) IF(POLAR)CALL CFMRTP(QXMAXD,QYMAXD,QXMAXD,QYMAXD,1) *** Show current matrix if no arguments are given. IF(NWORD.EQ.1)THEN IF(LDEBUG)THEN WRITE(LUNOUT,'('' In-plane vector of current view: '', - 3E12.5)') (FPROJ(3,I),I=1,3) WRITE(LUNOUT,'('' u-vector in current view plane: '', - 3E12.5)') (FPROJ(1,I),I=1,3) WRITE(LUNOUT,'('' v-vector in current view plane: '', - 3E12.5)') (FPROJ(2,I),I=1,3) ENDIF CALL OUTFMT(QXMIND,2,AUX1,NC1,'RIGHT') CALL OUTFMT(QXMAXD,2,AUX2,NC2,'LEFT') CALL OUTFMT(QYMIND,2,AUX3,NC3,'RIGHT') CALL OUTFMT(QYMAXD,2,AUX4,NC4,'LEFT') CALL OUTFMT(QZMIND,2,AUX5,NC5,'RIGHT') CALL OUTFMT(QZMAXD,2,AUX6,NC6,'LEFT') IF(POLAR)THEN WRITE(LUNOUT,'('' The current area is '', - A13,'' < r < '',A13/22X, - A13,'' < phi < '',A13/ - '' [in cm and degrees] '', - A13,'' < z < '',A13)') - AUX1,AUX2,AUX3,AUX4,AUX5,AUX6 ELSE WRITE(LUNOUT,'('' The current area is '', - A13,'' < x < '',A13/22X, - A13,'' < y < '',A13/ - '' [in cm] '', - A13,'' < z < '',A13)') - AUX1,AUX2,AUX3,AUX4,AUX5,AUX6 ENDIF CALL OUTFMT(PROROT*180/PI,2,AUX1,NC1,'LEFT') WRITE(LUNOUT,'(/'' Current view plane: '',A,'' rotated '', - A,'' degrees''/'' Coordinate axes: u = '',A,'', '', - ''v = '',A)') PROLAB(1:NCFPRO),AUX1(1:NC1), - PXLAB(1:MAX(1,NCXLAB-10)),PYLAB(1:MAX(1,NCYLAB-10)) IF(PRVIEW.EQ.'X-Y')THEN WRITE(LUNOUT,'('' Plots show the x-y plane.'')') ELSEIF(PRVIEW.EQ.'X-Z')THEN WRITE(LUNOUT,'('' Plots show the x-z plane.'')') ELSEIF(PRVIEW.EQ.'Y-Z')THEN WRITE(LUNOUT,'('' Plots show the y-z plane.'')') ELSEIF(PRVIEW.EQ.'R-PHI')THEN WRITE(LUNOUT,'('' Plots show the r-phi plane.'')') ELSEIF(PRVIEW.EQ.'CUT')THEN WRITE(LUNOUT,'( - '' Plots show a cut at the above plane.'')') ELSEIF(PRVIEW.EQ.'3D')THEN WRITE(LUNOUT,'('' Plots show a 3D impression.'')') ELSE WRITE(LUNOUT,'('' ##### Unknown projection '', - A,''.'')') PRVIEW ENDIF CALL OUTFMT(PRPHIL*180/PI,2,AUX1,NC1,'LEFT') CALL OUTFMT(PRTHL*180/PI,2,AUX2,NC2,'LEFT') WRITE(LUNOUT,'(/'' Light source placed at phi = '',A, - '', theta = '',A,'' degrees,'')') - AUX1(1:NC1),AUX2(1:NC2) CALL OUTFMT((1-PRFABS)*PRFREF*100,2,AUX1,NC1,'LEFT') CALL OUTFMT((1-PRFABS)*(1-PRFREF)*100,2,AUX2,NC2,'LEFT') CALL OUTFMT(PRFABS*100,2,AUX3,NC3,'LEFT') WRITE(LUNOUT,'('' Of the light, '',A,'' % is absorbed, '', - A,'' % reflected and '',A,'' % diffused.'')') - AUX3(1:NC3),AUX1(1:NC1),AUX2(1:NC2) RETURN ENDIF *** First flag the keywords. DO 50 I=2,NWORD+6 IF(INPCMP(I,'ROT#ATE')+INPCMP(I,'ROT#ATION-#ANGLE')+ - INPCMP(I,'X-Y')+INPCMP(I,'X-Z')+INPCMP(I,'Y-Z')+ - INPCMP(I,'R-PHI')+INPCMP(I,'CUT')+INPCMP(I,'3D')+ - INPCMP(I,'V#IEW')+INPCMP(I,'PL#ANE')+ - INPCMP(I,'LIGHT-#ORIGIN')+ - INPCMP(I,'REFL#ECTED-#FRACTION')+ - INPCMP(I,'ABS#ORBED-#FRACTION')+ - INPCMP(I,'COL#OURS')+ - INPCMP(I,'FULL-B#OX-#TICKMARKS')+ - INPCMP(I,'PART#IAL-B#OX-#TICKMARKS')+ - INPCMP(I,'FULL-T#UBE')+INPCMP(I,'PART#IAL-T#UBE')+ - INPCMP(I,'FULL-P#LANES')+INPCMP(I,'PART#IAL-P#LANES')+ - INPCMP(I,'SPL#IT-#INTERSECTING-#PLANES')+ - INPCMP(I,'NOSPL#IT-#INTERSECTING-#PLANES')+ - INPCMP(I,'SORT-#PLANES')+INPCMP(I,'NOSORT-#PLANES')+ - INPCMP(I,'OUT#LINE')+INPCMP(I,'NOOUT#LINE')+ - INPCMP(I,'PL#OT-MAP')+INPCMP(I,'NOPL#OT-MAP').NE.0)THEN FLAG(I)=.TRUE. ELSEIF(I.EQ.1.OR.I.GT.NWORD)THEN FLAG(I)=.TRUE. ELSE FLAG(I)=.FALSE. ENDIF 50 CONTINUE *** Get the area component, if specified. IF(NWORD.GE.7.AND..NOT.(FLAG(2).OR.FLAG(3).OR.FLAG(4).OR. - FLAG(5).OR.FLAG(6).OR.FLAG(7)))THEN CALL INPCHK(2,2,IFAIL1) CALL INPCHK(3,2,IFAIL2) CALL INPCHK(4,2,IFAIL3) CALL INPCHK(5,2,IFAIL4) CALL INPCHK(6,2,IFAIL5) CALL INPCHK(7,2,IFAIL6) CALL INPRDR(2,QXMINR,QXMIND) CALL INPRDR(3,QYMINR,QYMIND) CALL INPRDR(4,QZMINR,QZMIND) CALL INPRDR(5,QXMAXR,QXMAXD) CALL INPRDR(6,QYMAXR,QYMAXD) CALL INPRDR(7,QZMAXR,QZMAXD) INEXT=8 IF(IFAIL1.NE.0.OR.IFAIL2.NE.0.OR.IFAIL3.NE.0.OR. - IFAIL4.NE.0.OR.IFAIL5.NE.0.OR.IFAIL6.NE.0)THEN PRINT *,' !!!!!! CELVIE WARNING : AREA part', - ' ignored because of syntax errors.' GOTO 40 ENDIF ELSEIF(NWORD.GE.5.AND..NOT.(FLAG(2).OR.FLAG(3).OR.FLAG(4).OR. - FLAG(5)))THEN CALL INPCHK(2,2,IFAIL1) CALL INPCHK(3,2,IFAIL2) CALL INPCHK(4,2,IFAIL3) CALL INPCHK(5,2,IFAIL4) CALL INPRDR(2,QXMINR,QXMIND) CALL INPRDR(3,QYMINR,QYMIND) CALL INPRDR(4,QXMAXR,QXMAXD) CALL INPRDR(5,QYMAXR,QYMAXD) QZMINR=QZMIND QZMAXR=QZMAXD INEXT=6 IF(IFAIL1.NE.0.OR.IFAIL2.NE.0.OR. - IFAIL3.NE.0.OR.IFAIL4.NE.0)THEN PRINT *,' !!!!!! CELVIE WARNING : AREA part'// - ' ignored because of syntax errors.' GOTO 40 ENDIF ELSE INEXT=2 GOTO 40 ENDIF * Convert polar boundaries to internal coordinates. IFAIL1=0 IFAIL2=0 IF(POLAR)THEN CALL CFMPTR(QXMINR,QYMINR,QXMINR,QYMINR,1,IFAIL1) CALL CFMPTR(QXMAXR,QYMAXR,QXMAXR,QYMAXR,1,IFAIL2) ENDIF * Perform some elementary checks on these bounds. IF(IFAIL1.NE.0.OR.IFAIL2.NE.0)THEN PRINT *,' !!!!!! CELVIE WARNING : Incorrect area in'// - ' polar coordinates specified ; AREA is ignored.' ELSE IF(QXMINR.EQ.QXMAXR)THEN PRINT *,' !!!!!! CELVIE WARNING : Zero range'// - ' not permitted; x or r-part ignored.' ELSE QXMIN=MIN(QXMINR,QXMAXR) QXMAX=MAX(QXMINR,QXMAXR) ENDIF IF(QYMINR.EQ.QYMAXR)THEN PRINT *,' !!!!!! CELVIE WARNING : Zero range'// - ' not permitted; y or phi-part ignored.' ELSE QYMIN=MIN(QYMINR,QYMAXR) QYMAX=MAX(QYMINR,QYMAXR) ENDIF ENDIF IF(QZMINR.EQ.QZMAXR)THEN PRINT *,' !!!!!! CELVIE WARNING : Zero range'// - ' not permitted; z-part ignored.' ELSE QZMIN=MIN(QZMINR,QZMAXR) QZMAX=MAX(QZMINR,QZMAXR) ENDIF * Assign them to the graphics area. GXMIN=QXMIN GYMIN=QYMIN GZMIN=QZMIN GXMAX=QXMAX GYMAX=QYMAX GZMAX=QZMAX *** Get the other options. 40 CONTINUE *** Default options. VIEW=.FALSE. PROJEC=.FALSE. *** Search for further arguments. DO 10 I=2,NWORD IF(I.LT.INEXT)GOTO 10 ** Viewing plane. IF(INPCMP(I,'V#IEW')+INPCMP(I,'PL#ANE').NE.0)THEN * Ensure a definition is present. IF(FLAG(I+1))THEN CALL INPMSG(I,'Plane is missing.') GOTO 10 ENDIF * Check the format. CALL INPSTR(I+1,I+1,STRING,NC) IF(INDEX(STRING(1:NC),'=').EQ.0.AND.I+2.GT.NWORD)THEN CALL INPMSG(I+1,'Incomplete formula.') VIEW=.FALSE. ELSEIF(INDEX(STRING(1:NC),'=').EQ.0)THEN CALL INPSTR(I+1,I+2,STRING,NC) INEXT=I+3 VIEW=.TRUE. ELSE INEXT=I+2 VIEW=.TRUE. ENDIF IEQ=INDEX(STRING(1:NC),'=') IF(IEQ.EQ.0.OR.IEQ.GE.LEN(STRING).OR.IEQ.GE.NC)THEN CALL INPMSG(I+1,'= sign missing or misplaced.') VIEW=.FALSE. ENDIF * Replace the "=" sign. IF(VIEW)THEN STRAUX=STRING(IEQ+1:) NCAUX=NC-IEQ STRING(IEQ:)='-('//STRAUX(1:NCAUX)//')' NC=IEQ+NCAUX+2 ENDIF * Reset the rotation. PROROT=0 ** Rotation of the local coordinate frame. ELSEIF(INPCMP(I,'ROT#ATE')+ - INPCMP(I,'ROT#ATION-#ANGLE').NE.0)THEN IF(NWORD.LT.I+1)THEN CALL INPMSG(I,'Argument missing.') ELSE CALL INPCHK(I+1,2,IFAIL) IF(IFAIL.EQ.0)THEN CALL INPRDR(I+1,PROROT,0.0) PROROT=PI*PROROT/180 ENDIF INEXT=I+2 ENDIF ** Traditional x-y, x-z, y-z and r-phi plots. ELSEIF(INPCMP(I,'X-Y').NE.0)THEN IF(POLAR)THEN CALL INPMSG(I,'The cell is polar.') ELSE PRVIEW='X-Y' PROJEC=.TRUE. FPROJ(1,1)=1 FPROJ(1,2)=0 FPROJ(1,3)=0 FPROJ(2,1)=0 FPROJ(2,2)=1 FPROJ(2,3)=0 FPROJ(3,1)=0 FPROJ(3,2)=0 FPROJ(3,3)=0 PXLAB='x-Axis [cm]' NCXLAB=11 PYLAB='y-Axis [cm]' NCYLAB=11 PROLAB='x-y' NCFPRO=3 FPROJA=0 FPROJB=0 FPROJC=1 FPROJD=0 FPROJN=1 PROROT=0 ENDIF ELSEIF(INPCMP(I,'X-Z').NE.0)THEN IF(POLAR)THEN CALL INPMSG(I,'The cell is polar.') ELSE PRVIEW='X-Z' PROJEC=.TRUE. FPROJ(1,1)=1 FPROJ(1,2)=0 FPROJ(1,3)=0 FPROJ(2,1)=0 FPROJ(2,2)=0 FPROJ(2,3)=1 FPROJ(3,1)=0 FPROJ(3,2)=0 FPROJ(3,3)=0 PXLAB='x-Axis [cm]' NCXLAB=11 PYLAB='z-Axis [cm]' NCYLAB=11 PROLAB='x-z' NCFPRO=3 FPROJA=0 FPROJB=1 FPROJC=0 FPROJD=0 FPROJN=1 PROROT=0 ENDIF ELSEIF(INPCMP(I,'Y-Z').NE.0)THEN IF(POLAR)THEN CALL INPMSG(I,'The cell is polar.') ELSE PRVIEW='Y-Z' PROJEC=.TRUE. FPROJ(1,1)=0 FPROJ(1,2)=1 FPROJ(1,3)=0 FPROJ(2,1)=0 FPROJ(2,2)=0 FPROJ(2,3)=1 FPROJ(3,1)=0 FPROJ(3,2)=0 FPROJ(3,3)=0 PXLAB='y-Axis [cm]' NCXLAB=11 PYLAB='z-Axis [cm]' NCYLAB=11 PROLAB='y-z' NCFPRO=3 FPROJA=1 FPROJB=0 FPROJC=0 FPROJD=0 FPROJN=1 PROROT=0 ENDIF ELSEIF(INPCMP(I,'R-PHI').NE.0)THEN IF(POLAR)THEN PRVIEW='R-PHI' PROJEC=.TRUE. FPROJ(1,1)=1 FPROJ(1,2)=0 FPROJ(1,3)=0 FPROJ(2,1)=0 FPROJ(2,2)=1 FPROJ(2,3)=0 FPROJ(3,1)=0 FPROJ(3,2)=0 FPROJ(3,3)=0 PXLAB='r-Axis [cm]' NCXLAB=11 PYLAB='phi-Axis [degrees]' NCYLAB=18 PROLAB='r-phi' NCFPRO=5 FPROJA=0 FPROJB=0 FPROJC=1 FPROJD=0 FPROJN=1 PROROT=0 ELSE CALL INPMSG(I,'The cell is not polar') ENDIF ** Plot as a cut. ELSEIF(INPCMP(I,'CUT').NE.0)THEN IF(POLAR)THEN CALL INPMSG(I,'The cell is polar.') ELSE PRVIEW='CUT' PROJEC=.TRUE. ENDIF ** Plot in 3D. ELSEIF(INPCMP(I,'3D').NE.0)THEN IF(POLAR)THEN CALL INPMSG(I,'The cell is polar.') ELSE PRVIEW='3D' PROJEC=.TRUE. ENDIF ** Set the light origin relative to the normal vector. ELSEIF(INPCMP(I,'LIGHT-#ORIGIN').NE.0)THEN IF(NWORD.LT.I+2)THEN CALL INPMSG(I,'Arguments missing.') ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPCHK(I+2,2,IFAIL2) CALL INPRDR(I+1,PRPHIL,0.0) CALL INPRDR(I+2,PRTHL,30.0) PRPHIL=PRPHIL*PI/180.0 PRTHL=PRTHL*PI/180.0 INEXT=I+3 ENDIF ** Set the reflection component. ELSEIF(INPCMP(I,'REFL#ECTED-#FRACTION').NE.0)THEN IF(NWORD.LT.I+1)THEN CALL INPMSG(I,'Arguments missing.') ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,REFR,PRFREF*100) IF(REFR.LT.0.OR.REFR.GT.100)THEN CALL INPMSG(I+1,'Fraction out of range [0,100].') ELSE PRFREF=REFR/100 ENDIF INEXT=I+2 ENDIF ** Set the absorbed component. ELSEIF(INPCMP(I,'ABS#ORBED-#FRACTION').NE.0)THEN IF(NWORD.LT.I+1)THEN CALL INPMSG(I,'Arguments missing.') ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,ABSR,PRFABS*100) IF(ABSR.LT.0.OR.ABSR.GT.100)THEN CALL INPMSG(I+1,'Fraction out of range [0,100].') ELSE PRFABS=ABSR/100 ENDIF INEXT=I+2 ENDIF ** Set the number of colours in the shading tables. ELSEIF(INPCMP(I,'COL#OURS').NE.0)THEN IF(NWORD.LT.I+1)THEN CALL INPMSG(I,'Arguments missing.') ELSE CALL INPCHK(I+1,1,IFAIL1) CALL INPRDI(I+1,NCOLR,NPRCOL) IF(NCOLR.LE.1)THEN CALL INPMSG(I+1,'Number of colours < 2.') ELSE NPRCOL=NCOLR ENDIF INEXT=I+2 ENDIF ** Draw full boxes, tube and planes or not. ELSEIF(INPCMP(I,'FULL-B#OX-#TICKMARKS').NE.0)THEN LFULLB=.TRUE. ELSEIF(INPCMP(I,'PART#IAL-B#OX-#TICKMARKS').NE.0)THEN LFULLB=.FALSE. ELSEIF(INPCMP(I,'FULL-T#UBE').NE.0)THEN LFULLT=.TRUE. ELSEIF(INPCMP(I,'PART#IAL-T#UBE').NE.0)THEN LFULLT=.FALSE. ELSEIF(INPCMP(I,'FULL-P#LANES').NE.0)THEN LFULLP=.TRUE. ELSEIF(INPCMP(I,'PART#IAL-P#LANES').NE.0)THEN LFULLP=.FALSE. ELSEIF(INPCMP(I,'SPL#IT-#INTERSECTING-#PLANES').NE.0)THEN LSPLIT=.TRUE. ELSEIF(INPCMP(I,'NOSPL#IT-#INTERSECTING-#PLANES').NE.0)THEN LSPLIT=.FALSE. ELSEIF(INPCMP(I,'SORT-#PLANES').NE.0)THEN LSORT=.TRUE. ELSEIF(INPCMP(I,'NOSORT-#PLANES').NE.0)THEN LSORT=.FALSE. ELSEIF(INPCMP(I,'OUT#LINE').NE.0)THEN LOUTL=.TRUE. ELSEIF(INPCMP(I,'NOOUT#LINE').NE.0)THEN LOUTL=.FALSE. ELSEIF(INPCMP(I,'PL#OT-MAP').NE.0)THEN LMAPPL=.TRUE. ELSEIF(INPCMP(I,'NOPL#OT-MAP').NE.0)THEN LMAPPL=.FALSE. ELSEIF(INPCMP(I,'STEP').NE.0)THEN LGSTEP=.TRUE. ELSEIF(INPCMP(I,'NOSTEP').NE.0)THEN LGSTEP=.FALSE. * Other keywords not known. ELSE CALL INPMSG(I,'Not a known option.') ENDIF 10 CONTINUE *** R-PHI projection always and only in polar cells. IF(POLAR.AND.PRVIEW.NE.'R-PHI')THEN PRINT *,' !!!!!! CELVIE WARNING : Only the r-phi view is'// - ' available in polar cells; VIEW ignored.' RETURN ELSEIF(.NOT.POLAR.AND.PRVIEW.EQ.'R-PHI')THEN PRINT *,' !!!!!! CELVIE WARNING : The r-phi view is'// - ' only available in polar cells; VIEW ignored.' RETURN ENDIF *** Set a projection if not explicitely done. IF(VIEW.AND.(.NOT.PROJEC).AND.(PRVIEW.NE.'3D'))PRVIEW='CUT' *** Progress printing. IF(PRVIEW.EQ.'3D'.OR.PRVIEW.EQ.'CUT')CALL PROINT('AREA',1,6) *** If no formula was given, skip most of the rest. IF(.NOT.VIEW)GOTO 1000 IF(PRVIEW.EQ.'3D'.OR.PRVIEW.EQ.'CUT')THEN CALL PROFLD(1,'Processing formula',-1.0) CALL PROSTA(1,0.0) ENDIF *** Translate the formula. VARLIS(1)='X' VARLIS(2)='Y' VARLIS(3)='Z' CALL ALGPRE(STRING(1:NC),NC,VARLIS,3,NRES,USE,IENTRY,IFAIL) * Check the results. IF(IFAIL.NE.0)THEN CALL INPMSG(2,'Formula not translatable.') CALL ALGCLR(IENTRY) IF(PRVIEW.EQ.'3D'.OR.PRVIEW.EQ.'CUT')CALL PROEND RETURN ELSEIF(NRES.NE.1)THEN CALL INPMSG(2,'Does not return 1 result.') CALL ALGCLR(IENTRY) IF(PRVIEW.EQ.'3D'.OR.PRVIEW.EQ.'CUT')CALL PROEND RETURN ELSEIF(.NOT.(USE(1).OR.USE(2).OR.USE(3)))THEN CALL INPMSG(2,'Does not depend on x, y or z.') CALL ALGCLR(IENTRY) IF(PRVIEW.EQ.'3D'.OR.PRVIEW.EQ.'CUT')CALL PROEND RETURN ENDIF *** Compute function values at a (3x3) set of points. OK=.TRUE. MODVAR(1)=2 MODVAR(2)=2 MODVAR(3)=2 DO 80 I=-1,1 DO 90 J=-1,1 DO 100 K=-1,1 VAR(1)=0.5*(XMIN+XMAX)+I*(1+ABS(XMIN)+ABS(XMAX)) VAR(2)=0.5*(YMIN+YMAX)+J*(1+ABS(YMIN)+ABS(YMAX)) VAR(3)=0.5*(ZMIN+ZMAX)+K*(1+ABS(ZMIN)+ABS(ZMAX)) CALL ALGEXE(IENTRY,VAR,MODVAR,3,RES,MODRES,1,IFAIL) IF(IFAIL.NE.0.OR.MODRES(1).NE.2)OK=.FALSE. FRES(2+I,2+J,2+K)=RES(1) 100 CONTINUE 90 CONTINUE 80 CONTINUE * Ensure that all function evaluations worked. IF(.NOT.OK)THEN CALL INPMSG(2,'Formula can not be evaluated.') CALL ALGCLR(IENTRY) IF(PRVIEW.EQ.'3D'.OR.PRVIEW.EQ.'CUT')CALL PROEND RETURN ENDIF *** Extract parameters. FXR=((FRES(3,1,1)-FRES(1,1,1))+ - (FRES(3,1,2)-FRES(1,1,2))+ - (FRES(3,2,1)-FRES(1,2,1))+ - (FRES(3,2,2)-FRES(1,2,2)))/(8*(1+ABS(XMIN)+ABS(XMAX))) FYR=((FRES(1,3,1)-FRES(1,1,1))+ - (FRES(1,3,2)-FRES(1,1,2))+ - (FRES(2,3,1)-FRES(2,1,1))+ - (FRES(2,3,2)-FRES(2,1,2)))/(8*(1+ABS(YMIN)+ABS(YMAX))) FZR=((FRES(1,1,3)-FRES(1,1,1))+ - (FRES(1,2,3)-FRES(1,2,1))+ - (FRES(2,1,3)-FRES(2,1,1))+ - (FRES(2,2,3)-FRES(2,2,1)))/(8*(1+ABS(ZMIN)+ABS(ZMAX))) * Check the linearity and extract parameters. IF(ABS(FXR-0.5*(FRES(3,1,1)-FRES(1,1,1))/ - (1+ABS(XMIN)+ABS(XMAX))).GT.1E-4*(1+ABS(FXR)).OR. - ABS(FXR-0.5*(FRES(3,1,2)-FRES(1,1,2))/ - (1+ABS(XMIN)+ABS(XMAX))).GT.1E-4*(1+ABS(FXR)).OR. - ABS(FXR-0.5*(FRES(3,2,1)-FRES(1,2,1))/ - (1+ABS(XMIN)+ABS(XMAX))).GT.1E-4*(1+ABS(FXR)).OR. - ABS(FXR-0.5*(FRES(3,2,2)-FRES(1,2,2))/ - (1+ABS(XMIN)+ABS(XMAX))).GT.1E-4*(1+ABS(FXR)).OR. - ABS(FYR-0.5*(FRES(1,3,1)-FRES(1,1,1))/ - (1+ABS(YMIN)+ABS(YMAX))).GT.1E-4*(1+ABS(FYR)).OR. - ABS(FYR-0.5*(FRES(1,3,2)-FRES(1,1,2))/ - (1+ABS(YMIN)+ABS(YMAX))).GT.1E-4*(1+ABS(FYR)).OR. - ABS(FYR-0.5*(FRES(2,3,1)-FRES(2,1,1))/ - (1+ABS(YMIN)+ABS(YMAX))).GT.1E-4*(1+ABS(FYR)).OR. - ABS(FYR-0.5*(FRES(2,3,2)-FRES(2,1,2))/ - (1+ABS(YMIN)+ABS(YMAX))).GT.1E-4*(1+ABS(FYR)).OR. - ABS(FZR-0.5*(FRES(1,1,3)-FRES(1,1,1))/ - (1+ABS(ZMIN)+ABS(ZMAX))).GT.1E-4*(1+ABS(FZR)).OR. - ABS(FZR-0.5*(FRES(1,2,3)-FRES(1,2,1))/ - (1+ABS(ZMIN)+ABS(ZMAX))).GT.1E-4*(1+ABS(FZR)).OR. - ABS(FZR-0.5*(FRES(2,1,3)-FRES(2,1,1))/ - (1+ABS(ZMIN)+ABS(ZMAX))).GT.1E-4*(1+ABS(FZR)).OR. - ABS(FZR-0.5*(FRES(2,2,3)-FRES(2,2,1))/ - (1+ABS(ZMIN)+ABS(ZMAX))).GT.1E-4*(1+ABS(FZR)))THEN CALL INPMSG(2,'Formula is not linear.') CALL ALGCLR(IENTRY) IF(PRVIEW.EQ.'3D'.OR.PRVIEW.EQ.'CUT')CALL PROEND RETURN ENDIF *** Establish perpendicular vectors. FNORM=SQRT(FXR**2+FYR**2+FZR**2) IF(FXR**2+FZR**2.GT.0)THEN FPROJ(1,1)= FZR/SQRT(FXR**2+FZR**2) FPROJ(1,2)= 0 FPROJ(1,3)=-FXR/SQRT(FXR**2+FZR**2) FPROJ(2,1)=-FXR*FYR/(SQRT(FXR**2+FZR**2)*FNORM) FPROJ(2,2)= (FXR**2+FZR**2)/(SQRT(FXR**2+FZR**2)*FNORM) FPROJ(2,3)=-FYR*FZR/(SQRT(FXR**2+FZR**2)*FNORM) FPROJ(3,1)= FXR FPROJ(3,2)= FYR FPROJ(3,3)= FZR ELSEIF(FYR**2+FZR**2.GT.0)THEN FPROJ(1,1)= (FYR**2+FZR**2)/(SQRT(FYR**2+FZR**2)*FNORM) FPROJ(1,2)=-FXR*FZR/(SQRT(FYR**2+FZR**2)*FNORM) FPROJ(1,3)=-FYR*FZR/(SQRT(FYR**2+FZR**2)*FNORM) FPROJ(2,1)= 0 FPROJ(2,2)= FZR/SQRT(FYR**2+FZR**2) FPROJ(2,3)=-FYR/SQRT(FYR**2+FZR**2) FPROJ(3,1)= FXR FPROJ(3,2)= FYR FPROJ(3,3)= FZR ELSE CALL INPMSG(2,'Does not describe a plane.') CALL INPMSG(3,'See previous message.') CALL INPMSG(4,'See previous message.') CALL ALGCLR(IENTRY) IF(PRVIEW.EQ.'3D'.OR.PRVIEW.EQ.'CUT')CALL PROEND CALL PLAINT IF(POLAR)THEN PRVIEW='R-PHI' ELSE PRVIEW='X-Y' ENDIF RETURN ENDIF *** Rotate the vectors. DO 20 I=1,3 AUXU(I)=COS(PROROT)*FPROJ(1,I)-SIN(PROROT)*FPROJ(2,I) AUXV(I)=SIN(PROROT)*FPROJ(1,I)+COS(PROROT)*FPROJ(2,I) 20 CONTINUE DO 30 I=1,3 FPROJ(1,I)=AUXU(I) FPROJ(2,I)=AUXV(I) 30 CONTINUE *** Normalise the in-plane vector. VAR(1)=0 VAR(2)=0 VAR(3)=0 CALL ALGEXE(IENTRY,VAR,MODVAR,3,RES,MODRES,1,IFAIL) IF(IFAIL.NE.0.OR.MODRES(1).NE.2)THEN CALL INPMSG(2,'Unable to compute the norm.') CALL ALGCLR(IENTRY) IF(PRVIEW.EQ.'3D'.OR.PRVIEW.EQ.'CUT')CALL PROEND CALL PLAINT IF(POLAR)THEN PRVIEW='R-PHI' ELSE PRVIEW='X-Y' ENDIF RETURN ENDIF FPROJ(3,1)=-RES(1)*FPROJ(3,1)/FNORM**2 FPROJ(3,2)=-RES(1)*FPROJ(3,2)/FNORM**2 FPROJ(3,3)=-RES(1)*FPROJ(3,3)/FNORM**2 *** Store the plane parameters. FPROJA=FXR FPROJB=FYR FPROJC=FZR FPROJN=FNORM FPROJD=-RES(1) *** Delete the entry point. CALL ALGCLR(IENTRY) *** Format the x-axis label. IF(PRVIEW.EQ.'3D'.OR.PRVIEW.EQ.'CUT')THEN CALL PROFLD(1,'Formatting labels',-1.0) CALL PROSTA(1,0.0) ENDIF NCXLAB=0 PXLAB=' ' IF(ABS(FPROJ(1,1)-1).LE.1E-4)THEN PXLAB(NCXLAB+1:NCXLAB+1)='x' NCXLAB=NCXLAB+1 ELSEIF(ABS(FPROJ(1,1)+1).LE.1E-4)THEN PXLAB(NCXLAB+1:NCXLAB+2)='-x' NCXLAB=NCXLAB+2 ELSEIF(FPROJ(1,1).GT.1E-4)THEN CALL OUTFMT(REAL(FPROJ(1,1)),2,STRAUX,NCAUX,'LEFT') PXLAB(NCXLAB+1:NCXLAB+2+NCAUX)=STRAUX(1:NCAUX)//'*x' NCXLAB=NCXLAB+2+NCAUX ELSEIF(FPROJ(1,1).LT.-1E-4)THEN CALL OUTFMT(REAL(-FPROJ(1,1)),2,STRAUX,NCAUX,'LEFT') PXLAB(NCXLAB+1:NCXLAB+3+NCAUX)='-'//STRAUX(1:NCAUX)//'*x' NCXLAB=NCXLAB+3+NCAUX ENDIF IF(ABS(FPROJ(1,2)-1).LE.1E-4)THEN IF(NCXLAB.EQ.0)THEN PXLAB(NCXLAB+1:NCXLAB+1)='y' NCXLAB=NCXLAB+1 ELSE PXLAB(NCXLAB+1:NCXLAB+2)='+y' NCXLAB=NCXLAB+2 ENDIF ELSEIF(ABS(FPROJ(1,2)+1).LE.1E-4)THEN PXLAB(NCXLAB+1:NCXLAB+2)='-y' NCXLAB=NCXLAB+2 ELSEIF(FPROJ(1,2).GT.1E-4)THEN CALL OUTFMT(REAL(FPROJ(1,2)),2,STRAUX,NCAUX,'LEFT') IF(NCXLAB.EQ.0)THEN PXLAB(NCXLAB+1:NCXLAB+2+NCAUX)=STRAUX(1:NCAUX)//'*y' NCXLAB=NCXLAB+2+NCAUX ELSE PXLAB(NCXLAB+1:NCXLAB+3+NCAUX)='+'// - STRAUX(1:NCAUX)//'*y' NCXLAB=NCXLAB+3+NCAUX ENDIF ELSEIF(FPROJ(1,2).LT.-1E-4)THEN CALL OUTFMT(REAL(-FPROJ(1,2)),2,STRAUX,NCAUX,'LEFT') PXLAB(NCXLAB+1:NCXLAB+3+NCAUX)='-'//STRAUX(1:NCAUX)//'*y' NCXLAB=NCXLAB+3+NCAUX ENDIF IF(ABS(FPROJ(1,3)-1).LE.1E-4)THEN IF(NCXLAB.EQ.0)THEN PXLAB(NCXLAB+1:NCXLAB+1)='z' NCXLAB=NCXLAB+1 ELSE PXLAB(NCXLAB+1:NCXLAB+2)='+z' NCXLAB=NCXLAB+2 ENDIF ELSEIF(ABS(FPROJ(1,3)+1).LE.1E-4)THEN PXLAB(NCXLAB+1:NCXLAB+2)='-z' NCXLAB=NCXLAB+2 ELSEIF(FPROJ(1,3).GT.1E-4)THEN CALL OUTFMT(REAL(FPROJ(1,3)),2,STRAUX,NCAUX,'LEFT') IF(NCXLAB.EQ.0)THEN PXLAB(NCXLAB+1:NCXLAB+2+NCAUX)=STRAUX(1:NCAUX)//'*z' NCXLAB=NCXLAB+2+NCAUX ELSE PXLAB(NCXLAB+1:NCXLAB+3+NCAUX)='+'// - STRAUX(1:NCAUX)//'*z' NCXLAB=NCXLAB+3+NCAUX ENDIF ELSEIF(FPROJ(1,3).LT.-1E-4)THEN CALL OUTFMT(REAL(-FPROJ(1,3)),2,STRAUX,NCAUX,'LEFT') PXLAB(NCXLAB+1:NCXLAB+3+NCAUX)='-'//STRAUX(1:NCAUX)//'*z' NCXLAB=NCXLAB+3+NCAUX ENDIF PXLAB(NCXLAB+1:NCXLAB+10)=' Axis [cm]' IF(NCXLAB.EQ.1)PXLAB(2:2)='-' NCXLAB=NCXLAB+10 * Format the y-axis label. NCYLAB=0 PYLAB=' ' IF(ABS(FPROJ(2,1)-1).LE.1E-4)THEN PYLAB(NCYLAB+1:NCYLAB+1)='x' NCYLAB=NCYLAB+1 ELSEIF(ABS(FPROJ(2,1)+1).LE.1E-4)THEN PYLAB(NCYLAB+1:NCYLAB+2)='-x' NCYLAB=NCYLAB+2 ELSEIF(FPROJ(2,1).GT.1E-4)THEN CALL OUTFMT(REAL(FPROJ(2,1)),2,STRAUX,NCAUX,'LEFT') PYLAB(NCYLAB+1:NCYLAB+2+NCAUX)=STRAUX(1:NCAUX)//'*x' NCYLAB=NCYLAB+2+NCAUX ELSEIF(FPROJ(2,1).LT.-1E-4)THEN CALL OUTFMT(REAL(-FPROJ(2,1)),2,STRAUX,NCAUX,'LEFT') PYLAB(NCYLAB+1:NCYLAB+3+NCAUX)='-'//STRAUX(1:NCAUX)//'*x' NCYLAB=NCYLAB+3+NCAUX ENDIF IF(ABS(FPROJ(2,2)-1).LE.1E-4)THEN IF(NCYLAB.EQ.0)THEN PYLAB(NCYLAB+1:NCYLAB+1)='y' NCYLAB=NCYLAB+1 ELSE PYLAB(NCYLAB+1:NCYLAB+2)='+y' NCYLAB=NCYLAB+2 ENDIF ELSEIF(ABS(FPROJ(2,2)+1).LE.1E-4)THEN PYLAB(NCYLAB+1:NCYLAB+2)='-y' NCYLAB=NCYLAB+2 ELSEIF(FPROJ(2,2).GT.1E-4)THEN CALL OUTFMT(REAL(FPROJ(2,2)),2,STRAUX,NCAUX,'LEFT') IF(NCYLAB.EQ.0)THEN PYLAB(NCYLAB+1:NCYLAB+2+NCAUX)=STRAUX(1:NCAUX)//'*y' NCYLAB=NCYLAB+2+NCAUX ELSE PYLAB(NCYLAB+1:NCYLAB+3+NCAUX)='+'// - STRAUX(1:NCAUX)//'*y' NCYLAB=NCYLAB+3+NCAUX ENDIF ELSEIF(FPROJ(2,2).LT.-1E-4)THEN CALL OUTFMT(REAL(-FPROJ(2,2)),2,STRAUX,NCAUX,'LEFT') PYLAB(NCYLAB+1:NCYLAB+3+NCAUX)='-'//STRAUX(1:NCAUX)//'*y' NCYLAB=NCYLAB+3+NCAUX ENDIF IF(ABS(FPROJ(2,3)-1).LE.1E-4)THEN IF(NCYLAB.EQ.0)THEN PYLAB(NCYLAB+1:NCYLAB+1)='z' NCYLAB=NCYLAB+1 ELSE PYLAB(NCYLAB+1:NCYLAB+2)='+z' NCYLAB=NCYLAB+2 ENDIF ELSEIF(ABS(FPROJ(2,3)+1).LE.1E-4)THEN PYLAB(NCYLAB+1:NCYLAB+2)='-z' NCYLAB=NCYLAB+2 ELSEIF(FPROJ(2,3).GT.1E-4)THEN CALL OUTFMT(REAL(FPROJ(2,3)),2,STRAUX,NCAUX,'LEFT') IF(NCYLAB.EQ.0)THEN PYLAB(NCYLAB+1:NCYLAB+2+NCAUX)=STRAUX(1:NCAUX)//'*z' NCYLAB=NCYLAB+2+NCAUX ELSE PYLAB(NCYLAB+1:NCYLAB+3+NCAUX)='+'// - STRAUX(1:NCAUX)//'*z' NCYLAB=NCYLAB+3+NCAUX ENDIF ELSEIF(FPROJ(2,3).LT.-1E-4)THEN CALL OUTFMT(REAL(-FPROJ(2,3)),2,STRAUX,NCAUX,'LEFT') PYLAB(NCYLAB+1:NCYLAB+3+NCAUX)='-'//STRAUX(1:NCAUX)//'*z' NCYLAB=NCYLAB+3+NCAUX ENDIF PYLAB(NCYLAB+1:NCYLAB+10)=' Axis [cm]' IF(NCYLAB.EQ.1)PYLAB(2:2)='-' NCYLAB=NCYLAB+10 * Format the plane description. NCFPRO=0 PROLAB=' ' IF(ABS(FPROJA-1).LE.1E-4)THEN PROLAB(NCFPRO+1:NCFPRO+1)='x' NCFPRO=NCFPRO+1 ELSEIF(ABS(FPROJA+1).LE.1E-4)THEN PROLAB(NCFPRO+1:NCFPRO+2)='-x' NCFPRO=NCFPRO+2 ELSEIF(FPROJA.GT.1E-4)THEN CALL OUTFMT(REAL(FPROJA),2,STRAUX,NCAUX,'LEFT') PROLAB(NCFPRO+1:NCFPRO+2+NCAUX)=STRAUX(1:NCAUX)//'*x' NCFPRO=NCFPRO+2+NCAUX ELSEIF(FPROJA.LT.-1E-4)THEN CALL OUTFMT(REAL(-FPROJA),2,STRAUX,NCAUX,'LEFT') PROLAB(NCFPRO+1:NCFPRO+3+NCAUX)='-'//STRAUX(1:NCAUX)//'*x' NCFPRO=NCFPRO+3+NCAUX ENDIF IF(ABS(FPROJB-1).LE.1E-4)THEN IF(NCFPRO.EQ.0)THEN PROLAB(NCFPRO+1:NCFPRO+1)='y' NCFPRO=NCFPRO+1 ELSE PROLAB(NCFPRO+1:NCFPRO+2)='+y' NCFPRO=NCFPRO+2 ENDIF ELSEIF(ABS(FPROJB+1).LE.1E-4)THEN PROLAB(NCFPRO+1:NCFPRO+2)='-y' NCFPRO=NCFPRO+2 ELSEIF(FPROJB.GT.1E-4)THEN CALL OUTFMT(REAL(FPROJB),2,STRAUX,NCAUX,'LEFT') IF(NCFPRO.EQ.0)THEN PROLAB(NCFPRO+1:NCFPRO+2+NCAUX)=STRAUX(1:NCAUX)//'*y' NCFPRO=NCFPRO+2+NCAUX ELSE PROLAB(NCFPRO+1:NCFPRO+3+NCAUX)='+'// - STRAUX(1:NCAUX)//'*y' NCFPRO=NCFPRO+3+NCAUX ENDIF ELSEIF(FPROJB.LT.-1E-4)THEN CALL OUTFMT(REAL(-FPROJB),2,STRAUX,NCAUX,'LEFT') PROLAB(NCFPRO+1:NCFPRO+3+NCAUX)='-'//STRAUX(1:NCAUX)//'*y' NCFPRO=NCFPRO+3+NCAUX ENDIF IF(ABS(FPROJC-1).LE.1E-4)THEN IF(NCFPRO.EQ.0)THEN PROLAB(NCFPRO+1:NCFPRO+1)='z' NCFPRO=NCFPRO+1 ELSE PROLAB(NCFPRO+1:NCFPRO+2)='+z' NCFPRO=NCFPRO+2 ENDIF ELSEIF(ABS(FPROJC+1).LE.1E-4)THEN PROLAB(NCFPRO+1:NCFPRO+2)='-z' NCFPRO=NCFPRO+2 ELSEIF(FPROJC.GT.1E-4)THEN CALL OUTFMT(REAL(FPROJC),2,STRAUX,NCAUX,'LEFT') IF(NCFPRO.EQ.0)THEN PROLAB(NCFPRO+1:NCFPRO+2+NCAUX)=STRAUX(1:NCAUX)//'*z' NCFPRO=NCFPRO+2+NCAUX ELSE PROLAB(NCFPRO+1:NCFPRO+3+NCAUX)='+'// - STRAUX(1:NCAUX)//'*z' NCFPRO=NCFPRO+3+NCAUX ENDIF ELSEIF(FPROJC.LT.-1E-4)THEN CALL OUTFMT(REAL(-FPROJC),2,STRAUX,NCAUX,'LEFT') PROLAB(NCFPRO+1:NCFPRO+3+NCAUX)='-'//STRAUX(1:NCAUX)//'*z' NCFPRO=NCFPRO+3+NCAUX ENDIF PROLAB(NCFPRO+1:NCFPRO+1)='=' NCFPRO=NCFPRO+1 CALL OUTFMT(REAL(FPROJD),2,STRAUX,NCAUX,'LEFT') PROLAB(NCFPRO+1:NCFPRO+NCAUX)=STRAUX(1:NCAUX) NCFPRO=NCFPRO+NCAUX *** Next generate the tables. 1000 CONTINUE *** 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) FNORM=SQRT(FPROJA**2+FPROJB**2+FPROJC**2) IF(FNORM.LE.0)THEN PRINT *,' !!!!!! CELVIE WARNING : Zero norm vector'// - ' of viewing plane; reset to default.' IF(PRVIEW.EQ.'3D'.OR.PRVIEW.EQ.'CUT')CALL PROEND CALL PLAINT IF(POLAR)THEN PRVIEW='R-PHI' ELSE PRVIEW='X-Y' ENDIF RETURN ENDIF FPRMAT(1,3)=FPROJA/FNORM FPRMAT(2,3)=FPROJB/FNORM FPRMAT(3,3)=FPROJC/FNORM * Solve the matrix. CALL DFACT(3,FPRMAT,3,IPRMAT,IFAIL1,DET,IFAIL2) IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ CELVIE DEBUG :'', - '' Determinant of projection: '',E15.8)') DET IF(IFAIL1.NE.0.OR.IFAIL2.NE.0)THEN PRINT *,' !!!!!! CELVIE WARNING : Unable to solve'// - ' the projection matrix; reset to default.' IF(PRVIEW.EQ.'3D'.OR.PRVIEW.EQ.'CUT')CALL PROEND CALL PLAINT IF(POLAR)THEN PRVIEW='R-PHI' ELSE PRVIEW='X-Y' ENDIF RETURN ENDIF * Compute the, at most, 6 distinct crossings between plane and box. NGBOX=0 CALL PLALIN(GXMIN,GYMIN,GZMIN, GXMAX,GYMIN,GZMIN, - FPROJ(3,1),FPROJ(3,2),FPROJ(3,3), - FPROJA,FPROJB,FPROJC,XAUX,YAUX,ZAUX,IFAIL) IF(IFAIL.EQ.0)THEN NGBOX=NGBOX+1 CALL PLACO3(XAUX,YAUX,ZAUX, - GXBOX(NGBOX),GYBOX(NGBOX),GZBOX(NGBOX)) ENDIF CALL PLALIN(GXMIN,GYMIN,GZMIN, GXMIN,GYMAX,GZMIN, - FPROJ(3,1),FPROJ(3,2),FPROJ(3,3), - FPROJA,FPROJB,FPROJC,XAUX,YAUX,ZAUX,IFAIL) IF(IFAIL.EQ.0)THEN NGBOX=NGBOX+1 CALL PLACO3(XAUX,YAUX,ZAUX, - GXBOX(NGBOX),GYBOX(NGBOX),GZBOX(NGBOX)) ENDIF CALL PLALIN(GXMIN,GYMIN,GZMIN, GXMIN,GYMIN,GZMAX, - FPROJ(3,1),FPROJ(3,2),FPROJ(3,3), - FPROJA,FPROJB,FPROJC,XAUX,YAUX,ZAUX,IFAIL) IF(IFAIL.EQ.0)THEN NGBOX=NGBOX+1 CALL PLACO3(XAUX,YAUX,ZAUX, - GXBOX(NGBOX),GYBOX(NGBOX),GZBOX(NGBOX)) ENDIF CALL PLALIN(GXMAX,GYMAX,GZMIN, GXMIN,GYMAX,GZMIN, - FPROJ(3,1),FPROJ(3,2),FPROJ(3,3), - FPROJA,FPROJB,FPROJC,XAUX,YAUX,ZAUX,IFAIL) IF(IFAIL.EQ.0)THEN NGBOX=NGBOX+1 CALL PLACO3(XAUX,YAUX,ZAUX, - GXBOX(NGBOX),GYBOX(NGBOX),GZBOX(NGBOX)) ENDIF CALL PLALIN(GXMAX,GYMAX,GZMIN, GXMAX,GYMIN,GZMIN, - FPROJ(3,1),FPROJ(3,2),FPROJ(3,3), - FPROJA,FPROJB,FPROJC,XAUX,YAUX,ZAUX,IFAIL) IF(IFAIL.EQ.0)THEN NGBOX=NGBOX+1 CALL PLACO3(XAUX,YAUX,ZAUX, - GXBOX(NGBOX),GYBOX(NGBOX),GZBOX(NGBOX)) ENDIF CALL PLALIN(GXMAX,GYMAX,GZMIN, GXMAX,GYMAX,GZMAX, - FPROJ(3,1),FPROJ(3,2),FPROJ(3,3), - FPROJA,FPROJB,FPROJC,XAUX,YAUX,ZAUX,IFAIL) IF(IFAIL.EQ.0)THEN NGBOX=NGBOX+1 CALL PLACO3(XAUX,YAUX,ZAUX, - GXBOX(NGBOX),GYBOX(NGBOX),GZBOX(NGBOX)) ENDIF CALL PLALIN(GXMAX,GYMIN,GZMAX, GXMIN,GYMIN,GZMAX, - FPROJ(3,1),FPROJ(3,2),FPROJ(3,3), - FPROJA,FPROJB,FPROJC,XAUX,YAUX,ZAUX,IFAIL) IF(IFAIL.EQ.0)THEN NGBOX=NGBOX+1 CALL PLACO3(XAUX,YAUX,ZAUX, - GXBOX(NGBOX),GYBOX(NGBOX),GZBOX(NGBOX)) ENDIF CALL PLALIN(GXMAX,GYMIN,GZMAX, GXMAX,GYMAX,GZMAX, - FPROJ(3,1),FPROJ(3,2),FPROJ(3,3), - FPROJA,FPROJB,FPROJC,XAUX,YAUX,ZAUX,IFAIL) IF(IFAIL.EQ.0)THEN NGBOX=NGBOX+1 CALL PLACO3(XAUX,YAUX,ZAUX, - GXBOX(NGBOX),GYBOX(NGBOX),GZBOX(NGBOX)) ENDIF CALL PLALIN(GXMAX,GYMIN,GZMAX, GXMAX,GYMIN,GZMIN, - FPROJ(3,1),FPROJ(3,2),FPROJ(3,3), - FPROJA,FPROJB,FPROJC,XAUX,YAUX,ZAUX,IFAIL) IF(IFAIL.EQ.0)THEN NGBOX=NGBOX+1 CALL PLACO3(XAUX,YAUX,ZAUX, - GXBOX(NGBOX),GYBOX(NGBOX),GZBOX(NGBOX)) ENDIF CALL PLALIN(GXMIN,GYMAX,GZMAX, GXMAX,GYMAX,GZMAX, - FPROJ(3,1),FPROJ(3,2),FPROJ(3,3), - FPROJA,FPROJB,FPROJC,XAUX,YAUX,ZAUX,IFAIL) IF(IFAIL.EQ.0)THEN NGBOX=NGBOX+1 CALL PLACO3(XAUX,YAUX,ZAUX, - GXBOX(NGBOX),GYBOX(NGBOX),GZBOX(NGBOX)) ENDIF CALL PLALIN(GXMIN,GYMAX,GZMAX, GXMIN,GYMIN,GZMAX, - FPROJ(3,1),FPROJ(3,2),FPROJ(3,3), - FPROJA,FPROJB,FPROJC,XAUX,YAUX,ZAUX,IFAIL) IF(IFAIL.EQ.0)THEN NGBOX=NGBOX+1 CALL PLACO3(XAUX,YAUX,ZAUX, - GXBOX(NGBOX),GYBOX(NGBOX),GZBOX(NGBOX)) ENDIF CALL PLALIN(GXMIN,GYMAX,GZMAX, GXMIN,GYMAX,GZMIN, - FPROJ(3,1),FPROJ(3,2),FPROJ(3,3), - FPROJA,FPROJB,FPROJC,XAUX,YAUX,ZAUX,IFAIL) IF(IFAIL.EQ.0)THEN NGBOX=NGBOX+1 CALL PLACO3(XAUX,YAUX,ZAUX, - GXBOX(NGBOX),GYBOX(NGBOX),GZBOX(NGBOX)) ENDIF * Ensure there is no butterfly. CALL BUTFLD(NGBOX,GXBOX,GYBOX,GZBOX) * 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 * Reset the buffer of the panels. CALL PLABU1('RESET',IREF,0,XPL,YPL,ZPL, - 0.0D0,0.0D0,0.0D0,0,0,IFAIL) ** Copy the wires to the solids. IF(NWIRE.NE.0.AND.NSOLID.EQ.0.AND. - (PRVIEW.EQ.'3D'.OR.PRVIEW.EQ.'CUT')) - CALL CELCNW(QXMIN,QYMIN,QXMAX,QYMAX) ** Generate the plot panels for each solid, first for 3D views. IF(PRVIEW.EQ.'3D')THEN * Prepare colour tables. ICOL0=30 ICOLBX=0 ICOLPL=0 ICOLST=0 ICOLW1=0 ICOLW2=0 ICOLW3=0 ICOLD1=0 ICOLD2=0 ICOLD3=0 * Loop over the volumes. CALL PROFLD(1,'Generating volumes',REAL(NSOLID)) DO 1010 IVOL=1,NSOLID CALL PROSTA(1,REAL(IVOL)) * Assign the colour index, generating colour tables as required. IF(ISOLMT(IVOL).EQ.1)THEN IF(ICOLW1.EQ.0)THEN CALL GRATTS('CONDUCTORS-1','AREA') ICOLW1=ICOL0 CALL COLSHD(ICOLW1) ICOL0=ICOL0+NPRCOL ENDIF ICOL=ICOLW1 ELSEIF(ISOLMT(IVOL).EQ.2)THEN IF(ICOLW2.EQ.0)THEN CALL GRATTS('CONDUCTORS-2','AREA') ICOLW2=ICOL0 CALL COLSHD(ICOLW2) ICOL0=ICOL0+NPRCOL ENDIF ICOL=ICOLW2 ELSEIF(ISOLMT(IVOL).EQ.3)THEN IF(ICOLW3.EQ.0)THEN CALL GRATTS('CONDUCTORS-3','AREA') ICOLW3=ICOL0 CALL COLSHD(ICOLW3) ICOL0=ICOL0+NPRCOL ENDIF ICOL=ICOLW3 ELSEIF(ISOLMT(IVOL).EQ.11)THEN IF(ICOLD1.EQ.0)THEN CALL GRATTS('DIELECTRIC-1','AREA') ICOLD1=ICOL0 CALL COLSHD(ICOLD1) ICOL0=ICOL0+NPRCOL ENDIF ICOL=ICOLD1 ELSEIF(ISOLMT(IVOL).EQ.12)THEN IF(ICOLD2.EQ.0)THEN CALL GRATTS('DIELECTRIC-2','AREA') ICOLD2=ICOL0 CALL COLSHD(ICOLD2) ICOL0=ICOL0+NPRCOL ENDIF ICOL=ICOLD2 ELSEIF(ISOLMT(IVOL).EQ.13)THEN IF(ICOLD3.EQ.0)THEN CALL GRATTS('DIELECTRIC-3','AREA') ICOLD3=ICOL0 CALL COLSHD(ICOLD3) ICOL0=ICOL0+NPRCOL ENDIF ICOL=ICOLD3 ELSE ICOL=0 ENDIF * cylinders ... IF(ISOLTP(IVOL).EQ.1)THEN CALL PLACYP(IVOL,ICOL) * cylindrical holes ... ELSEIF(ISOLTP(IVOL).EQ.2)THEN CALL PLACHP(IVOL,ICOL) * boxes ... ELSEIF(ISOLTP(IVOL).EQ.3)THEN CALL PLABXP(IVOL,ICOL) * spheres ... ELSEIF(ISOLTP(IVOL).EQ.4)THEN CALL PLASPP(IVOL,ICOL) * other things not known. ELSE PRINT *,' !!!!!! CELVIE WARNING : Asked to plot a'// - ' solid of unknown type ',ISOLTP(IVOL), - '; not plotted.' ENDIF 1010 CONTINUE * And sort them for plotting. CALL PLASRP ** Same thing for cut views. ELSEIF(PRVIEW.EQ.'CUT')THEN * Create the colour entries. CALL PROFLD(1,'Making colour table',-1.0) CALL PROSTA(1,0.0) CALL GRATTS('CONDUCTORS-1','AREA') CALL GQFACI(IERR,ICOLW1) IF(IERR.NE.0)ICOLW1=1 CALL GRATTS('CONDUCTORS-2','AREA') CALL GQFACI(IERR,ICOLW2) IF(IERR.NE.0)ICOLW2=1 CALL GRATTS('CONDUCTORS-3','AREA') CALL GQFACI(IERR,ICOLW3) IF(IERR.NE.0)ICOLW3=1 CALL GRATTS('DIELECTRIC-1','AREA') CALL GQFACI(IERR,ICOLD1) IF(IERR.NE.0)ICOLD1=1 CALL GRATTS('DIELECTRIC-2','AREA') CALL GQFACI(IERR,ICOLD2) IF(IERR.NE.0)ICOLD2=1 CALL GRATTS('DIELECTRIC-3','AREA') CALL GQFACI(IERR,ICOLD3) IF(IERR.NE.0)ICOLD3=1 * Loop over the volumes. CALL PROFLD(1,'Generating volumes',REAL(NSOLID)) DO 1020 IVOL=1,NSOLID CALL PROSTA(1,REAL(IVOL)) * Assign the colour index. IF(ISOLMT(IVOL).EQ.1)THEN ICOL=ICOLW1 ELSEIF(ISOLMT(IVOL).EQ.2)THEN ICOL=ICOLW2 ELSEIF(ISOLMT(IVOL).EQ.3)THEN ICOL=ICOLW3 ELSEIF(ISOLMT(IVOL).EQ.11)THEN ICOL=ICOLD1 ELSEIF(ISOLMT(IVOL).EQ.12)THEN ICOL=ICOLD2 ELSEIF(ISOLMT(IVOL).EQ.13)THEN ICOL=ICOLD3 ELSE ICOL=0 ENDIF * cylinders ... IF(ISOLTP(IVOL).EQ.1)THEN CALL PLACYC(IVOL,FPROJ(3,1),FPROJ(3,2),FPROJ(3,3), - FPROJA,FPROJB,FPROJC,ICOL) * cylindrical holes. ELSEIF(ISOLTP(IVOL).EQ.2)THEN CALL PLACHC(IVOL,FPROJ(3,1),FPROJ(3,2),FPROJ(3,3), - FPROJA,FPROJB,FPROJC,ICOL) * boxes ... ELSEIF(ISOLTP(IVOL).EQ.3)THEN CALL PLABXC(IVOL,FPROJ(3,1),FPROJ(3,2),FPROJ(3,3), - FPROJA,FPROJB,FPROJC,ICOL) * spheres ... ELSEIF(ISOLTP(IVOL).EQ.4)THEN CALL PLASPC(IVOL,FPROJ(3,1),FPROJ(3,2),FPROJ(3,3), - FPROJA,FPROJB,FPROJC,ICOL) * other things not known. ELSE PRINT *,' !!!!!! CELVIE WARNING : Asked to plot a'// - ' solid of unknown type ',ISOLTP(IVOL), - '; not plotted.' ENDIF 1020 CONTINUE * And sort them for plotting. CALL PLASRC ENDIF *** End of progress printing. IF(PRVIEW.EQ.'3D'.OR.PRVIEW.EQ.'CUT')CALL PROEND *** Reset tolerances. CALL EPSSET('RESET',0.0D0,0.0D0,0.0D0) END +DECK,CELWRT. SUBROUTINE CELWRT(IMODE) *----------------------------------------------------------------------- * CELWRT - This routine writes all cell information on a dataset. * VARIABLES : IMODE : If 1 : find name, if 2 write cell. * IACC : If 0 no name specified, no write. * If 1 name OK, write will be executed. * If 2 name rejected no write. * (Last changed on 29/11/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,SOLIDS. +SEQ,PRINTPLOT. CHARACTER*(MXINCH) STRING CHARACTER*(MXNAME) FILE CHARACTER*29 REMARK CHARACTER*8 TIME,DATE,MEMBER INTEGER IMODE,IACC,NCFILE,NCMEMB,NCREM,I,J,K,IFAIL,INEXT,IOS, - INPCMP,NWORD LOGICAL EXMEMB EXTERNAL INPCMP +SELF,IF=SAVE. SAVE IACC,FILE,NCFILE,MEMBER,NCMEMB,REMARK,NCREM +SELF. DATA IACC/0/ *** Identify the routine. IF(LIDENT)PRINT *,' /// ROUTINE CELWRT ///' *** Goto 200 if a write is requested. IF(IMODE.EQ.2)GOTO 200 * Set the file name etc. IACC=0 FILE=' ' NCFILE=1 MEMBER='< none >' NCMEMB=8 REMARK='none' NCREM=4 * First decode the argument string. CALL INPNUM(NWORD) * Make sure there is at least one argument. IF(NWORD.EQ.1)THEN PRINT *,' !!!!!! CELWRT WARNING : WRITE takes at least one', - ' argument (a dataset name); data will not be written.' RETURN * Check whether keywords have been used. ELSEIF(INPCMP(2,'D#ATASET')+INPCMP(2,'R#EMARK').NE.0)THEN INEXT=2 DO 10 I=2,NWORD IF(I.LT.INEXT)GOTO 10 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 10 CONTINUE * Otherwise the string is interpreted as a file name (+ member name). ELSE CALL INPSTR(2,2,STRING,NCFILE) FILE=STRING IF(NWORD.GE.3)THEN CALL INPSTR(3,3,STRING,NCMEMB) MEMBER=STRING ENDIF IF(NWORD.GE.4)THEN CALL INPSTR(4,NWORD,STRING,NCREM) REMARK=STRING ENDIF ENDIF * Print error messages. CALL INPERR IF(NCFILE.GT.MXNAME)PRINT *,' !!!!!! CELWRT WARNING : The file', - ' name is truncated to MXNAME (=',MXNAME,') characters.' IF(NCMEMB.GT.8)PRINT *,' !!!!!! CELWRT WARNING : The member', - ' name is shortened to ',MEMBER,', first 8 characters.' IF(NCREM.GT.29)PRINT *,' !!!!!! CELWRT 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),'CELL',EXMEMB) IF(JEXMEM.EQ.2.AND.EXMEMB)THEN PRINT *,' ------ CELWRT MESSAGE : A copy of the member'// - ' exists; new member will be appended.' ELSEIF(JEXMEM.EQ.3.AND.EXMEMB)THEN PRINT *,' !!!!!! CELWRT WARNING : A copy of the member'// - ' exists already; member will not be written.' RETURN ENDIF * Everything seems to be OK, the accept flag can be set to 'accept'. IACC=1 * Print some debugging output if requested. IF(LDEBUG)THEN PRINT *,' ++++++ CELWRT DEBUG : File= '//FILE(1:NCFILE)// - ', member= '//MEMBER(1:NCMEMB),' IACC=',IACC PRINT *,' Remark= ',REMARK(1:NCREM) ENDIF RETURN *** Execute write operation if a valid name is available. 200 CONTINUE IF(IACC.EQ.0)RETURN IACC=0 *** Open the dataset for sequential write and inform DSNLOG. CALL DSNOPN(FILE,NCFILE,12,'WRITE-LIBRARY',IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! CELWRT WARNING : Opening '//FILE(1:NCFILE), - ' failed ; the cell data will not be written.' RETURN ENDIF CALL DSNLOG(FILE,'Cell data ','Sequential','Write ') IF(LDEBUG)PRINT *,' ++++++ CELWRT 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,'' CELL '', - 1X,''"'',A29,''"'')') DATE,TIME,MEMBER,REMARK WRITE(12,'(A80)',IOSTAT=IOS,ERR=2010) STRING IF(LDEBUG)THEN PRINT *,' ++++++ CELWRT DEBUG : Dataset heading record:' PRINT *,STRING ENDIF * Write a version number. WRITE(12,'('' Version : 1'')') * Write the cell on the dataset. WRITE(12,'('' CELLID: '',A)',IOSTAT=IOS,ERR=2010) CELLID WRITE(12,'('' Wires: '',I10,'' Type: '',A3,I2, - '' Polar: '',L1,'' Tube: '',L1)',IOSTAT=IOS,ERR=2010) - NWIRE,TYPE,ICTYPE,POLAR,TUBE WRITE(12,'('' Area: '',6E15.8,/,'' V-RANGE: '',2E15.8)', - IOSTAT=IOS,ERR=2010) XMIN,XMAX,YMIN,YMAX,ZMIN,ZMAX,VMIN,VMAX WRITE(12,'('' Wire table follows: '')',IOSTAT=IOS,ERR=2010) DO 210 I=1,NWIRE WRITE(12,'(1X,A1,6E15.8/2X,5E15.8)',IOSTAT=IOS,ERR=2010) - WIRTYP(I),X(I),Y(I),V(I),E(I),D(I),W(I),U(I),DENS(I), - B2SIN(I),WMAP(I) 210 CONTINUE WRITE(12,'('' Gravity: '',3E15.8)',IOSTAT=IOS, - ERR=2010) (DOWN(I),I=1,3) WRITE(12,'('' CORVT: '',3E15.8,'' V0: '',E15.8)',IOSTAT=IOS, - ERR=2010) CORVTA,CORVTB,CORVTC,V0 WRITE(12,'('' x-Planes: '',2(L1,2E15.8,A1))',IOSTAT=IOS,ERR=2010) - (YNPLAN(I),COPLAN(I),VTPLAN(I),PLATYP(I),I=1,2) WRITE(12,'('' y-Planes: '',2(L1,2E15.8,A1))',IOSTAT=IOS,ERR=2010) - (YNPLAN(I),COPLAN(I),VTPLAN(I),PLATYP(I),I=3,4) WRITE(12,'('' Plane summary data: '',2L1,2E15.8)',IOSTAT=IOS, - ERR=2010) YNPLAX,YNPLAY,COPLAX,COPLAY WRITE(12,'('' Strips: '',5I10/9X,5I10)',IOSTAT=IOS,ERR=2010) - (NPSTR1(I),NPSTR2(I),I=1,5) DO 240 I=1,5 DO 250 J=1,NPSTR1(I) WRITE(12,'(1X,A1,1X,3E15.8)',IOSTAT=IOS,ERR=2010) - PSLAB1(I,J),(PLSTR1(I,J,K),K=1,3) 250 CONTINUE DO 260 J=1,NPSTR2(I) WRITE(12,'(1X,A1,1X,3E15.8)',IOSTAT=IOS,ERR=2010) - PSLAB2(I,J),(PLSTR2(I,J,K),K=1,3) 260 CONTINUE 240 CONTINUE WRITE(12,'('' Periodicity : '',2(L1,E15.8))',IOSTAT=IOS, - ERR=2010) PERX,SX,PERY,SY IF(TYPE(1:1).EQ.'C')WRITE(12,'('' C cell data: '',5E15.8,I10)', - IOSTAT=IOS,ERR=2010) ZMULT,P1,P2,C1,MODE IF(TYPE.EQ.'D3 '.OR.TYPE.EQ.'D4 ') - WRITE(12,'('' D3-D4 data: '',E15.8)', - IOSTAT=IOS,ERR=2010) KAPPA WRITE(12,'('' Dielectrica: nx='',I3,'', ny='',I3)',IOSTAT=IOS, - ERR=2010) NXMATT,NYMATT DO 220 I=1,NXMATT WRITE(12,'(1X,5E15.8)',IOSTAT=IOS,ERR=2010) (XMATT(I,J),J=1,5) 220 CONTINUE DO 230 I=1,NYMATT WRITE(12,'(1X,5E15.8)',IOSTAT=IOS,ERR=2010) (YMATT(I,J),J=1,5) 230 CONTINUE IF(TUBE)WRITE(12,'('' Tube: '',2E15.8,2I10,A1)',IOSTAT=IOS, - ERR=2010) COTUBE,VTTUBE,NTUBE,MTUBE,PLATYP(5) WRITE(12,'('' Solids: '',2I10)',IOSTAT=IOS,ERR=2010) - NSOLID,ICCURR IF(NSOLID.GT.0)WRITE(12,'(1X,3I10)',IOSTAT=IOS,ERR=2010) - (ISTART(I),ISOLTP(I),ISOLMT(I),I=1,NSOLID) IF(ICCURR.GT.0)WRITE(12,'(1X,8E15.8)',IOSTAT=IOS,ERR=2010) - (CBUF(I),I=1,ICCURR) * Close the file after the operation. CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) CALL TIMLOG('Writing the cell data to a dataset: ') RETURN *** Handle the error conditions. 2010 CONTINUE PRINT *,' ###### CELWRT ERROR : Error while writing'// - ' to ',FILE(1:NCFILE),' via unit 12 ; no cell data written.' CALL INPIOS(IOS) CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) RETURN 2030 CONTINUE PRINT *,' ###### CELWRT ERROR : Dataset '//FILE(1:NCFILE)// - ' unit 12 cannot be closed ; results not predictable' CALL INPIOS(IOS) END +DECK,CELSEL. SUBROUTINE CELSEL *----------------------------------------------------------------------- * CELSEL - This routine allows the user to change his set of readout * electrodes. Wires can be identified by means of their label * and by their number. Planes and tubes by their label only. * (Last changed on 4/12/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,FIELDMAP. +SEQ,SOLIDS. +SEQ,PRINTPLOT. LOGICAL OPEN,OK,EXIST,FOUND,USED(MXWIRE+5+MXWMAP+10*MXPSTR), - SOLSEL INTEGER NC,I,J,K,L,II,IREAD,NWORD,IFAIL,INEXT CHARACTER*(MXINCH) TEXT,WRONG *** Identify the routine if requested. IF(LIDENT)PRINT *,' /// ROUTINE CELSEL ///' *** Obtain the argument string. CALL INPSTR(2,MXWORD,TEXT,NC) CALL INPNUM(NWORD) *** If the string is blank, only print the current settings. IF(NWORD.LE.1)THEN CALL CELPRC(LUNOUT,0) RETURN ENDIF *** Initialse INDSW, the logicals and the error logging array. OK=.TRUE. WRONG=' '// - ' ' DO 10 I=1,MXWIRE USED(I)=.FALSE. INDSW(I)=0 10 CONTINUE DO 160 I=1,5 USED(MXWIRE+I)=.FALSE. INDPLA(I)=0 DO 340 J=1,MXPSTR INDST1(I,J)=0 INDST2(I,J)=0 USED(MXWIRE+5+MXWMAP+(I-1)*MXPSTR+J)=.FALSE. USED(MXWIRE+5+MXWMAP+(I+4)*MXPSTR+J)=.FALSE. 340 CONTINUE 160 CONTINUE DO 260 I=1,NWMAP USED(MXWIRE+5+I)=.FALSE. INDEWS(I)=0 260 CONTINUE NSW=0 DO 170 I=1,MXSOLI INDSOL(I)=0 170 CONTINUE SOLSEL=.FALSE. *** Loop over all characters in the string. OPEN=.FALSE. INEXT=1 DO 20 I=1,NC IF(I.LT.INEXT)GOTO 20 ** Skip blanks, commas and equal signs (the usual separators), IF(INDEX(' ,=',TEXT(I:I)).NE.0)GOTO 20 ** "(" open brackets, IF(TEXT(I:I).EQ.'(')THEN IF(OPEN)THEN OK=.FALSE. WRONG(I:I)='|' ELSE OPEN=.TRUE. NSW=NSW+1 EXIST=.FALSE. ENDIF * ")" close brackets, ELSEIF(TEXT(I:I).EQ.')')THEN IF(OPEN)THEN OPEN=.FALSE. IF(.NOT.EXIST)NSW=NSW-1 ELSE OK=.FALSE. WRONG(I:I)='|' ENDIF ** Wire, plane, tube and field map code in numeric form, ELSEIF(INDEX('+-0123456789',TEXT(I:I)).NE.0)THEN J=I 30 CONTINUE J=J+1 IF(J.LE.NC.AND.INDEX('0123456789',TEXT(J:J)).NE.0)GOTO 30 CALL INPRIC(TEXT(I:J-1),IREAD,0,IFAIL) IF(IFAIL.NE.0.OR.IREAD.LT.-5-MXWMAP.OR.IREAD.GT.NWIRE.OR. - IREAD.EQ.0)THEN WRONG(I:I)='#' OK=.FALSE. INEXT=J GOTO 20 ENDIF IF(IREAD.LT.0)IREAD=MXWIRE-IREAD IF(USED(IREAD))THEN OK=.FALSE. WRONG(I:I)='2' ELSE IF(.NOT.OPEN.AND.NSW.GE.MXSW)THEN PRINT *,' !!!!!! CELSEL WARNING : You have'// - ' selected more electrodes than the'// - ' program can store ; increase MXSW.' OK=.FALSE. DO 40 K=I,NC IF(TEXT(K:K).NE.' ')WRONG(K:K)='.' 40 CONTINUE NSW=MXSW GOTO 100 ENDIF IF(IREAD.GE.MXWIRE+6.AND.IREAD.LE.MXWIRE+5+MXWMAP)THEN IF(NWMAP.LT.IREAD-MXWIRE-5)THEN WRONG(I:I)='M' OK=.FALSE. ELSE IF(.NOT.OPEN)NSW=NSW+1 INDEWS(IREAD-MXWIRE-5)=NSW USED(IREAD)=.TRUE. EXIST=.TRUE. ENDIF ELSEIF(IREAD.EQ.MXWIRE+5)THEN IF(.NOT.TUBE)THEN WRONG(I:I)='T' OK=.FALSE. ELSE IF(.NOT.OPEN)NSW=NSW+1 INDPLA(IREAD-MXWIRE)=NSW USED(IREAD)=.TRUE. EXIST=.TRUE. ENDIF ELSEIF(IREAD.GE.MXWIRE+1.AND.IREAD.LE.MXWIRE+4)THEN IF(.NOT.YNPLAN(IREAD-MXWIRE))THEN WRONG(I:I)='P' OK=.FALSE. ELSE IF(.NOT.OPEN)NSW=NSW+1 INDPLA(IREAD-MXWIRE)=NSW USED(IREAD)=.TRUE. EXIST=.TRUE. ENDIF ELSE IF(.NOT.OPEN)NSW=NSW+1 INDSW(IREAD)=NSW USED(IREAD)=.TRUE. EXIST=.TRUE. ENDIF ENDIF INEXT=J ** Wire and plane code as a letter, ELSEIF(INDEX('ABCDEFGHIJKLMNOPQRSTUVWXYZ',TEXT(I:I)).NE.0)THEN FOUND=.FALSE. * Check the wires. DO 60 J=1,NWIRE IF(WIRTYP(J).EQ.TEXT(I:I))THEN EXIST=.TRUE. FOUND=.TRUE. IF(USED(J))THEN OK=.FALSE. WRONG(I:I)='2' GOTO 60 ELSE IF(.NOT.OPEN)NSW=NSW+1 IF(NSW.GT.MXSW)THEN PRINT *,' !!!!!! CELSEL WARNING : You have'// - ' selected more electrodes than the'// - ' program can store ; increase MXSW.' OK=.FALSE. DO 50 K=I,NC IF(TEXT(K:K).NE.' ')WRONG(K:K)='.' 50 CONTINUE NSW=MXSW GOTO 100 ENDIF INDSW(J)=NSW USED(J)=.TRUE. ENDIF ENDIF 60 CONTINUE * Check the planes and the tube. DO 180 J=1,5 IF(J.LE.4)THEN IF(.NOT.YNPLAN(J))GOTO 180 ELSE IF(.NOT.TUBE)GOTO 180 ENDIF IF(PLATYP(J).EQ.TEXT(I:I))THEN EXIST=.TRUE. FOUND=.TRUE. IF(USED(MXWIRE+J))THEN OK=.FALSE. WRONG(I:I)='2' GOTO 180 ELSE IF(.NOT.OPEN)NSW=NSW+1 IF(NSW.GT.MXSW)THEN PRINT *,' !!!!!! CELSEL WARNING : You have'// - ' selected more electrodes than the'// - ' program can store ; increase MXSW.' OK=.FALSE. DO 190 K=I,NC IF(TEXT(K:K).NE.' ')WRONG(K:K)='.' 190 CONTINUE NSW=MXSW GOTO 100 ENDIF INDPLA(J)=NSW USED(MXWIRE+J)=.TRUE. ENDIF ENDIF 180 CONTINUE * Check the strips on the planes and the tube. DO 240 J=1,5 IF(J.LE.4)THEN IF(.NOT.YNPLAN(J))GOTO 240 ELSE IF(.NOT.TUBE)GOTO 240 ENDIF DO 280 K=1,NPSTR1(J) IF(PSLAB1(J,K).EQ.TEXT(I:I))THEN EXIST=.TRUE. FOUND=.TRUE. IF(USED(MXWIRE+5+MXWMAP+(J-1)*MXPSTR+K))THEN OK=.FALSE. WRONG(I:I)='2' GOTO 280 ELSE IF(.NOT.OPEN)NSW=NSW+1 IF(NSW.GT.MXSW)THEN PRINT *,' !!!!!! CELSEL WARNING : You have'// - ' selected more electrodes than the'// - ' program can store ; increase MXSW.' OK=.FALSE. DO 250 L=I,NC IF(TEXT(L:L).NE.' ')WRONG(L:L)='.' 250 CONTINUE NSW=MXSW GOTO 100 ENDIF INDST1(J,K)=NSW USED(MXWIRE+5+MXWMAP+(J-1)*MXPSTR+K)=.TRUE. ENDIF ENDIF 280 CONTINUE DO 350 K=1,NPSTR2(J) IF(PSLAB2(J,K).EQ.TEXT(I:I))THEN EXIST=.TRUE. FOUND=.TRUE. IF(USED(MXWIRE+5+MXWMAP+(J+4)*MXPSTR+K))THEN OK=.FALSE. WRONG(I:I)='2' GOTO 350 ELSE IF(.NOT.OPEN)NSW=NSW+1 IF(NSW.GT.MXSW)THEN PRINT *,' !!!!!! CELSEL WARNING : You have'// - ' selected more electrodes than the'// - ' program can store ; increase MXSW.' OK=.FALSE. DO 360 L=I,NC IF(TEXT(L:L).NE.' ')WRONG(L:L)='.' 360 CONTINUE NSW=MXSW GOTO 100 ENDIF INDST2(J,K)=NSW USED(MXWIRE+5+MXWMAP+(J+4)*MXPSTR+K)=.TRUE. ENDIF ENDIF 350 CONTINUE 240 CONTINUE * Check the field map. DO 270 J=1,NWMAP IF(EWSTYP(J).EQ.TEXT(I:I))THEN EXIST=.TRUE. FOUND=.TRUE. IF(USED(MXWIRE+5+J))THEN OK=.FALSE. WRONG(I:I)='2' ELSE IF(.NOT.OPEN)NSW=NSW+1 IF(NSW.GT.MXSW)THEN PRINT *,' !!!!!! CELSEL WARNING : You have'// - ' selected more electrodes than the'// - ' program can store ; increase MXSW.' OK=.FALSE. DO 210 K=I,NC IF(TEXT(K:K).NE.' ')WRONG(K:K)='.' 210 CONTINUE NSW=MXSW GOTO 100 ENDIF INDEWS(J)=NSW USED(MXWIRE+5+J)=.TRUE. ENDIF ENDIF 270 CONTINUE * Check the solids, do not assign new groups to these however. DO 150 J=1,NSOLID IF(SOLTYP(J).EQ.TEXT(I:I))THEN FOUND=.TRUE. SOLSEL=.TRUE. INDSOL(J)=-1 ENDIF 150 CONTINUE * See that something has been found. IF(.NOT.FOUND)THEN OK=.FALSE. WRONG(I:I)='?' ENDIF ** invalid character. ELSE WRONG(I:I)='*' OK=.FALSE. ENDIF * Next selection character. 20 CONTINUE *** Match solids and weighting field, if selected. DO 290 J=1,NWMAP IF(INDEWS(J).NE.0)THEN DO 70 I=1,NSOLID IF(SOLTYP(I).EQ.EWSTYP(J))THEN IF(INDSOL(I).GT.0.AND.INDSOL(I).NE.INDEWS(J))THEN PRINT *,' !!!!!! CELSEL WARNING : Solid ',I, - ' matches more than one field map.' OK=.FALSE. ELSE INDSOL(I)=INDEWS(J) SOLSEL=.TRUE. ENDIF ENDIF 70 CONTINUE ENDIF 290 CONTINUE *** Check that there are electrodes. IF(NSW.EQ.0.AND.SOLSEL)THEN PRINT *,' ------ CELSEL MESSAGE : You have only'// - ' selected solids that are not read out.' ELSEIF(NSW.EQ.0.AND.JFAIL.EQ.1)THEN PRINT *,' !!!!!! CELSEL WARNING : No electrodes found'// - ' that match your selection ; searching for "S".' * Consider wires. DO 80 I=1,NWIRE IF(WIRTYP(I).EQ.'S')THEN NSW=NSW+1 INDSW(I)=NSW ENDIF 80 CONTINUE * Planes and tube. DO 200 I=1,5 IF(PLATYP(I).EQ.'S')THEN NSW=NSW+1 INDPLA(I)=NSW ENDIF 200 CONTINUE * Field map. DO 300 I=1,NWMAP IF(EWSTYP(I).EQ.'S')THEN NSW=NSW+1 INDEWS(I)=NSW ENDIF 300 CONTINUE IF(NSW.GT.MXSW)NSW=MXSW IF(NSW.EQ.0)THEN PRINT *,' !!!!!! CELSEL WARNING : The cell does not'// - ' contain "S" electrodes ; nothing selected.' NSW=0 ENDIF ELSEIF(NSW.EQ.0.AND.JFAIL.EQ.2)THEN PRINT *,' !!!!!! CELSEL WARNING : No electrodes found'// - ' that match your selection ; nothing selected.' ELSEIF(NSW.EQ.0.AND.JFAIL.EQ.3)THEN PRINT *,' !!!!!! CELSEL WARNING : No electrodes found'// - ' that match your selection ; terminating.' CALL QUIT ENDIF *** Print an error message if an error occured. 100 CONTINUE IF(WRONG(1:NC).NE.' ')WRITE(*,'('' !!!!!! CELSEL WARNING : An'', - '' error occured in the selection of electrodes''/ - 9X,''Selection : '',A/ - 9X,''Error messages : '',A/ - 9X,''Error codes : '', - ''"?" label not found, "#" number out of range,''/ - 26X,''"*" invalid character, "|" unmatched bracket,''/ - 26X,''"2" referenced twice, "." (partially) ignored,''/ - 26X,''"M" no such map, "P" no such plane,''/ - 26X,''"T" there is no tube.'')') - TEXT(1:NC),WRONG(1:NC) *** Print some extra output if the debug option is on/input is blank. IF(LDEBUG)THEN WRITE(LUNOUT,'('' ++++++ CELSEL DEBUG : Number of'', - '' electrode groups: '',I5)') NSW * List wires. WRITE(LUNOUT,'('' ++++++ CELSEL DEBUG : The wires have'', - '' been selected as follows:'')') DO 120 II=1,NWIRE,4 WRITE(WRONG,'(25X,4(I3,'' '',A1,'' - '',I3,'', ''))') - (I,WIRTYP(I),INDSW(I),I=II,MIN(II+3,NWIRE)) DO 110 I=II,MIN(II+3,NWIRE) IF(INDSW(I).EQ.0)WRONG(34+(I-II)*13:36+(I-II)*13)='---' 110 CONTINUE IF(II+3.GE.NWIRE)WRONG(37+(NWIRE-II)*13:37+(NWIRE-II)*13)= - '.' WRITE(LUNOUT,'(1X,A)') WRONG(1:76) 120 CONTINUE * List planes and tubes. WRITE(LUNOUT,'('' ++++++ CELSEL DEBUG : The planes'', - '' have been selected as follows:'')') WRITE(WRONG,'(25X,4(I3,'' '',A1,'' - '',I3,'', ''))') - (I,PLATYP(I),INDPLA(I),I=1,4) DO 140 I=1,4 IF(INDPLA(I).EQ.0)WRONG(21+I*13:23+I*13)='---' 140 CONTINUE WRITE(LUNOUT,'(1X,A)') WRONG(1:76) WRITE(LUNOUT,'('' ++++++ CELSEL DEBUG : The tube'', - '' has been selected as follows:'')') WRITE(WRONG,'(25X,I3,'' '',A1,'' - '',I3,''.'')') - 1,PLATYP(5),INDPLA(5) IF(INDPLA(5).EQ.0)WRONG(34:36)='---' WRITE(LUNOUT,'(1X,A)') WRONG(1:76) * List strips. DO 370 I=1,5 IF(NPSTR1(I).NE.0)WRITE(LUNOUT,'('' ++++++ CELSEL'', - '' DEBUG : The x-y strips of plane '',I3, - '' have been selected as follows:'')') I DO 380 II=1,NPSTR1(I),4 WRITE(WRONG,'(25X,4(I3,'' '',A1,'' - '',I3,'', ''))') - (J,PSLAB1(I,J),INDST1(I,J),J=II,MIN(II+3,NPSTR1(I))) DO 390 J=II,MIN(II+3,NPSTR1(I)) IF(INDST1(I,J).EQ.0)WRONG(34+(J-II)*13:36+(J-II)*13)='---' 390 CONTINUE IF(II+3.GE.NPSTR1(I))WRONG(37+(NPSTR1(I)-II)*13: - 37+(NPSTR1(I)-II)*13)='.' WRITE(LUNOUT,'(1X,A)') WRONG(1:76) 380 CONTINUE IF(NPSTR2(I).NE.0)WRITE(LUNOUT,'('' ++++++ CELSEL'', - '' DEBUG : The z strips of plane '',I3, - '' have been selected as follows:'')') I DO 400 II=1,NPSTR2(I),4 WRITE(WRONG,'(25X,4(I3,'' '',A1,'' - '',I3,'', ''))') - (J,PSLAB2(I,J),INDST2(I,J),J=II,MIN(II+3,NPSTR2(I))) DO 410 J=II,MIN(II+3,NPSTR2(I)) IF(INDST2(I,J).EQ.0)WRONG(34+(J-II)*13:36+(J-II)*13)='---' 410 CONTINUE IF(II+3.GE.NPSTR2(I))WRONG(37+(NPSTR2(I)-II)*13: - 37+(NPSTR2(I)-II)*13)='.' WRITE(LUNOUT,'(1X,A)') WRONG(1:76) 400 CONTINUE 370 CONTINUE * List the field maps. WRITE(LUNOUT,'('' ++++++ CELSEL DEBUG : The field'', - '' maps have been selected as follows:'')') DO 310 II=1,NWMAP,4 WRITE(WRONG,'(25X,4(I3,'' '',A1,'' - '',I3,'', ''))') - (I,EWSTYP(I),INDEWS(I),I=II,MIN(II+3,NWMAP)) DO 320 I=II,MIN(II+3,NWMAP) IF(INDEWS(I).EQ.0)WRONG(34+(I-II)*13:36+(I-II)*13)='---' 320 CONTINUE IF(II+3.GE.NWMAP)WRONG(37+(NWMAP-II)*13: - 37+(NWMAP-II)*13)='.' WRITE(LUNOUT,'(1X,A)') WRONG(1:76) 310 CONTINUE * List solids. WRITE(LUNOUT,'('' ++++++ CELSEL DEBUG : The solids'', - '' have been selected as follows:'')') DO 220 II=1,NSOLID,4 WRITE(WRONG,'(25X,4(I3,'' '',A1,'' - '',I3,'', ''))') - (I,SOLTYP(I),INDSOL(I),I=II,MIN(II+3,NSOLID)) DO 230 I=II,MIN(II+3,NSOLID) IF(INDSOL(I).EQ.0)WRONG(34+(I-II)*13:36+(I-II)*13)='---' 230 CONTINUE IF(II+3.GE.NSOLID)WRONG(37+(NSOLID-II)*13: - 37+(NSOLID-II)*13)='.' WRITE(LUNOUT,'(1X,A)') WRONG(1:76) 220 CONTINUE ENDIF END +DECK,CELPRC. SUBROUTINE CELPRC(LUNPRT,ISW) *----------------------------------------------------------------------- * CELPRC - Prints the current selection to unit LUNPRT * (Last changed on 5/12/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,FIELDMAP. +SEQ,SOLIDS. +SEQ,CONSTANTS. REAL XPRT,YPRT INTEGER LUNPRT,NC1,NC2,NC3,NC4,NC5,I,J,K,IOS,ISW,NCOUNT CHARACTER*20 AUX1,AUX2,AUX3,AUX4,AUX5 *** Print a header. IF(ISW.EQ.0)THEN IF(NSW.EQ.0)THEN WRITE(LUNPRT,'(/'' No electrode is currently'', - '' selected for read-out.'')', - ERR=2010,IOSTAT=IOS) ELSEIF(NSW.EQ.1)THEN WRITE(LUNPRT,'(/'' A single group of electrodes'', - '' is currently selected for read-out:'')', - ERR=2010,IOSTAT=IOS) ELSE CALL OUTFMT(REAL(NSW),2,AUX1,NC1,'LEFT') WRITE(LUNPRT,'(/'' At present, '',A,'' groups of'', - '' electrodes are selected for read-out:'')', - ERR=2010,IOSTAT=IOS) - AUX1(1:NC1) ENDIF ENDIF *** Loop over the electrodes. DO 210 I=1,NSW IF(ISW.NE.0.AND.I.NE.ISW)GOTO 210 * Print a header for this group. CALL OUTFMT(REAL(I),2,AUX1,NC1,'LEFT') WRITE(LUNPRT,'(/'' Group '',A,'' consists of:'')', - ERR=2010,IOSTAT=IOS) AUX1(1:NC1) *** Loop over the wires. DO 220 J=1,NWIRE * Pick out those with a matching id. IF(INDSW(J).NE.I)GOTO 220 * Format position and potential. XPRT=X(J) YPRT=Y(J) CALL OUTFMT(REAL(J),2,AUX2,NC2,'LEFT') CALL OUTFMT(V(J) ,2,AUX5,NC5,'LEFT') IF(POLAR)THEN CALL CFMRTP(XPRT,YPRT,XPRT,YPRT,1) CALL OUTFMT(XPRT ,2,AUX3,NC3,'LEFT') CALL OUTFMT(YPRT ,2,AUX4,NC4,'LEFT') WRITE(LUNPRT,'(5X,''Wire '',A,'' with label '',A, - '' at (r,phi)=('',A,'','',A,'') and at '',A, - '' V'')',ERR=2010,IOSTAT=IOS) AUX2(1:NC2),WIRTYP(J), - AUX3(1:NC3),AUX4(1:NC4),AUX5(1:NC5) ELSE CALL OUTFMT(XPRT ,2,AUX3,NC3,'LEFT') CALL OUTFMT(YPRT ,2,AUX4,NC4,'LEFT') WRITE(LUNPRT,'(5X,''Wire '',A,'' with label '',A, - '' at (x,y)=('',A,'','',A,'') and at '',A, - '' V'')',ERR=2010,IOSTAT=IOS) AUX2(1:NC2),WIRTYP(J), - AUX3(1:NC3),AUX4(1:NC4),AUX5(1:NC5) ENDIF 220 CONTINUE *** Loop over the x-planes. DO 230 J=1,2 * Pick out those with a matching id. IF(INDPLA(J).EQ.I)THEN * Format position and potential. IF(POLAR)THEN CALL OUTFMT(EXP(COPLAN(J)),2,AUX2,NC2,'LEFT') CALL OUTFMT(VTPLAN(J) ,2,AUX3,NC3,'LEFT') WRITE(LUNPRT,'(5X,''The plane with label '',A, - '' at r='',A,'' cm and at '',A,'' V'')', - ERR=2010,IOSTAT=IOS) PLATYP(J),AUX2(1:NC2), - AUX3(1:NC3) ELSE CALL OUTFMT(COPLAN(J) ,2,AUX2,NC2,'LEFT') CALL OUTFMT(VTPLAN(J) ,2,AUX3,NC3,'LEFT') WRITE(LUNPRT,'(5X,''The plane with label '',A, - '' at x='',A,'' cm and at '',A,'' V'')', - ERR=2010,IOSTAT=IOS) PLATYP(J),AUX2(1:NC2), - AUX3(1:NC3) ENDIF ENDIF * See whether there are selected strips in the plane. DO 260 K=1,NPSTR1(J) IF(INDST1(J,K).EQ.I)THEN IF(POLAR)THEN CALL OUTFMT(EXP(COPLAN(J)),2,AUX2,NC2,'LEFT') CALL OUTFMT(180*PLSTR1(J,K,1)/PI,2,AUX4,NC4,'LEFT') CALL OUTFMT(180*PLSTR1(J,K,2)/PI,2,AUX5,NC5,'LEFT') WRITE(LUNPRT,'(5X,''The strip '',A,'' < phi < '', - A,'' degrees, labeled '',A,'', of the plane'', - '' at r='',A,'' cm'')',ERR=2010,IOSTAT=IOS) - AUX4(1:NC4),AUX5(1:NC5),PSLAB1(J,K),AUX2(1:NC2) ELSE CALL OUTFMT(COPLAN(J) ,2,AUX2,NC2,'LEFT') CALL OUTFMT(PLSTR1(J,K,1),2,AUX4,NC4,'LEFT') CALL OUTFMT(PLSTR1(J,K,2),2,AUX5,NC5,'LEFT') WRITE(LUNPRT,'(5X,''The strip '',A,'' < y < '', - A,'' cm, labeled '',A,'', of the plane'', - '' at x='',A,'' cm'')',ERR=2010,IOSTAT=IOS) - AUX4(1:NC4),AUX5(1:NC5),PSLAB1(J,K),AUX2(1:NC2) ENDIF ENDIF 260 CONTINUE DO 270 K=1,NPSTR2(J) IF(INDST2(J,K).EQ.I)THEN IF(POLAR)THEN CALL OUTFMT(EXP(COPLAN(J)),2,AUX2,NC2,'LEFT') CALL OUTFMT(PLSTR2(J,K,1) ,2,AUX4,NC4,'LEFT') CALL OUTFMT(PLSTR2(J,K,2) ,2,AUX5,NC5,'LEFT') WRITE(LUNPRT,'(5X,''The strip '',A,'' < z < '', - A,'' cm, labeled '',A,'', of the plane'', - '' at r='',A,'' cm'')',ERR=2010,IOSTAT=IOS) - AUX4(1:NC4),AUX5(1:NC5),PSLAB2(J,K),AUX2(1:NC2) ELSE CALL OUTFMT(COPLAN(J) ,2,AUX2,NC2,'LEFT') CALL OUTFMT(PLSTR2(J,K,1),2,AUX4,NC4,'LEFT') CALL OUTFMT(PLSTR2(J,K,2),2,AUX5,NC5,'LEFT') WRITE(LUNPRT,'(5X,''The strip '',A,'' < z < '', - A,'' cm, labeled '',A,'', of the plane'', - '' at x='',A,'' cm'')',ERR=2010,IOSTAT=IOS) - AUX4(1:NC4),AUX5(1:NC5),PSLAB2(J,K),AUX2(1:NC2) ENDIF ENDIF 270 CONTINUE 230 CONTINUE *** Loop over the y-planes. DO 240 J=3,4 * Pick out those with a matching id. IF(INDPLA(J).EQ.I)THEN * Format position and potential. IF(POLAR)THEN CALL OUTFMT(180*COPLAN(J)/PI,2,AUX2,NC2,'LEFT') CALL OUTFMT(VTPLAN(J) ,2,AUX3,NC3,'LEFT') WRITE(LUNPRT,'(5X,''The plane with label '',A, - '' at phi='',A,'' degrees and at '',A, - '' V'')',ERR=2010,IOSTAT=IOS) PLATYP(J), - AUX2(1:NC2),AUX3(1:NC3) ELSE CALL OUTFMT(COPLAN(J) ,2,AUX2,NC2,'LEFT') CALL OUTFMT(VTPLAN(J) ,2,AUX3,NC3,'LEFT') WRITE(LUNPRT,'(5X,''The plane with label '',A, - '' at y='',A,'' cm and at '',A,'' V'')', - ERR=2010,IOSTAT=IOS) PLATYP(J),AUX2(1:NC2), - AUX3(1:NC3) ENDIF ENDIF * See whether there are selected strips in the plane. DO 280 K=1,NPSTR1(J) IF(INDST1(J,K).EQ.I)THEN IF(POLAR)THEN CALL OUTFMT(180*COPLAN(J)/PI,2,AUX2,NC2,'LEFT') CALL OUTFMT(EXP(PLSTR1(J,K,1)),2,AUX4,NC4,'LEFT') CALL OUTFMT(EXP(PLSTR1(J,K,2)),2,AUX5,NC5,'LEFT') WRITE(LUNPRT,'(5X,''The strip '',A,'' < r < '', - A,'' cm, labeled '',A,'', of the planen at'', - '' phi='',A,'' degrees'')',ERR=2010,IOSTAT=IOS) - AUX4(1:NC4),AUX5(1:NC5),PSLAB1(J,K),AUX2(1:NC2) ELSE CALL OUTFMT(COPLAN(J) ,2,AUX2,NC2,'LEFT') CALL OUTFMT(PLSTR1(J,K,1),2,AUX4,NC4,'LEFT') CALL OUTFMT(PLSTR1(J,K,2),2,AUX5,NC5,'LEFT') WRITE(LUNPRT,'(5X,''The strip '',A,'' < x < '', - A,'' cm, labeled '',A,'', of the plane at'', - '' y='',A,'' cm'')',ERR=2010,IOSTAT=IOS) - AUX4(1:NC4),AUX5(1:NC5),PSLAB1(J,K),AUX2(1:NC2) ENDIF ENDIF 280 CONTINUE DO 290 K=1,NPSTR2(J) IF(INDST2(J,K).EQ.I)THEN IF(POLAR)THEN CALL OUTFMT(180*COPLAN(J)/PI,2,AUX2,NC2,'LEFT') CALL OUTFMT(PLSTR2(J,K,1),2,AUX4,NC4,'LEFT') CALL OUTFMT(PLSTR2(J,K,2),2,AUX5,NC5,'LEFT') WRITE(LUNPRT,'(5X,''The strip '',A,'' < z < '', - A,'' cm, labeled '',A,'', of the plane at'', - '' phi='',A,'' degrees'')',ERR=2010,IOSTAT=IOS) - AUX4(1:NC4),AUX5(1:NC5),PSLAB2(J,K),AUX2(1:NC2) ELSE CALL OUTFMT(COPLAN(J) ,2,AUX2,NC2,'LEFT') CALL OUTFMT(PLSTR2(J,K,1),2,AUX4,NC4,'LEFT') CALL OUTFMT(PLSTR2(J,K,2),2,AUX5,NC5,'LEFT') WRITE(LUNPRT,'(5X,''The strip '',A,'' < z < '', - A,'' cm, labeled '',A,'', of the plane at'', - '' y='',A,'' cm'')',ERR=2010,IOSTAT=IOS) - AUX4(1:NC4),AUX5(1:NC5),PSLAB2(J,K),AUX2(1:NC2) ENDIF ENDIF 290 CONTINUE 240 CONTINUE *** Check whether the tube has been selected. IF(INDPLA(5).EQ.I)THEN CALL OUTFMT(COTUBE,2,AUX2,NC2,'LEFT') CALL OUTFMT(VTTUBE,2,AUX3,NC3,'LEFT') WRITE(LUNPRT,'(5X,''The tube with label '',A, - '', radius='',A,'' cm and potential '',A, - '' V'')',ERR=2010,IOSTAT=IOS) - PLATYP(5),AUX2(1:NC2),AUX3(1:NC3) ENDIF * See whether there are selected strips in the tube. DO 300 K=1,NPSTR1(5) IF(INDST1(5,K).EQ.I)THEN CALL OUTFMT(180*PLSTR1(5,K,1)/PI,2,AUX4,NC4,'LEFT') CALL OUTFMT(180*PLSTR1(5,K,2)/PI,2,AUX5,NC5,'LEFT') WRITE(LUNPRT,'(5X,''The sector '',A,'' < phi < '', - A,'' degrees, labeled '',A,'', of the tube'')', - ERR=2010,IOSTAT=IOS) - AUX4(1:NC4),AUX5(1:NC5),PSLAB1(5,K) ENDIF 300 CONTINUE DO 310 K=1,NPSTR2(5) IF(INDST2(5,K).EQ.I)THEN CALL OUTFMT(PLSTR2(5,K,1),2,AUX4,NC4,'LEFT') CALL OUTFMT(PLSTR2(5,K,2),2,AUX5,NC5,'LEFT') WRITE(LUNPRT,'(5X,''The ring '',A,'' < z < '', - A,'' cm, labeled '',A,'', of the tube'')', - ERR=2010,IOSTAT=IOS) - AUX4(1:NC4),AUX5(1:NC5),PSLAB2(5,K) ENDIF 310 CONTINUE *** Loop over the weighting field maps. DO 250 K=1,NWMAP * Pick out if matching. IF(INDEWS(K).NE.I)GOTO 250 * Header. CALL OUTFMT(REAL(K),2,AUX1,NC1,'LEFT') WRITE(LUNPRT,'(5X,''Finite element weighting field map '',A, - '' with label '',A,'' representing:'')', - ERR=2010,IOSTAT=IOS) AUX1(1:NC1),EWSTYP(K) * Check for matching solids. NCOUNT=0 DO 10 J=1,NSOLID IF(INDSOL(J).NE.I)GOTO 10 CALL OUTFMT(REAL(J),2,AUX5,NC5,'LEFT') * Cylinders. IF(ISOLTP(J).EQ.1)THEN CALL OUTFMT(REAL(CBUF(ISTART(J)+3)),2,AUX2,NC2,'LEFT') CALL OUTFMT(REAL(CBUF(ISTART(J)+4)),2,AUX3,NC3,'LEFT') CALL OUTFMT(REAL(CBUF(ISTART(J)+5)),2,AUX4,NC4,'LEFT') WRITE(LUNPRT,'(8X,''Cylinder '',A,'' with label '',A, - '' centered at ('', A,'','',A,'','',A,'')'')', - ERR=2010,IOSTAT=IOS) AUX5(1:NC5),SOLTYP(J), - AUX2(1:NC2),AUX3(1:NC3),AUX4(1:NC4) NCOUNT=NCOUNT+1 * Holes. ELSEIF(ISOLTP(J).EQ.2)THEN CALL OUTFMT(REAL(CBUF(ISTART(J)+6)),2,AUX2,NC2,'LEFT') CALL OUTFMT(REAL(CBUF(ISTART(J)+7)),2,AUX3,NC3,'LEFT') CALL OUTFMT(REAL(CBUF(ISTART(J)+8)),2,AUX4,NC4,'LEFT') WRITE(LUNPRT,'(8X,''Hole '',A,'' with label '',A, - '' centered at ('', A,'','',A,'','',A,'')'')', - ERR=2010,IOSTAT=IOS) AUX5(1:NC5),SOLTYP(J), - AUX2(1:NC2),AUX3(1:NC3),AUX4(1:NC4) NCOUNT=NCOUNT+1 * Boxes. ELSEIF(ISOLTP(J).EQ.3)THEN CALL OUTFMT(REAL(CBUF(ISTART(J)+4)),2,AUX2,NC2,'LEFT') CALL OUTFMT(REAL(CBUF(ISTART(J)+5)),2,AUX3,NC3,'LEFT') CALL OUTFMT(REAL(CBUF(ISTART(J)+6)),2,AUX4,NC4,'LEFT') WRITE(LUNPRT,'(8X,''Box '',A,'' with label '',A, - '' centered at ('', A,'','',A,'','',A,'')'')', - ERR=2010,IOSTAT=IOS) AUX5(1:NC5),SOLTYP(J), - AUX2(1:NC2),AUX3(1:NC3),AUX4(1:NC4) NCOUNT=NCOUNT+1 * Sphere. ELSEIF(ISOLTP(J).EQ.4)THEN CALL OUTFMT(REAL(CBUF(ISTART(J)+2)),2,AUX2,NC2,'LEFT') CALL OUTFMT(REAL(CBUF(ISTART(J)+3)),2,AUX3,NC3,'LEFT') CALL OUTFMT(REAL(CBUF(ISTART(J)+4)),2,AUX4,NC4,'LEFT') WRITE(LUNPRT,'(8X,''Sphere '',A,'' with label '',A, - '' centered at ('', A,'','',A,'','',A,'')'')', - ERR=2010,IOSTAT=IOS) AUX5(1:NC5),SOLTYP(J), - AUX2(1:NC2),AUX3(1:NC3),AUX4(1:NC4) NCOUNT=NCOUNT+1 * Other ELSE PRINT *,' !!!!!! CELPRC WARNING : Found a solid'// - ' of unknown type; not printed.' ENDIF 10 CONTINUE IF(NCOUNT.EQ.0)WRITE(LUNPRT,'(8X,''No matching solid'')', - ERR=2010,IOSTAT=IOS) 250 CONTINUE *** Next electrode identifier. 210 CONTINUE *** Now check for selected solids not assigned to a readout group. IF(ISW.EQ.0)THEN * See whether there are any. NCOUNT=0 DO 30 J=1,NSOLID IF(INDSOL(J).EQ.-1)NCOUNT=NCOUNT+1 30 CONTINUE * Header. IF(NCOUNT.EQ.0)THEN WRITE(LUNPRT,'(/'' No solid is currently selected'', - '' outside read-out.'')',ERR=2010,IOSTAT=IOS) ELSE WRITE(LUNPRT,'(/'' Solids which are selected but'', - '' not read out:'')',ERR=2010,IOSTAT=IOS) ENDIF * Check for matching solids. NCOUNT=0 DO 20 J=1,NSOLID IF(INDSOL(J).NE.-1)GOTO 20 CALL OUTFMT(REAL(J),2,AUX5,NC5,'LEFT') * Cylinders. IF(ISOLTP(J).EQ.1)THEN CALL OUTFMT(REAL(CBUF(ISTART(J)+3)),2,AUX2,NC2,'LEFT') CALL OUTFMT(REAL(CBUF(ISTART(J)+4)),2,AUX3,NC3,'LEFT') CALL OUTFMT(REAL(CBUF(ISTART(J)+5)),2,AUX4,NC4,'LEFT') WRITE(LUNPRT,'(5X,''Cylinder '',A,'' with label '',A, - '' centered at ('', A,'','',A,'','',A,'')'')', - ERR=2010,IOSTAT=IOS) AUX5(1:NC5),SOLTYP(J), - AUX2(1:NC2),AUX3(1:NC3),AUX4(1:NC4) NCOUNT=NCOUNT+1 * Holes. ELSEIF(ISOLTP(J).EQ.2)THEN CALL OUTFMT(REAL(CBUF(ISTART(J)+6)),2,AUX2,NC2,'LEFT') CALL OUTFMT(REAL(CBUF(ISTART(J)+7)),2,AUX3,NC3,'LEFT') CALL OUTFMT(REAL(CBUF(ISTART(J)+8)),2,AUX4,NC4,'LEFT') WRITE(LUNPRT,'(5X,''Hole '',A,'' with label '',A, - '' centered at ('', A,'','',A,'','',A,'')'')', - ERR=2010,IOSTAT=IOS) AUX5(1:NC5),SOLTYP(J), - AUX2(1:NC2),AUX3(1:NC3),AUX4(1:NC4) NCOUNT=NCOUNT+1 * Boxes. ELSEIF(ISOLTP(J).EQ.3)THEN CALL OUTFMT(REAL(CBUF(ISTART(J)+4)),2,AUX2,NC2,'LEFT') CALL OUTFMT(REAL(CBUF(ISTART(J)+5)),2,AUX3,NC3,'LEFT') CALL OUTFMT(REAL(CBUF(ISTART(J)+6)),2,AUX4,NC4,'LEFT') WRITE(LUNPRT,'(5X,''Box '',A,'' with label '',A, - '' centered at ('', A,'','',A,'','',A,'')'')', - ERR=2010,IOSTAT=IOS) AUX5(1:NC5),SOLTYP(J), - AUX2(1:NC2),AUX3(1:NC3),AUX4(1:NC4) NCOUNT=NCOUNT+1 * Sphere. ELSEIF(ISOLTP(J).EQ.4)THEN CALL OUTFMT(REAL(CBUF(ISTART(J)+2)),2,AUX2,NC2,'LEFT') CALL OUTFMT(REAL(CBUF(ISTART(J)+3)),2,AUX3,NC3,'LEFT') CALL OUTFMT(REAL(CBUF(ISTART(J)+4)),2,AUX4,NC4,'LEFT') WRITE(LUNPRT,'(5X,''Sphere '',A,'' with label '',A, - '' centered at ('', A,'','',A,'','',A,'')'')', - ERR=2010,IOSTAT=IOS) AUX5(1:NC5),SOLTYP(J), - AUX2(1:NC2),AUX3(1:NC3),AUX4(1:NC4) NCOUNT=NCOUNT+1 * Other ELSE PRINT *,' !!!!!! CELPRC WARNING : Found a solid'// - ' of unknown type; not printed.' ENDIF 20 CONTINUE ENDIF RETURN *** I/O errors. 2010 CONTINUE PRINT *,' !!!!!! CELPRC WARNING : Error writing out the group'// - ' composition of the electrodes to unit ',LUNPRT CALL INPIOS(IOS) END +DECK,CELSTR. SUBROUTINE CELSTR(IFAIL) *----------------------------------------------------------------------- * CELSTR - Assigns default anode-cathode gaps, if applicable. * (Last changed on 7/12/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. INTEGER IFAIL,I,J REAL GAPDEF(4) *** Assume this will work. IFAIL=0 *** Compute default gaps. IF(YNPLAN(1))THEN IF(YNPLAN(2))THEN GAPDEF(1)=COPLAN(2)-COPLAN(1) ELSEIF(NWIRE.LE.0)THEN GAPDEF(1)=-1 ELSE GAPDEF(1)=X(1)-COPLAN(1) DO 10 I=2,NWIRE IF(X(I)-COPLAN(1).LT.GAPDEF(1))GAPDEF(1)=X(I)-COPLAN(1) 10 CONTINUE ENDIF ENDIF IF(YNPLAN(2))THEN IF(YNPLAN(1))THEN GAPDEF(2)=COPLAN(2)-COPLAN(1) ELSEIF(NWIRE.LE.0)THEN GAPDEF(2)=-1 ELSE GAPDEF(2)=COPLAN(2)-X(1) DO 20 I=2,NWIRE IF(COPLAN(2)-X(I).LT.GAPDEF(2))GAPDEF(2)=COPLAN(2)-X(I) 20 CONTINUE ENDIF ENDIF IF(YNPLAN(3))THEN IF(YNPLAN(4))THEN GAPDEF(3)=COPLAN(4)-COPLAN(3) ELSEIF(NWIRE.LE.0)THEN GAPDEF(3)=-1 ELSE GAPDEF(3)=Y(1)-COPLAN(3) DO 30 I=2,NWIRE IF(Y(I)-COPLAN(3).LT.GAPDEF(3))GAPDEF(3)=Y(I)-COPLAN(3) 30 CONTINUE ENDIF ENDIF IF(YNPLAN(4))THEN IF(YNPLAN(3))THEN GAPDEF(4)=COPLAN(4)-COPLAN(3) ELSEIF(NWIRE.LE.0)THEN GAPDEF(4)=-1 ELSE GAPDEF(4)=COPLAN(4)-X(1) DO 40 I=2,NWIRE IF(COPLAN(4)-Y(I).LT.GAPDEF(4))GAPDEF(4)=COPLAN(4)-Y(I) 40 CONTINUE ENDIF ENDIF *** Assign. DO 50 I=1,4 DO 60 J=1,NPSTR1(I) IF(PLSTR1(I,J,3).LT.0)PLSTR1(I,J,3)=GAPDEF(I) IF(PLSTR1(I,J,3).LT.0)THEN PRINT *,' !!!!!! CELSTR WARNING : Not able to set a'// - ' default anode-cathode gap for x/y-strip ',J, - ' of plane ',I,'.' IFAIL=1 ENDIF 60 CONTINUE DO 70 J=1,NPSTR2(I) IF(PLSTR2(I,J,3).LT.0)PLSTR2(I,J,3)=GAPDEF(I) IF(PLSTR2(I,J,3).LT.0)THEN PRINT *,' !!!!!! CELSTR WARNING : Not able to set a'// - ' default anode-cathode gap for z-strip ',J, - ' of plane ',I,'.' IFAIL=1 ENDIF 70 CONTINUE 50 CONTINUE END +DECK,CELSYN. SUBROUTINE CELSYN *----------------------------------------------------------------------- * CELSYN - Outputs the cell data for use by front end programs. * (Last changed on 23/ 2/99.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. INTEGER I,NC1,NC2 CHARACTER*20 AUX1,AUX2 *** Cell type. IF(POLAR)THEN WRITE(6,'('' >>>>>> set cell coordinates polar'')') ELSEIF(TUBE)THEN WRITE(6,'('' >>>>>> set cell coordinates tube'')') ELSE WRITE(6,'('' >>>>>> set cell coordinates cartesian'')') ENDIF *** Potential type. WRITE(6,'('' >>>>>> set cell type '',A)') TYPE *** Dimensions. WRITE(6,'('' >>>>>> set cell xmin '',E15.8/ - '' >>>>>> set cell ymin '',E15.8/ - '' >>>>>> set cell zmin '',E15.8/ - '' >>>>>> set cell xmax '',E15.8/ - '' >>>>>> set cell ymax '',E15.8/ - '' >>>>>> set cell zmax '',E15.8/ - '' >>>>>> set cell vmin '',E15.8/ - '' >>>>>> set cell vmax '',E15.8)') - XMIN,YMIN,ZMIN,XMAX,YMAX,ZMAX,VMIN,VMAX *** Number of wires. WRITE(6,'('' >>>>>> set cell nwire '',I10)') NWIRE *** Wire data. DO 10 I=1,NWIRE CALL OUTFMT(REAL(I),2,AUX1,NC1,'LEFT') CALL OUTFMT(X(I),2,AUX2,NC2,'LEFT') WRITE(6,'('' >>>>>> set cell x'',A,1X,A)') - AUX1(1:NC1),AUX2(1:NC2) CALL OUTFMT(Y(I),2,AUX2,NC2,'LEFT') WRITE(6,'('' >>>>>> set cell y'',A,1X,A)') - AUX1(1:NC1),AUX2(1:NC2) CALL OUTFMT(V(I),2,AUX2,NC2,'LEFT') WRITE(6,'('' >>>>>> set cell v'',A,1X,A)') - AUX1(1:NC1),AUX2(1:NC2) CALL OUTFMT(E(I),2,AUX2,NC2,'LEFT') WRITE(6,'('' >>>>>> set cell e'',A,1X,A)') - AUX1(1:NC1),AUX2(1:NC2) CALL OUTFMT(D(I),2,AUX2,NC2,'LEFT') WRITE(6,'('' >>>>>> set cell d'',A,1X,A)') - AUX1(1:NC1),AUX2(1:NC2) CALL OUTFMT(W(I),2,AUX2,NC2,'LEFT') WRITE(6,'('' >>>>>> set cell w'',A,1X,A)') - AUX1(1:NC1),AUX2(1:NC2) CALL OUTFMT(U(I),2,AUX2,NC2,'LEFT') WRITE(6,'('' >>>>>> set cell u'',A,1X,A)') - AUX1(1:NC1),AUX2(1:NC2) CALL OUTFMT(DENS(I),2,AUX2,NC2,'LEFT') WRITE(6,'('' >>>>>> set cell dens'',A,1X,A)') - AUX1(1:NC1),AUX2(1:NC2) WRITE(6,'('' >>>>>> set cell type'',A,'' "'',A1,''"'')') - AUX1(1:NC1),WIRTYP(I) 10 CONTINUE *** Plane data. DO 20 I=1,4 IF(YNPLAN(I))THEN WRITE(6,'('' >>>>>> set cell plane'',I1,'' 1'')') I CALL OUTFMT(COPLAN(I),2,AUX1,NC1,'LEFT') WRITE(6,'('' >>>>>> set cell coorplane'',I1,1X,A)') - I,AUX1(1:NC1) CALL OUTFMT(VTPLAN(I),2,AUX1,NC1,'LEFT') WRITE(6,'('' >>>>>> set cell voltplane'',I1,1X,A)') - I,AUX1(1:NC1) WRITE(6,'('' >>>>>> set cell typeplane'',I1,'' "'', - A1,''"'')') I,PLATYP(I) ELSE WRITE(6,'('' >>>>>> set cell plane'',I1,'' 0'')') I WRITE(6,'('' >>>>>> set cell coorplane'',I1,'' 0'')') I WRITE(6,'('' >>>>>> set cell voltplane'',I1,'' 0'')') I WRITE(6,'('' >>>>>> set cell typeplane'',I1,'' "?"'')') I ENDIF 20 CONTINUE *** Tube. IF(TUBE)THEN WRITE(6,'('' >>>>>> set cell tube 1'')') CALL OUTFMT(COTUBE,2,AUX1,NC1,'LEFT') WRITE(6,'('' >>>>>> set cell coortube '',A)') - AUX1(1:NC1) CALL OUTFMT(VTTUBE,2,AUX1,NC1,'LEFT') WRITE(6,'('' >>>>>> set cell volttube '',A)') - AUX1(1:NC1) WRITE(6,'('' >>>>>> set cell ntube '',I10)') NTUBE WRITE(6,'('' >>>>>> set cell mtube '',I10)') MTUBE WRITE(6,'('' >>>>>> set cell typetube "'',A1,''"'')') - PLATYP(5) ELSE WRITE(6,'('' >>>>>> set cell tube 0'')') WRITE(6,'('' >>>>>> set cell coortube 0'')') WRITE(6,'('' >>>>>> set cell volttube 0'')') WRITE(6,'('' >>>>>> set cell ntube 0'')') WRITE(6,'('' >>>>>> set cell mtube 0'')') WRITE(6,'('' >>>>>> set cell typetube 0'')') ENDIF *** Declare the cell as having been set. WRITE(6,'('' >>>>>> set cell set 1'')') END +DECK,MAGCMP. SUBROUTINE MAGCMP *----------------------------------------------------------------------- * MAGCMP - Reads the B field components. * (Last changed on 25/ 2/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,BFIELD. +SEQ,GLOBALS. +SEQ,MATDATA. +SEQ,PRINTPLOT. CHARACTER*(MXCHAR) FUN CHARACTER*30 AUX1,AUX2,UNIT CHARACTER*10 VARLIS(MXVAR) REAL B0,BMIN,BMAX INTEGER NWORD,NC1,NC2,NCUNIT,NVAR,I,J,K,INEXT, - ISLOT,MATSLT,NDIM,IDIM(1),IMOD, - ISCOPY,ISDATA,INPTYP,INPCMP,NRES,IFAIL,NCFUN,IENTRY, - IREFB,IREFV,IBTYPE,IDIR,IGLB LOGICAL USE(MXVAR),OK EXTERNAL INPCMP,INPTYP,MATSLT *** Identify the routine. IF(LIDENT)PRINT *,' /// ROUTINE MAGCMP ///' *** Count words. CALL INPNUM(NWORD) *** Display current state if there are no arguments. IF(NWORD.EQ.1)THEN * Scale factor. IF(ABS(BSCALE-100.0).LT.0.01)THEN UNIT(1:1)='T' NCUNIT=1 ELSEIF(ABS(BSCALE-0.01).LT.0.00001)THEN UNIT(1:1)='G' NCUNIT=1 ELSE CALL OUTFMT(BSCALE/100,2,AUX1,NC1,'LEFT') UNIT=' * '//AUX1(1:NC1)//' T' NCUNIT=NC1+5 ENDIF * x-component. IF(POLAR)THEN WRITE(LUNOUT,'('' Magnetic field components:'', - '' Br = 0 T,'')') ELSEIF(IBXTYP.EQ.0)THEN WRITE(LUNOUT,'('' Magnetic field components: Bx = '', - ''Undefined, assumed to be 0 T,'')') ELSEIF(IBXTYP.EQ.1)THEN CALL OUTFMT(B0X*BSCALE/100,2,AUX1,NC1,'LEFT') WRITE(LUNOUT,'('' Magnetic field components: Bx = '', - A,'' T,'')') AUX1(1:NC1) ELSEIF(IBXTYP.EQ.2)THEN WRITE(LUNOUT,'('' Magnetic field components: Bx = '', - A,'' '',A,'','')') FUNB0X(1:NCB0X),UNIT(1:NCUNIT) ELSEIF(IBXTYP.EQ.3)THEN CALL OUTFMT(REAL(IRB0X),5,AUX1,NC1,'LEFT') CALL OUTFMT(REAL(IRV0X),5,AUX2,NC2,'LEFT') IF(IBXDIR.EQ.1)THEN WRITE(LUNOUT,'('' Magnetic field components:'', - '' Bx = '',A,'' '',A,'' vs''/34X,A, - '' cm as x,'')') AUX1(1:NC1),UNIT(1:NCUNIT), - AUX2(1:NC2) ELSEIF(IBXDIR.EQ.2)THEN WRITE(LUNOUT,'('' Magnetic field components:'', - '' Bx = '',A,'' '',A,'' vs''/34X,A, - '' cm as x,'')') AUX1(1:NC1),UNIT(1:NCUNIT), - AUX2(1:NC2) ELSEIF(IBXDIR.EQ.3)THEN WRITE(LUNOUT,'('' Magnetic field components:'', - '' Bx = '',A,'' '',A,'' vs''/34X,A, - '' cm as x,'')') AUX1(1:NC1),UNIT(1:NCUNIT), - AUX2(1:NC2) ELSE WRITE(LUNOUT,'('' Magnetic field components:'', - '' Bx = Invalid interpolation,'', - '' assumed to 0 T,'')') ENDIF ELSE WRITE(LUNOUT,'('' Magnetic field components: Bx = '', - '' Unknown, assumed to be 0 T,'')') ENDIF * y-component. IF(POLAR)THEN WRITE(LUNOUT,'(29X,''By = 0 T,'')') ELSEIF(IBYTYP.EQ.0)THEN WRITE(LUNOUT,'(29X,''By = Undefined, assumed to be'', - '' 0 T,'')') ELSEIF(IBYTYP.EQ.1)THEN CALL OUTFMT(B0Y*BSCALE/100,2,AUX1,NC1,'LEFT') WRITE(LUNOUT,'(29X,''By = '',A,'' T,'')') AUX1(1:NC1) ELSEIF(IBYTYP.EQ.2)THEN WRITE(LUNOUT,'(29X,''By = '',A,'' '',A,'','')') - FUNB0Y(1:NCB0Y),UNIT(1:NCUNIT) ELSEIF(IBYTYP.EQ.3)THEN CALL OUTFMT(REAL(IRB0Y),5,AUX1,NC1,'LEFT') CALL OUTFMT(REAL(IRV0Y),5,AUX2,NC2,'LEFT') IF(IBYDIR.EQ.1)THEN WRITE(LUNOUT,'(29X,''By = '',A,'' '',A,'' vs''/ - 34X,A,'' cm as x,'')') - AUX1(1:NC1),UNIT(1:NCUNIT),AUX2(1:NC2) ELSEIF(IBYDIR.EQ.2)THEN WRITE(LUNOUT,'(29X,''By = '',A,'' '',A,'' vs''/ - 34X,A,'' cm as y,'')') - AUX1(1:NC1),UNIT(1:NCUNIT),AUX2(1:NC2) ELSEIF(IBYDIR.EQ.3)THEN WRITE(LUNOUT,'(29X,''By = '',A,'' '',A,'' vs''/ - 34X,A,'' cm as z,'')') - AUX1(1:NC1),UNIT(1:NCUNIT),AUX2(1:NC2) ELSE WRITE(LUNOUT,'(29X,''By = Invalid'', - '' interpolation, assumed to 0 T,'')') ENDIF ELSE WRITE(LUNOUT,'(29X,''By = Unknown, assumed to be'', - '' 0 T,'')') ENDIF * z-component. IF(IBZTYP.EQ.0)THEN WRITE(LUNOUT,'(29X,''Bz = Undefined, assumed to be'', - '' 0 T.'')') ELSEIF(IBZTYP.EQ.1)THEN CALL OUTFMT(B0Z*BSCALE/100,2,AUX1,NC1,'LEFT') WRITE(LUNOUT,'(29X,''Bz = '',A,'' T.'')') AUX1(1:NC1) ELSEIF(IBZTYP.EQ.2)THEN WRITE(LUNOUT,'(29X,''Bz = '',A,'' '',A,''.'')') - FUNB0Z(1:NCB0Z),UNIT(1:NCUNIT) ELSEIF(IBZTYP.EQ.3)THEN CALL OUTFMT(REAL(IRB0Z),5,AUX1,NC1,'LEFT') CALL OUTFMT(REAL(IRV0Z),5,AUX2,NC2,'LEFT') IF(IBZDIR.EQ.1)THEN WRITE(LUNOUT,'(29X,''Bz = '',A,'' '',A,'' vs''/ - 34X,A,'' cm as x.'')') - AUX1(1:NC1),UNIT(1:NCUNIT),AUX2(1:NC2) ELSEIF(IBZDIR.EQ.2)THEN WRITE(LUNOUT,'(29X,''Bz = '',A,'' '',A,'' vs''/ - 34X,A,'' cm as y.'')') - AUX1(1:NC1),UNIT(1:NCUNIT),AUX2(1:NC2) ELSEIF(IBZDIR.EQ.3)THEN WRITE(LUNOUT,'(29X,''Bz = '',A,'' '',A,'' vs''/ - 34X,A,'' cm as z.'')') - AUX1(1:NC1),UNIT(1:NCUNIT),AUX2(1:NC2) ELSE WRITE(LUNOUT,'(29X,''Bz = Invalid'', - '' interpolation, assumed to 0 T.'')') ENDIF ELSE WRITE(LUNOUT,'(29X,''Bz = Unknown, assumed to be'', - '' 0 T.'')') ENDIF * Range. CALL OUTFMT(BFMIN*BSCALE/100,2,AUX1,NC1,'LEFT') CALL OUTFMT(BFMAX*BSCALE/100,2,AUX2,NC2,'LEFT') WRITE(LUNOUT,'(/'' Default magnetic field range is '',A, - '' < B < '',A,'' T.'')') AUX1(1:NC1),AUX2(1:NC2) * Nothing more to be done. RETURN ENDIF *** Set the list of variables. IF(POLAR)THEN VARLIS(1)='R' VARLIS(2)='PHI' VARLIS(3)='Z' ELSE VARLIS(1)='X' VARLIS(2)='Y' VARLIS(3)='Z' ENDIF NVAR=3 *** Reset the OK flag. OK=.TRUE. *** Reset the scale to Tesla. BSCALE=100.0 *** Get each of the 3 components in turn. INEXT=2 DO 100 K=1,3 * Preset the variables. IF(K.EQ.1)THEN B0=B0X FUN=FUNB0X NCFUN=NCB0X IENTRY=IENB0X IREFB=IRB0X IREFV=IRV0X IBTYPE=IBXTYP IDIR=IBXDIR BMIN=BFXMIN BMAX=BFXMAX ELSEIF(K.EQ.2)THEN B0=B0Y FUN=FUNB0Y NCFUN=NCB0Y IENTRY=IENB0Y IREFB=IRB0Y IREFV=IRV0Y IBTYPE=IBYTYP IDIR=IBYDIR BMIN=BFYMIN BMAX=BFYMAX ELSEIF(K.EQ.3)THEN B0=B0Z FUN=FUNB0Z NCFUN=NCB0Z IENTRY=IENB0Z IREFB=IRB0Z IREFV=IRV0Z IBTYPE=IBZTYP IDIR=IBZDIR BMIN=BFZMIN BMAX=BFZMAX ENDIF *** Get the component, try the format "Matrix VS {X|Y|Z} Matrix". IF(INPCMP(INEXT+1,'VS').NE.0.AND.INEXT+3.LE.NWORD)THEN IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAGCMP DEBUG :'', - '' Component '',I1,'': Matrix interpolation.'')') K ** Extract the name of the B vector. CALL INPSTR(INEXT,INEXT,AUX1,NC1) IF(NC1.LT.1)THEN AUX1='?' NC1=1 ENDIF * Scan the list of globals for the B vector. ISDATA=0 ISCOPY=0 IGLB=0 DO 10 I=1,NGLB IF(GLBVAR(I).EQ.AUX1(1:NC1))THEN * Ensure this is a Matrix. IF(GLBMOD(I).NE.5)THEN CALL INPMSG(INEXT,AUX1(1:NC1)// - ' is not a Matrix.') OK=.FALSE. GOTO 10 ENDIF * Locate it. ISLOT=MATSLT(NINT(GLBVAL(I))) IF(ISLOT.LE.0)THEN PRINT *,' !!!!!! MAGCMP WARNING : '//AUX1(1:NC1)// - ' can not be located in the Matrix buffer.' OK=.FALSE. * Ensure it is 1-dimensional. ELSEIF(MDIM(ISLOT).NE.1)THEN CALL INPMSG(INEXT,AUX1(1:NC1)// - ' is not 1-dimensional.') OK=.FALSE. * And that it has a length of at least 1. ELSEIF(MLEN(ISLOT).LT.2)THEN CALL INPMSG(INEXT,'Length of '//AUX1(1:NC1)// - ' < 2.') OK=.FALSE. * Duplicate B, delete an old copy if there is one. ELSE IF(IREFB.NE.0)CALL MATADM('DELETE',IREFB,NDIM, - IDIM,IMOD,IFAIL) NDIM=MDIM(ISLOT) IMOD=MMOD(ISLOT) IDIM(1)=MSIZ(ISLOT,1) CALL MATADM('ALLOCATE',IREFB,NDIM,IDIM,IMOD,IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! MAGCMP WARNING : Failed'// - ' to obtain space for a copy of B.' OK=.FALSE. ENDIF ISCOPY=MATSLT(IREFB) IF(ISCOPY.LE.0)THEN PRINT *,' !!!!!! MAGCMP WARNING : Failed'// - ' to locate the copy of B.' OK=.FALSE. ENDIF DO 20 J=1,MLEN(ISLOT) MVEC(MORG(ISCOPY)+J)=MVEC(MORG(ISLOT)+J) IF(J.EQ.1)THEN BMIN=MVEC(MORG(ISLOT)+J) BMAX=MVEC(MORG(ISLOT)+J) ELSE BMIN=MIN(BMIN,MVEC(MORG(ISLOT)+J)) BMAX=MAX(BMAX,MVEC(MORG(ISLOT)+J)) ENDIF 20 CONTINUE ENDIF * Also look for the name of the copy in the global list. ELSEIF((GLBVAR(I).EQ.'Bx field'.AND.K.EQ.1).OR. - (GLBVAR(I).EQ.'By field'.AND.K.EQ.2).OR. - (GLBVAR(I).EQ.'Bz field'.AND.K.EQ.3))THEN IGLB=I ENDIF 10 CONTINUE * Ensure we did find the vector. IF(ISCOPY.LE.0)THEN CALL INPMSG(INEXT,AUX1(1:NC1)//' is not a Global.') OK=.FALSE. INEXT=INEXT+4 GOTO 100 ELSE ISDATA=ISCOPY ENDIF * Add to the globals list, if not yet done. IF(IGLB.EQ.0.AND.NGLB.LT.MXVAR)THEN NGLB=NGLB+1 IF(K.EQ.1)THEN GLBVAR(NGLB)='Bx field' ELSEIF(K.EQ.2)THEN GLBVAR(NGLB)='By field' ELSEIF(K.EQ.3)THEN GLBVAR(NGLB)='Bz field' ENDIF IGLB=NGLB ELSEIF(IGLB.EQ.0.AND.NGLB.GE.MXVAR)THEN PRINT *,' !!!!!! MAGCMP WARNING : Unable to obtain'// - ' naming space for an interpolation vector;'// - ' do not reference the vector.' ENDIF IF(IGLB.NE.0)THEN GLBVAL(IGLB)=IREFB GLBMOD(IGLB)=5 ENDIF * Debugging. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAGCMP DEBUG :'', - '' Field: name='',A,'', ref='',I3,'', slot='',I3)') - AUX1(1:NC1),IREFB,ISCOPY ** Find out which direction the coordinate vector represents. IF(INPCMP(INEXT+2,'X')+INPCMP(INEXT+2,'R').NE.0)THEN IDIR=1 ELSEIF(INPCMP(INEXT+2,'Y')+INPCMP(INEXT+2,'PHI').NE.0)THEN IDIR=2 ELSEIF(INPCMP(INEXT+2,'Z').NE.0)THEN IDIR=3 ELSE CALL INPMSG(INEXT+2,'Not a valid direction.') IDIR=0 OK=.FALSE. INEXT=INEXT+4 GOTO 100 ENDIF * Debugging. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAGCMP DEBUG :'', - '' Direction: '',I1)') IDIR ** Extract the name of the coordinate vector. CALL INPSTR(INEXT+3,INEXT+3,AUX1,NC1) IF(NC1.LT.1)THEN AUX1='?' NC1=1 ENDIF * Scan the list of globals for the B vector. ISCOPY=0 IGLB=0 DO 30 I=1,NGLB IF(GLBVAR(I).EQ.AUX1(1:NC1))THEN * Ensure this is a Matrix. IF(GLBMOD(I).NE.5)THEN CALL INPMSG(INEXT+3,AUX1(1:NC1)// - ' is not a Matrix.') OK=.FALSE. GOTO 30 ENDIF * Locate it. ISLOT=MATSLT(NINT(GLBVAL(I))) IF(ISLOT.LE.0)THEN PRINT *,' !!!!!! MAGCMP WARNING : '//AUX1(1:NC1)// - ' can not be located in the Matrix buffer.' OK=.FALSE. * Ensure it is 1-dimensional. ELSEIF(MDIM(ISLOT).NE.1)THEN CALL INPMSG(INEXT+3,AUX1(1:NC1)// - ' is not 1-dimensional.') OK=.FALSE. * Ensure the length is the same as the B vector. ELSEIF(MLEN(ISLOT).NE.MLEN(ISDATA))THEN CALL INPMSG(INEXT+3, - 'Lengths of B and coord differ.') OK=.FALSE. * Duplicate coordinate, delete an old copy if there is one. ELSE IF(IREFV.NE.0)CALL MATADM('DELETE',IREFV,NDIM, - IDIM,IMOD,IFAIL) NDIM=MDIM(ISLOT) IMOD=MMOD(ISLOT) IDIM(1)=MSIZ(ISLOT,1) CALL MATADM('ALLOCATE',IREFV,NDIM,IDIM,IMOD,IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! MAGCMP WARNING : Failed'// - ' to obtain space for a copy of the'// - ' coordinate vector.' OK=.FALSE. ENDIF ISCOPY=MATSLT(IREFV) IF(ISCOPY.LE.0)THEN PRINT *,' !!!!!! MAGCMP WARNING : Failed'// - ' locate the copy of a coordinate'// - ' vector.' OK=.FALSE. ENDIF DO 40 J=1,MLEN(ISLOT) MVEC(MORG(ISCOPY)+J)=MVEC(MORG(ISLOT)+J) 40 CONTINUE ENDIF * Also look for the name of the copy in the global list. ELSEIF((GLBVAR(I).EQ.'Bx coord'.AND.K.EQ.1).OR. - (GLBVAR(I).EQ.'By coord'.AND.K.EQ.2).OR. - (GLBVAR(I).EQ.'Bz coord'.AND.K.EQ.3))THEN IGLB=I ENDIF 30 CONTINUE * Be sure we found the vector. IF(ISCOPY.LE.0)THEN CALL INPMSG(INEXT+3,AUX1(1:NC1)//' is not a Global.') OK=.FALSE. INEXT=INEXT+4 GOTO 100 ENDIF * Add to the globals list, if not yet done. IF(IGLB.EQ.0.AND.NGLB.LT.MXVAR)THEN NGLB=NGLB+1 IF(K.EQ.1)THEN GLBVAR(NGLB)='Bx coord' ELSEIF(K.EQ.2)THEN GLBVAR(NGLB)='By coord' ELSEIF(K.EQ.3)THEN GLBVAR(NGLB)='Bz coord' ENDIF IGLB=NGLB ELSEIF(IGLB.EQ.0.AND.NGLB.GE.MXVAR)THEN PRINT *,' !!!!!! MAGCMP WARNING : Unable to obtain'// - ' naming space for an interpolation vector;'// - ' do not reference the vector.' ENDIF IF(IGLB.NE.0)THEN GLBVAL(IGLB)=IREFV GLBMOD(IGLB)=5 ENDIF * Debugging. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAGCMP DEBUG :'', - '' Coordinates: name='',A,'', ref='',I3,'', slot='', - I3)') AUX1(1:NC1),IREFV,ISCOPY * Remember the source of B. IBTYPE=3 ** Update the pointer. INEXT=INEXT+4 *** Try the fixed value format. ELSEIF(INPTYP(INEXT).EQ.1.OR.INPTYP(INEXT).EQ.2)THEN * Read the value. CALL INPCHK(INEXT,2,IFAIL) IF(IFAIL.EQ.0)THEN CALL INPRDR(INEXT,B0,0.0) IBTYPE=1 ENDIF IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAGCMP DEBUG :'', - '' Component '',I1,'': fixed value '',E10.3, - '', IFAIL='',I1)') K,B0,IFAIL * Update the limits. BMIN=B0 BMAX=B0 * Update the pointer. INEXT=INEXT+1 *** Try the formula format. ELSEIF(INEXT.LE.NWORD)THEN * Retrieve the formula. CALL INPSTR(INEXT,INEXT,FUN,NCFUN) IF(NCFUN.LT.1)THEN FUN='?' NCFUN=1 ENDIF IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAGCMP DEBUG :'', - '' Component '',I1,'': formula '',A)') K,FUN(1:NCFUN) * Clear old entry point, if there is one. IF(IENTRY.NE.0)CALL ALGCLR(IENTRY) * Translate it. IF(INDEX(FUN(1:NCFUN),'@').NE.0)THEN NRES=1 PRINT *,' ------ MAGCMP MESSAGE : Please edit the'// - ' function.' CALL ALGEDT(VARLIS,NVAR,IENTRY,USE,NRES) IFAIL=0 * Usual function translation if not. ELSE CALL ALGPRE(FUN(1:NCFUN),NCFUN,VARLIS,NVAR,NRES,USE, - IENTRY,IFAIL) ENDIF * Check return code of translation. IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! MAGCMP WARNING : Error translating'// - ' a B function.' OK=.FALSE. CALL ALGCLR(IENTRY) * Check number of results returned by the function. ELSEIF(NRES.NE.1)THEN PRINT *,' !!!!!! MAGCMP WARNING : A B function'// - ' does not return 1 result.' OK=.FALSE. CALL ALGCLR(IENTRY) ELSE * Remember the source of B. IBTYPE=2 ENDIF * Set the limits. BMIN=0 BMAX=0 * Update the pointer. INEXT=INEXT+1 *** Unknown format. ELSE * Issue message. CALL INPMSG(INEXT,'Not a recognised format') * Set type to non-set. IBTYPE=0 * Set the limits. BMIN=0 BMAX=0 * Set OK flag. OK=.FALSE. ENDIF *** Transfer the results. IF(K.EQ.1)THEN B0X=B0 FUNB0X=FUN NCB0X=NCFUN IENB0X=IENTRY IRB0X=IREFB IRV0X=IREFV IBXTYP=IBTYPE IBXDIR=IDIR BFXMIN=BMIN BFXMAX=BMAX ELSEIF(K.EQ.2)THEN B0Y=B0 FUNB0Y=FUN NCB0Y=NCFUN IENB0Y=IENTRY IRB0Y=IREFB IRV0Y=IREFV IBYTYP=IBTYPE IBYDIR=IDIR BFYMIN=BMIN BFYMAX=BMAX ELSEIF(K.EQ.3)THEN B0Z=B0 FUNB0Z=FUN NCB0Z=NCFUN IENB0Z=IENTRY IRB0Z=IREFB IRV0Z=IREFV IBZTYP=IBTYPE IBZDIR=IDIR BFZMIN=BMIN BFZMAX=BMAX ENDIF *** Next component. 100 CONTINUE *** Now look for other elements, such as units. DO 50 I=INEXT,NWORD IF(INPCMP(I,'T#ESLA').NE.0)THEN BSCALE=100.0 ELSEIF(INPCMP(I,'G#AUSS')+INPCMP(I,'OE#RSTED').NE.0)THEN BSCALE=0.01 ELSEIF(INPCMP(I,'V.MICROSEC/CM2').NE.0)THEN BSCALE=1.0 ELSE CALL INPMSG(I,'Not a known keyword') OK=.FALSE. ENDIF 50 CONTINUE *** Dump the error messages. CALL INPERR *** Ensure no extra fields have been entered in polar coordinates. IF(POLAR.AND.(IBXTYP.NE.1.OR.B0X.NE.0.OR. - IBXTYP.NE.1.OR.B0X.NE.0))THEN PRINT *,' !!!!!! MAGCMP WARNING : In polar coordinates,'// - ' only Bz may be non-zero; Br and Bphi ignored.' OK=.FALSE. ENDIF *** See whether we have all components. IF(IBXTYP.EQ.0.OR.IBYTYP.EQ.0.OR.IBZTYP.EQ.0)THEN PRINT *,' !!!!!! MAGCMP WARNING : Not all magnetic'// - ' field components have been entered.' OK=.FALSE. ENDIF *** See whether we continue. IF(JFAIL.EQ.2.AND..NOT.OK)THEN PRINT *,' ###### MAGCMP ERROR : No magnetic field'// - ' because of the above errors.' IBXTYP=0 IBYTYP=0 IBZTYP=0 MAGSRC=0 MAGOK=.FALSE. RETURN ELSEIF(JFAIL.EQ.3.AND..NOT.OK)THEN PRINT *,' ###### MAGCMP ERROR : Program terminated'// - ' because of the above errors.' CALL QUIT RETURN ENDIF *** Determine the range of the magnetic field. IF(IBXTYP.EQ.2.OR.IBYTYP.EQ.2.OR.IBZTYP.EQ.2)THEN BFMIN=0 BFMAX=5 ELSE BFMIN=SQRT(BFXMIN**2+BFYMIN**2+BFZMIN**2) BFMAX=SQRT(BFXMAX**2+BFYMAX**2+BFZMAX**2) ENDIF *** This B field is not defined by a field map. MAGSRC=1 *** Set the magnetic field flag. IF((IBXTYP.EQ.1.AND.B0X.NE.0).OR.IBXTYP.GE.2.OR. - (IBYTYP.EQ.1.AND.B0Y.NE.0).OR.IBYTYP.GE.2.OR. - (IBZTYP.EQ.1.AND.B0Z.NE.0).OR.IBZTYP.GE.2)THEN MAGOK=.TRUE. ELSE MAGOK=.FALSE. ENDIF END +DECK,MAGINP. SUBROUTINE MAGINP *----------------------------------------------------------------------- * MAGINP - Routine reading the magnetic field data from input file. * VARIABLES : IUNIT : Unit system (0: internal, 1: Gauss, 2: T) * (Last changed on 13/ 2/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,BFIELD. +SEQ,PRINTPLOT. CHARACTER*(MXCHAR) STRING INTEGER INPCMP,NWORD,NC,IFAIL1,IFAIL2,I REAL SUSGSR,SUSWRR EXTERNAL INPCMP +SELF,IF=AST. EXTERNAL ASTCCH +SELF. *** Identify the routine. IF(LIDENT)PRINT *,' /// ROUTINE MAGINP ///' *** Print a heading for this section. WRITE(*,'(''1'')') PRINT *,' ================================================' PRINT *,' ========== Start of B-field input ==========' PRINT *,' ================================================' PRINT *,' ' *** Start the input loop. CALL INPPRM('B field','NEW-PRINT') 10 CONTINUE CALL INPWRD(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 *** Return to calling routine if the instruction contains an &. IF(STRING(1:1).EQ.'&')THEN GOTO 20 *** Magnetic field components. ELSEIF(INPCMP(1,'COMP#ONENTS').NE.0)THEN CALL MAGCMP *** Reset the magnetic field. ELSEIF(INPCMP(1,'RES#ET').NE.0)THEN IF(NWORD.EQ.1)THEN CALL MAGINT ELSE DO 30 I=2,NWORD IF(INPCMP(I,'COMP#ONENTS').NE.0)THEN MAGSRC=0 ELSEIF(INPCMP(I,'PERM#EABILITY').NE.0)THEN ALFA=0 ELSE CALL INPMSG(I,'Not a known item.') ENDIF 30 CONTINUE ENDIF *** Permeability. ELSEIF(INPCMP(1,'PERM#EABILITY').NE.0)THEN ** No arguments, print current values. IF(NWORD.EQ.1)THEN WRITE(LUNOUT,'(/'' Currently, the permeabilities'', - '' are set to the following values:'',/, - 5X,''Wires: '',E15.8,'' [Arbitrary units],'',/, - 5X,''Gas : '',E15.8,'' [Arbitrary units]'',/, - '' which leads to Alpha = '',E15.8/)') - SUSWIR,SUSGAS,ALFA ** One argument: look for the IGNORE keyword, otherwise reject. ELSEIF(NWORD.EQ.2)THEN IF(INPCMP(2,'IGN#ORE').NE.0)THEN ALFA=0.0 SUSWIR=1.0 SUSGAS=1.0 ELSE CALL INPMSG(2,'Not a valid option. ') ENDIF ** Two arguments: specification of new values. ELSEIF(NWORD.EQ.3)THEN CALL INPCHK(2,2,IFAIL1) CALL INPCHK(3,2,IFAIL2) CALL INPRDR(2,SUSWRR,1.0) CALL INPRDR(3,SUSGSR,1.0) * Reject negative permeabilities. IF(SUSWRR.LT.0.0.AND.IFAIL1.EQ.0)THEN CALL INPMSG(2,'Wire permeability not > 0.') IFAIL1=1 ELSE SUSWIR=SUSWRR ENDIF IF(SUSGSR.LT.0.0.AND.IFAIL2.EQ.0)THEN CALL INPMSG(2,'Gas permeability not > 0.') IFAIL2=1 ELSE SUSGAS=SUSGSR ENDIF * Calculate ALFA, the coefficient needed in the rest of the program. IF(SUSWIR.LE.0.AND.SUSGAS.LE.0)THEN ALFA=0 ELSE ALFA=(SUSWIR-SUSGAS)/(SUSWIR+SUSGAS) ENDIF ** Strange number of arguments. ELSE PRINT *,' !!!!!! MAGINP WARNING : PERMEABILITY'// - ' needs up to 2 arguments ; line is ignored.' ENDIF *** It is not possible to get here if the option was recognised. ELSE CALL INPSTR(1,1,STRING,NC) PRINT *,' !!!!!! MAGINP WARNING : '//STRING(1:NC)//' is'// - ' not a valid instruction ; line is ignored.' ENDIF *** Dump error messages. CALL INPERR *** And return for a new input line. GOTO 10 20 CONTINUE *** Register the amount of CPU time used for reading these data. CALL TIMLOG('Reading the magnetic field section: ') END +DECK,MAGINT. SUBROUTINE MAGINT *----------------------------------------------------------------------- * MAGINT - Initialises the B field. * (Last changed on 13/ 2/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,BFIELD. *** Set the overall flag. MAGOK=.FALSE. *** Source of the B field. MAGSRC=0 IBXTYP=0 IBYTYP=0 IBZTYP=0 *** Components when using a fixed field. B0X=0 B0Y=0 B0Z=0 *** Matrix references when interpolating. IRB0X=0 IRB0Y=0 IRB0Z=0 IRV0X=0 IRV0Y=0 IRV0Z=0 *** Directions when interpolating. IBXDIR=0 IBYDIR=0 IBZDIR=0 *** Function strings and lengths. FUNB0X=' ' FUNB0Y=' ' FUNB0Z=' ' NCB0X=1 NCB0Y=1 NCB0Z=1 IENB0X=0 IENB0Y=0 IENB0Z=0 *** Permeability. ALFA=0 SUSWIR=1 SUSGAS=1 *** Default unit: Tesla. BSCALE=100.0 *** B field range. BFXMIN=0 BFXMAX=0 BFYMIN=0 BFYMAX=0 BFZMIN=0 BFZMAX=0 BFMIN=0 BFMAX=0 END +DECK,MAPCHK. SUBROUTINE MAPCHK(IFAIL) *----------------------------------------------------------------------- * MAPCHK - Checks the element aspect ratio and measure range. * (Last changed on 26/ 1/99) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. +SEQ,FIELDMAP. REAL DMIN,DMAX,DIST,SMIN,SMAX,SURF,RMIN,RMAX,STEP INTEGER I,J,K,NP,NCHA,IFAIL1,IFAIL2,IASP,IVOL,IFAIL *** By default, this should work. IFAIL=0 *** Ensure there are some triangles / tetrahedrons. IF(NMAP.LE.0)THEN PRINT *,' !!!!!! MAPCHK WARNING : No elements in the'// - ' current map ; histograms not made, map rejected.' IFAIL=1 RETURN ENDIF *** Compute the range of volumes. DO 40 I=1,NMAP IF(MAPTYP.EQ.1.OR.MAPTYP.EQ.2.OR.MAPTYP.EQ.3)THEN SURF=ABS( - (XMAP(I,3)-XMAP(I,1))*(YMAP(I,2)-YMAP(I,1))- - (YMAP(I,3)-YMAP(I,1))*(XMAP(I,2)-XMAP(I,1)))/2 ELSEIF(MAPTYP.EQ.11.OR.MAPTYP.EQ.12.OR.MAPTYP.EQ.13)THEN SURF=ABS( - (XMAP(I,4)-XMAP(I,1))*( - (YMAP(I,2)-YMAP(I,1))*(ZMAP(I,3)-ZMAP(I,1))- - (YMAP(I,3)-YMAP(I,1))*(ZMAP(I,2)-ZMAP(I,1)))+ - (YMAP(I,4)-YMAP(I,1))*( - (ZMAP(I,2)-ZMAP(I,1))*(XMAP(I,3)-XMAP(I,1))- - (ZMAP(I,3)-ZMAP(I,1))*(XMAP(I,2)-XMAP(I,1)))+ - (ZMAP(I,4)-ZMAP(I,1))*( - (XMAP(I,2)-XMAP(I,1))*(YMAP(I,3)-YMAP(I,1))- - (XMAP(I,3)-XMAP(I,1))*(YMAP(I,2)-YMAP(I,1))))/6 ELSEIF(MAPTYP.EQ.14.OR.MAPTYP.EQ.15.OR.MAPTYP.EQ.16)THEN SURF=ABS( - (XMAP(I,4)-XMAP(I,1))*( - (YMAP(I,2)-YMAP(I,1))*(ZMAP(I,3)-ZMAP(I,1))- - (YMAP(I,3)-YMAP(I,1))*(ZMAP(I,2)-ZMAP(I,1)))+ - (YMAP(I,4)-YMAP(I,1))*( - (ZMAP(I,2)-ZMAP(I,1))*(XMAP(I,3)-XMAP(I,1))- - (ZMAP(I,3)-ZMAP(I,1))*(XMAP(I,2)-XMAP(I,1)))+ - (ZMAP(I,4)-ZMAP(I,1))*( - (XMAP(I,2)-XMAP(I,1))*(YMAP(I,3)-YMAP(I,1))- - (XMAP(I,3)-XMAP(I,1))*(YMAP(I,2)-YMAP(I,1)))) ELSE SURF=0 ENDIF IF(I.EQ.0)THEN SMIN=SURF SMAX=SURF ELSE SMIN=MIN(SMIN,SURF) SMAX=MAX(SMAX,SURF) ENDIF 40 CONTINUE *** Number of bins. NCHA=MIN(100,MXCHA) *** Check we do have a range and round it. SMIN=MAX(0.0,SMIN-0.1*(SMAX-SMIN)) SMAX=SMAX+0.1*(SMAX-SMIN) IF(SMIN.EQ.SMAX)THEN SMIN=SMIN-(1+ABS(SMIN)) SMAX=SMAX+(1+ABS(SMAX)) ENDIF CALL ROUND(SMIN,SMAX,NCHA,'LARGER,COARSER',STEP) *** Book histograms. CALL HISADM('ALLOCATE',IASP,NCHA,0.0,100.0,.FALSE.,IFAIL1) CALL HISADM('ALLOCATE',IVOL,NCHA,SMIN,SMAX,.FALSE.,IFAIL2) IF(IFAIL1.NE.0.OR.IFAIL2.NE.0)THEN PRINT *,' !!!!!! MAPCHK WARNING : Unable to allocate'// - ' histograms ; no check done.' CALL HISADM('DELETE',IASP,NCHA,0.0,100.0,.FALSE.,IFAIL1) CALL HISADM('DELETE',IVOL,NCHA,0.0,100.0,.FALSE.,IFAIL2) RETURN ENDIF *** Set the number of vertices. IF(MAPTYP.EQ.1.OR.MAPTYP.EQ.2.OR.MAPTYP.EQ.3)THEN NP=3 ELSEIF(MAPTYP.EQ.11.OR.MAPTYP.EQ.12.OR.MAPTYP.EQ.13)THEN NP=4 ELSEIF(MAPTYP.EQ.14.OR.MAPTYP.EQ.15.OR.MAPTYP.EQ.16)THEN NP=4 ELSE NP=0 ENDIF *** Loop over all triangles or tetrahedrons. DO 10 I=1,NMAP * And over all pairs of vertices. DO 20 J=1,NP-1 DO 30 K=J+1,NP * Compute distance. DIST=SQRT((XMAP(I,J)-XMAP(I,K))**2+(YMAP(I,J)-YMAP(I,K))**2+ - (ZMAP(I,J)-ZMAP(I,K))**2) * And update maximum/minimum. IF(K.EQ.2)THEN DMIN=DIST DMAX=DIST ELSE DMIN=MIN(DMIN,DIST) DMAX=MAX(DMAX,DIST) ENDIF * Next vertex pair. 30 CONTINUE 20 CONTINUE * Check for null-sizes. IF(DMIN.LE.0)THEN PRINT *,' !!!!!! MAPCHK WARNING : Found a shape with a'// - ' zero-length vertex separation; map rejected.' IFAIL=1 GOTO 10 ENDIF * Histogramming. CALL HISENT(IASP,DMAX/DMIN,1.0) ** Compute the surface or volume. IF(MAPTYP.EQ.1.OR.MAPTYP.EQ.2.OR.MAPTYP.EQ.3)THEN SURF=ABS( - (XMAP(I,3)-XMAP(I,1))*(YMAP(I,2)-YMAP(I,1))- - (YMAP(I,3)-YMAP(I,1))*(XMAP(I,2)-XMAP(I,1)))/2 ELSEIF(MAPTYP.EQ.11.OR.MAPTYP.EQ.12.OR.MAPTYP.EQ.13)THEN SURF=ABS( - (XMAP(I,4)-XMAP(I,1))*( - (YMAP(I,2)-YMAP(I,1))*(ZMAP(I,3)-ZMAP(I,1))- - (YMAP(I,3)-YMAP(I,1))*(ZMAP(I,2)-ZMAP(I,1)))+ - (YMAP(I,4)-YMAP(I,1))*( - (ZMAP(I,2)-ZMAP(I,1))*(XMAP(I,3)-XMAP(I,1))- - (ZMAP(I,3)-ZMAP(I,1))*(XMAP(I,2)-XMAP(I,1)))+ - (ZMAP(I,4)-ZMAP(I,1))*( - (XMAP(I,2)-XMAP(I,1))*(YMAP(I,3)-YMAP(I,1))- - (XMAP(I,3)-XMAP(I,1))*(YMAP(I,2)-YMAP(I,1))))/6 ELSEIF(MAPTYP.EQ.14.OR.MAPTYP.EQ.15.OR.MAPTYP.EQ.16)THEN SURF=ABS( - (XMAP(I,4)-XMAP(I,1))*( - (YMAP(I,2)-YMAP(I,1))*(ZMAP(I,3)-ZMAP(I,1))- - (YMAP(I,3)-YMAP(I,1))*(ZMAP(I,2)-ZMAP(I,1)))+ - (YMAP(I,4)-YMAP(I,1))*( - (ZMAP(I,2)-ZMAP(I,1))*(XMAP(I,3)-XMAP(I,1))- - (ZMAP(I,3)-ZMAP(I,1))*(XMAP(I,2)-XMAP(I,1)))+ - (ZMAP(I,4)-ZMAP(I,1))*( - (XMAP(I,2)-XMAP(I,1))*(YMAP(I,3)-YMAP(I,1))- - (XMAP(I,3)-XMAP(I,1))*(YMAP(I,2)-YMAP(I,1)))) ELSE SURF=0 ENDIF * Check for null-sizes. IF(SURF.LE.0)THEN PRINT *,' !!!!!! MAPCHK WARNING : Found a shape with a'// - ' zero surface or volume; map rejected.' IFAIL=1 GOTO 10 ENDIF * Histogramming. CALL HISENT(IVOL,SURF,1.0) * Update maxima and minima. IF(I.EQ.1)THEN SMIN=SURF SMAX=SURF RMIN=DMAX/DMIN RMAX=DMAX/DMIN ELSE SMIN=MIN(SMIN,SURF) SMAX=MAX(SMAX,SURF) RMIN=MIN(RMIN,DMAX/DMIN) RMAX=MAX(RMAX,DMAX/DMIN) ENDIF * Next triangle or tetrahedron. 10 CONTINUE *** Final output, aspect ratio plot. C CALL GRAOPT('LOG-Y') CALL HISPLT(IASP,'Largest / smallest vertex distance', - 'Aspect ratio',.TRUE.) CALL GRNEXT CALL GRALOG('Aspect ratio histogram') CALL HISADM('DELETE',IASP,0,0.0,0.0,.FALSE.,IFAIL1) C CALL GRAOPT('LIN-Y') * Volumes. CALL GRAOPT('LOG-Y') CALL HISPLT(IVOL,'Surface [cm2] or Volume [cm3]', - 'Element measure',.TRUE.) CALL GRNEXT CALL GRALOG('Element measure') CALL HISADM('DELETE',IVOL,0,0.0,0.0,.FALSE.,IFAIL2) CALL GRAOPT('LIN-Y') * Printout. WRITE(LUNOUT,'('' Aspect ratios: ''/ - 5X,''Smallest: '',F10.3/5X,''Largest: '',F10.3/ - '' Volumes or Surfaces: ''/ - 5X,''Smallest: '',E10.3/5X,''Largest: '',E10.3)') - RMIN,RMAX,SMIN,SMAX *** Record the time needed. CALL TIMLOG('Checking the mesh') END +DECK,MAPEPS. SUBROUTINE MAPEPS(IFAIL) *----------------------------------------------------------------------- * MAPEPS - Sorts the dielectric constants and the conductivities. * (Last changed on 29/11/99.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,FIELDMAP. +SEQ,PRINTPLOT. INTEGER IND(MXEPS),INEW,I,II,J,IFAIL REAL AUX *** Identify the routine if requested. IF(LIDENT)PRINT *,' /// ROUTINE MAPEPS ///' *** Assume the routine will fail. IFAIL=1 *** Sort the epsilons. CALL SORTZV(EPSMAT,IND,NEPS,0,0,0) *** Attribute new numbers to the volumes. DO 10 I=1,NMAP * Search what the old index of this material was. DO 20 J=1,NEPS IF(IND(J).EQ.MATMAP(I))THEN INEW=J GOTO 30 ENDIF 20 CONTINUE PRINT *,' !!!!!! MAPEPS WARNING : Unable to trace back a'// - ' material index; program bug, please report.' INEW=I 30 CONTINUE * Assign the new material number. MATMAP(I)=INEW 10 CONTINUE *** Sort the epsilons. DO 150 I=1,NEPS * Find the I'th epsilon. II=0 DO 110 J=I,NEPS IF(IND(J).EQ.I)II=J 110 CONTINUE * Exchange. AUX=EPSMAT(I) EPSMAT(I)=EPSMAT(IND(I)) EPSMAT(IND(I))=AUX IND(II)=IND(I) 150 CONTINUE *** Compute volumes and areas. DO 40 I=1,NEPS EPSSUR(I)=0 DO 50 J=1,NMAP IF(MATMAP(J).EQ.I)THEN IF(MAPTYP.EQ.1.OR.MAPTYP.EQ.2.OR.MAPTYP.EQ.3)THEN EPSSUR(I)=EPSSUR(I)+ABS( - (XMAP(J,3)-XMAP(J,1))*(YMAP(J,2)-YMAP(J,1))- - (YMAP(J,3)-YMAP(J,1))*(XMAP(J,2)-XMAP(J,1)))/2 ELSEIF(MAPTYP.EQ.11.OR.MAPTYP.EQ.12.OR.MAPTYP.EQ.13)THEN EPSSUR(I)=EPSSUR(I)+ABS( - (XMAP(J,4)-XMAP(J,1))*( - (YMAP(J,2)-YMAP(J,1))*(ZMAP(J,3)-ZMAP(J,1))- - (YMAP(J,3)-YMAP(J,1))*(ZMAP(J,2)-ZMAP(J,1)))+ - (YMAP(J,4)-YMAP(J,1))*( - (ZMAP(J,2)-ZMAP(J,1))*(XMAP(J,3)-XMAP(J,1))- - (ZMAP(J,3)-ZMAP(J,1))*(XMAP(J,2)-XMAP(J,1)))+ - (ZMAP(J,4)-ZMAP(J,1))*( - (XMAP(J,2)-XMAP(J,1))*(YMAP(J,3)-YMAP(J,1))- - (XMAP(J,3)-XMAP(J,1))*(YMAP(J,2)-YMAP(J,1))))/6 ELSEIF(MAPTYP.EQ.14.OR.MAPTYP.EQ.15.OR.MAPTYP.EQ.16)THEN EPSSUR(I)=EPSSUR(I)+ABS( - (XMAP(J,4)-XMAP(J,1))*( - (YMAP(J,2)-YMAP(J,1))*(ZMAP(J,3)-ZMAP(J,1))- - (YMAP(J,3)-YMAP(J,1))*(ZMAP(J,2)-ZMAP(J,1)))+ - (YMAP(J,4)-YMAP(J,1))*( - (ZMAP(J,2)-ZMAP(J,1))*(XMAP(J,3)-XMAP(J,1))- - (ZMAP(J,3)-ZMAP(J,1))*(XMAP(J,2)-XMAP(J,1)))+ - (ZMAP(J,4)-ZMAP(J,1))*( - (XMAP(J,2)-XMAP(J,1))*(YMAP(J,3)-YMAP(J,1))- - (XMAP(J,3)-XMAP(J,1))*(YMAP(J,2)-YMAP(J,1)))) ENDIF ENDIF 50 CONTINUE * Debugging output. IF(LDEBUG)THEN IF(MATSRC.EQ.'EPSILON')THEN WRITE(LUNOUT,'('' ++++++ MAPEPS DEBUG :'', - '' Material '',I3,'': epsilon='',E10.3,'', '', - '' surface '',E10.3)') I,EPSMAT(I),EPSSUR(I) ELSE WRITE(LUNOUT,'('' ++++++ MAPEPS DEBUG :'', - '' Material '',I3,'': sigma='',E10.3,'' S/m, '', - '' surface '',E10.3)') I,EPSMAT(I),EPSSUR(I) ENDIF ENDIF 40 CONTINUE *** Seems to have worked. IFAIL=0 END +DECK,MAPFMF. SUBROUTINE MAPFMF(IFAIL) *----------------------------------------------------------------------- * MAPFMF - Retrieves the field map data in binary format. * (Last changed on 13/ 3/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,FIELDMAP. +SEQ,CELLDATA. +SEQ,BFIELD. +SEQ,GASDATA. INTEGER I,J,K,IOS,NWORD,NC,IFAIL,IFAIL1,IVERS CHARACTER*(MXNAME) FILE *** Assume for the time being that this will fail. IFAIL=1 *** Get hold of the file name. CALL INPNUM(NWORD) * Make sure there is at least one argument. IF(NWORD.NE.2)THEN PRINT *,' !!!!!! MAPFMF WARNING : FETCH-FIELD-MAP takes 1'// - ' argument (a dataset name); the map will not be read.' RETURN ENDIF CALL INPSTR(2,2,FILE,NC) * Check the length. IF(NC.GT.MXNAME)PRINT *,' !!!!!! MAPFMF WARNING : The file', - ' name is truncated to MXNAME (=',MXNAME,') characters.' NC=MIN(NC,MXNAME) *** Open the file for sequential binary read. CALL DSNOPN(FILE,NC,12,'READ-BINARY',IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! MAPFMF WARNING : Opening '//FILE(1:NC)// - ' failed ; the field map will not be read.' CLOSE(UNIT=12,STATUS='KEEP',ERR=2030,IOSTAT=IOS) RETURN ENDIF *** Reset the field map. CALL MAPINT *** Read version number. READ(12,ERR=2010,IOSTAT=IOS) IVERS IF(IVERS.NE.3)THEN PRINT *,' !!!!!! MAPFMF WARNING : Format of '//FILE(1:NC)// - ' is not compatible with program version; not read.' CLOSE(UNIT=12,STATUS='KEEP',ERR=2030,IOSTAT=IOS) RETURN ENDIF *** Read # triangles, map order, availability, 3D, plot flag. READ(12,ERR=2010,IOSTAT=IOS) NMAP,MAPORD, - (MAPFLG(I),I=1,10+3*MXWMAP),MAPTYP,LMAPPL,NWMAP * Verify that the dimensions match. IF(NMAP.GT.MXMAP)THEN PRINT *,' !!!!!! MAPFMF WARNING : The map in '//FILE(1:NC)// - ' exceeds dimensions of this compilation; not read.' CALL MAPINT CLOSE(UNIT=12,STATUS='KEEP',ERR=2030,IOSTAT=IOS) RETURN ELSEIF(NWMAP.GT.MXWMAP)THEN PRINT *,' !!!!!! MAPFMF WARNING : Too many weighting'// - ' fields in '//FILE(1:NC)//' for this compilation;'// - ' not read.' CALL MAPINT CLOSE(UNIT=12,STATUS='KEEP',ERR=2030,IOSTAT=IOS) RETURN * Make sure there is a field map. ELSEIF(NMAP.LE.0.OR..NOT.MAPFLG(1))THEN PRINT *,' !!!!!! MAPFMF WARNING : The map in '//FILE(1:NC)// - ' is empty; file not read.' CALL MAPINT CLOSE(UNIT=12,STATUS='KEEP',ERR=2030,IOSTAT=IOS) RETURN ENDIF *** Read the triangles or tetrahedrons, dimensions and periodicities. IF(MAPFLG(1))READ(12,ERR=2010,IOSTAT=IOS) - ((XMAP(I,J),I=1,NMAP),J=1,4), - ((YMAP(I,J),I=1,NMAP),J=1,4), - ((ZMAP(I,J),I=1,NMAP),J=1,4), - XMMIN,XMMAX,YMMIN,YMMAX,ZMMIN,ZMMAX, - XAMIN,XAMAX,YAMIN,YAMAX,ZAMIN,ZAMAX, - SETAX,SETAY,SETAZ,SX,SY,SZ,PERX,PERY,PERZ, - PERMX,PERMY,PERMZ,PERAX,PERAY,PERAZ,PERRX,PERRY,PERRZ * The (Ex,Ey,Ez) field, if available. IF(MAPFLG(2))READ(12,ERR=2010,IOSTAT=IOS) - ((EXMAP(I,J),I=1,NMAP),J=1,10) IF(MAPFLG(3))READ(12,ERR=2010,IOSTAT=IOS) - ((EYMAP(I,J),I=1,NMAP),J=1,10) IF(MAPFLG(4))READ(12,ERR=2010,IOSTAT=IOS) - ((EZMAP(I,J),I=1,NMAP),J=1,10) * The potential and potential range, if available. IF(MAPFLG(5))READ(12,ERR=2010,IOSTAT=IOS) - ((VMAP(I,J),I=1,NMAP),J=1,10),VMMIN,VMMAX * The (Bx,By,Bz) field, if available. IF(MAPFLG(6))READ(12,ERR=2010,IOSTAT=IOS) - ((BXMAP(I,J),I=1,NMAP),J=1,10) IF(MAPFLG(7))READ(12,ERR=2010,IOSTAT=IOS) - ((BYMAP(I,J),I=1,NMAP),J=1,10) IF(MAPFLG(8))READ(12,ERR=2010,IOSTAT=IOS) - ((BZMAP(I,J),I=1,NMAP),J=1,10) * The material map, if available. IF(MAPFLG(9))READ(12,ERR=2010,IOSTAT=IOS) - (MATMAP(I),I=1,NMAP) * The weighting (Ex,Ey,Ez) field and label, if available. DO 10 K=1,NWMAP IF(MAPFLG(10+3*K-2))READ(12,ERR=2010,IOSTAT=IOS) - ((EWXMAP(I,J,K),I=1,NMAP),J=1,10) IF(MAPFLG(11+3*K-2))READ(12,ERR=2010,IOSTAT=IOS) - ((EWYMAP(I,J,K),I=1,NMAP),J=1,10) IF(MAPFLG(12+3*K-2))READ(12,ERR=2010,IOSTAT=IOS) - ((EWZMAP(I,J,K),I=1,NMAP),J=1,10) IF(MAPFLG(10+3*K-2).OR.MAPFLG(11+3*K-2).OR.MAPFLG(12+3*K-2)) - READ(12,ERR=2010,IOSTAT=IOS) EWSTYP(K) 10 CONTINUE *** Read the number of materials and the drift medium. READ(12,ERR=2010,IOSTAT=IOS) NEPS,IDRMAT * Verify that the dimensions match. IF(NEPS.GT.MXEPS)THEN PRINT *,' !!!!!! MAPFMF WARNING : The map in '//FILE(1:NC)// - ' exceeds dimensions of this compilation; not read.' CALL MAPINT CLOSE(UNIT=12,STATUS='KEEP',ERR=2030,IOSTAT=IOS) RETURN ENDIF *** Read the material table. READ(12,ERR=2010,IOSTAT=IOS) (EPSMAT(I),I=1,NEPS), - (EPSSUR(I),I=1,NEPS) *** Close the file. CLOSE(UNIT=12,STATUS='KEEP',ERR=2030,IOSTAT=IOS) *** Set the same limits for the cell. XMIN=XMMIN XMAX=XMMAX YMIN=YMMIN YMAX=YMMAX ZMIN=ZMMIN ZMAX=ZMMAX VMIN=VMMIN VMAX=VMMAX IF(PERX.OR.PERMX)SX=ABS(XMMAX-XMMIN) IF(PERY.OR.PERMY)SY=ABS(YMMAX-YMMIN) IF(PERZ.OR.PERMZ)SZ=ABS(ZMMAX-ZMMIN) IF(PERRX)THEN XMIN=YMMIN XMAX=YMMAX YMIN=-MAX(ABS(XMMIN),ABS(XMMAX)) YMAX=+MAX(ABS(XMMIN),ABS(XMMAX)) ZMIN=-MAX(ABS(XMMIN),ABS(XMMAX)) ZMAX=+MAX(ABS(XMMIN),ABS(XMMAX)) ELSEIF(PERRY)THEN XMIN=-MAX(ABS(XMMIN),ABS(XMMAX)) XMAX=+MAX(ABS(XMMIN),ABS(XMMAX)) YMIN=YMMIN YMAX=YMMAX ZMIN=-MAX(ABS(XMMIN),ABS(XMMAX)) ZMAX=+MAX(ABS(XMMIN),ABS(XMMAX)) ELSEIF(PERRZ)THEN XMIN=-MAX(ABS(XMMIN),ABS(XMMAX)) XMAX=+MAX(ABS(XMMIN),ABS(XMMAX)) YMIN=-MAX(ABS(XMMIN),ABS(XMMAX)) YMAX=+MAX(ABS(XMMIN),ABS(XMMAX)) ZMIN=YMMIN ZMAX=YMMAX ENDIF IF(PERAX)THEN YMIN=-MAX(ABS(YMMIN),ABS(YMMAX),ABS(ZMMIN),ABS(ZMMAX)) YMAX=+MAX(ABS(YMMIN),ABS(YMMAX),ABS(ZMMIN),ABS(ZMMAX)) ZMIN=-MAX(ABS(YMMIN),ABS(YMMAX),ABS(ZMMIN),ABS(ZMMAX)) ZMAX=+MAX(ABS(YMMIN),ABS(YMMAX),ABS(ZMMIN),ABS(ZMMAX)) ELSEIF(PERAY)THEN XMIN=-MAX(ABS(XMMIN),ABS(XMMAX),ABS(ZMMIN),ABS(ZMMAX)) XMAX=+MAX(ABS(XMMIN),ABS(XMMAX),ABS(ZMMIN),ABS(ZMMAX)) ZMIN=-MAX(ABS(XMMIN),ABS(XMMAX),ABS(ZMMIN),ABS(ZMMAX)) ZMAX=+MAX(ABS(XMMIN),ABS(XMMAX),ABS(ZMMIN),ABS(ZMMAX)) ELSEIF(PERAZ)THEN XMIN=-MAX(ABS(XMMIN),ABS(XMMAX),ABS(YMMIN),ABS(YMMAX)) XMAX=+MAX(ABS(XMMIN),ABS(XMMAX),ABS(YMMIN),ABS(YMMAX)) YMIN=-MAX(ABS(XMMIN),ABS(XMMAX),ABS(YMMIN),ABS(YMMAX)) YMAX=+MAX(ABS(XMMIN),ABS(XMMAX),ABS(YMMIN),ABS(YMMAX)) ENDIF *** Set magnetic field flag. IF(MAPFLG(6).AND.MAPFLG(7).AND.MAPFLG(8))THEN MAGOK=.TRUE. IF(MAGSRC.EQ.1)PRINT *,' ------ MAGFMF MESSAGE : B field'// - ' from &MAGNETIC replaced by a field map.' MAGSRC=2 IF(GASSET)PRINT *,' ------ MAPFMF MESSAGE : Previous gas'// - ' data deleted.' GASSET=.FALSE. ELSEIF(MAGSRC.EQ.2)THEN PRINT *,' ------ MAGFMF MESSAGE : The new field map has'// - ' no magnetic field; currently no magnetic field.' MAGSRC=0 MAGOK=.FALSE. IF(GASSET)PRINT *,' ------ MAPFMF MESSAGE : Previous gas'// - ' data deleted.' GASSET=.FALSE. ENDIF *** Register file access. CALL DSNLOG(FILE(1:NC),'Field map ','Sequential', - 'Bin Read ') *** Seems to have worked. IFAIL=0 RETURN *** Handle I/O errors. 2010 CONTINUE PRINT *,' !!!!!! MAPFMF WARNING : Error during binary read'// - ' to file '//FILE(1:NC)//'; resetting field map.' CALL INPIOS(IOS) CALL MAPINT CLOSE(UNIT=12,STATUS='KEEP',ERR=2030,IOSTAT=IOS) RETURN 2030 CONTINUE PRINT *,' !!!!!! MAPFMF WARNING : Error closing '//FILE(1:NC)// - ' after binary read; effect not known.' CALL INPIOS(IOS) END +DECK,MAPFMS. SUBROUTINE MAPFMS *----------------------------------------------------------------------- * MAPFMS - Writes the field map data in binary format. * (Last changed on 4/ 9/99.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,FIELDMAP. +SEQ,CELLDATA. INTEGER I,J,K,IOS,NWORD,NC,IFAIL CHARACTER*(MXNAME) FILE *** Make sure there is a field map. IF(NMAP.LE.0.OR..NOT.MAPFLG(1))THEN PRINT *,' !!!!!! MAPFMS WARNING : There is currently no'// - ' valid field map in memory; map not saved.' RETURN ENDIF *** Get hold of the file name. CALL INPNUM(NWORD) * Make sure there is at least one argument. IF(NWORD.NE.2)THEN PRINT *,' !!!!!! MAPFMS WARNING : SAVE-FIELD-MAP takes 1'// - ' argument (a dataset name); map will not be saved.' RETURN ENDIF CALL INPSTR(2,2,FILE,NC) * Check the length. IF(NC.GT.MXNAME)PRINT *,' !!!!!! MAPFMS WARNING : The file'// - ' name is truncated to MXNAME (=',MXNAME,') characters.' NC=MIN(NC,MXNAME) *** Open the file for sequential binary write. CALL DSNOPN(FILE,NC,12,'WRITE-BINARY',IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! MAPFMS WARNING : Opening '//FILE(1:NC)// - ' failed ; the field map will not be written.' RETURN ENDIF *** Write the version number. WRITE(12,ERR=2010,IOSTAT=IOS) 3 *** Write # triangles, map order, availability, 3D, plot flag. WRITE(12,ERR=2010,IOSTAT=IOS) NMAP,MAPORD, - (MAPFLG(I),I=1,10+3*MXWMAP),MAPTYP,LMAPPL,NWMAP *** Write the triangles or tetrahedrons, dimensions and periodicities. IF(MAPFLG(1))WRITE(12,ERR=2010,IOSTAT=IOS) - ((XMAP(I,J),I=1,NMAP),J=1,4), - ((YMAP(I,J),I=1,NMAP),J=1,4), - ((ZMAP(I,J),I=1,NMAP),J=1,4), - XMMIN,XMMAX,YMMIN,YMMAX,ZMMIN,ZMMAX, - XAMIN,XAMAX,YAMIN,YAMAX,ZAMIN,ZAMAX, - SETAX,SETAY,SETAZ,SX,SY,SZ,PERX,PERY,PERZ, - PERMX,PERMY,PERMZ,PERAX,PERAY,PERAZ,PERRX,PERRY,PERRZ * The (Ex,Ey,Ez) field, if available. IF(MAPFLG(2))WRITE(12,ERR=2010,IOSTAT=IOS) - ((EXMAP(I,J),I=1,NMAP),J=1,10) IF(MAPFLG(3))WRITE(12,ERR=2010,IOSTAT=IOS) - ((EYMAP(I,J),I=1,NMAP),J=1,10) IF(MAPFLG(4))WRITE(12,ERR=2010,IOSTAT=IOS) - ((EZMAP(I,J),I=1,NMAP),J=1,10) * The potential and potential range, if available. IF(MAPFLG(5))WRITE(12,ERR=2010,IOSTAT=IOS) - ((VMAP(I,J),I=1,NMAP),J=1,10),VMMIN,VMMAX * The (Bx,By,Bz) field, if available. IF(MAPFLG(6))WRITE(12,ERR=2010,IOSTAT=IOS) - ((BXMAP(I,J),I=1,NMAP),J=1,10) IF(MAPFLG(7))WRITE(12,ERR=2010,IOSTAT=IOS) - ((BYMAP(I,J),I=1,NMAP),J=1,10) IF(MAPFLG(8))WRITE(12,ERR=2010,IOSTAT=IOS) - ((BZMAP(I,J),I=1,NMAP),J=1,10) * The material map, if available. IF(MAPFLG(9))WRITE(12,ERR=2010,IOSTAT=IOS) - (MATMAP(I),I=1,NMAP) * The weighting (Ex,Ey,Ez) field and label, if available. DO 10 K=1,NWMAP IF(MAPFLG(10+3*K-2))WRITE(12,ERR=2010,IOSTAT=IOS) - ((EWXMAP(I,J,K),I=1,NMAP),J=1,10) IF(MAPFLG(11+3*K-2))WRITE(12,ERR=2010,IOSTAT=IOS) - ((EWYMAP(I,J,K),I=1,NMAP),J=1,10) IF(MAPFLG(12+3*K-2))WRITE(12,ERR=2010,IOSTAT=IOS) - ((EWZMAP(I,J,K),I=1,NMAP),J=1,10) IF(MAPFLG(10+3*K-2).OR.MAPFLG(11+3*K-2).OR.MAPFLG(12+3*K-2)) - WRITE(12,ERR=2010,IOSTAT=IOS) EWSTYP(K) 10 CONTINUE *** Write the number of materials and the drift medium. WRITE(12,ERR=2010,IOSTAT=IOS) NEPS,IDRMAT *** Write the material table. WRITE(12,ERR=2010,IOSTAT=IOS) (EPSMAT(I),I=1,NEPS), - (EPSSUR(I),I=1,NEPS) *** Close the file. CLOSE(UNIT=12,STATUS='KEEP',ERR=2030,IOSTAT=IOS) *** Register file access. CALL DSNLOG(FILE(1:NC),'Field map ','Sequential', - 'Bin Write ') RETURN *** Handle I/O errors. 2010 CONTINUE PRINT *,' !!!!!! MAPFMS WARNING : Error during binary write'// - ' to file '//FILE(1:NC)//'; deleting file.' CALL INPIOS(IOS) CLOSE(UNIT=12,STATUS='DELETE',ERR=2030,IOSTAT=IOS) RETURN 2030 CONTINUE PRINT *,' !!!!!! MAPFMS WARNING : Error closing '//FILE(1:NC)// - ' after binary write; effect not known.' CALL INPIOS(IOS) END +DECK,MAPFMR. SUBROUTINE MAPFMR(FMAP,NCMAP,IFORM,IDATA,IWMAP, - WXMIN,WYMIN,WZMIN,WXMAX,WYMAX,WZMAX,WINDOW,DELBKG, - MAPMAX,IFAIL) *----------------------------------------------------------------------- * MAPFMR - Reads one interpolation table. * (Last changed on 4/ 9/99.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. +SEQ,FIELDMAP. CHARACTER*(*) FMAP INTEGER NCMAP,IFAIL,IOS,I,IFORM,IDATA,IFAIL1,INPCMP,MAPMAX, - NWORD,IWMAP REAL WXMIN,WYMIN,WZMIN,WXMAX,WYMAX,WZMAX LOGICAL EXIST,WINDOW,DELBKG EXTERNAL INPCMP *** Identify the routine if requested. IF(LIDENT)PRINT *,' /// ROUTINE MAPFMR ///' *** Assume the routine will fail. IFAIL=1 *** Reset search for volumes. CALL MAPINR *** Debugging output. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFMR DEBUG : Field'', - '' map: '',A/26X,''Format: '',I2/26X,''Contents: '', - I2)') FMAP(1:NCMAP),IFORM,IDATA *** Check the existence of the field map or mesh file. CALL DSNINQ(FMAP,NCMAP,EXIST) IF(.NOT.EXIST)THEN PRINT *,' !!!!!! MAPFMR WARNING : Field map file ', - FMAP(1:NCMAP),' not found; field map not read.' RETURN ENDIF * Open the field map file. CALL DSNOPN(FMAP,NCMAP,12,'READ-FILE',IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! MAPFMR WARNING : Unable to open the'// - ' field map file ',FMAP(1:NCMAP),'; not read.' RETURN ENDIF * Record the opening. CALL DSNLOG(FMAP(1:NCMAP),'Field map ','Sequential', - 'Read only ') * Read the header records, switch to the data file. CALL INPSWI('UNIT12') CALL INPGET CALL INPNUM(NWORD) * Check for empty files. IF(NWORD.EQ.0)THEN PRINT *,' !!!!!! MAPFMR WARNING : The file ', - FMAP(1:NCMAP),' seems to be empty; not read.' CALL INPSWI('RESTORE') CLOSE(12,STATUS='KEEP',ERR=2030,IOSTAT=IOS) RETURN ENDIF *** In case of planar and real data, try Maxwell Parameter Extractor 2D. IF(INPCMP(1,'PLANE').NE.0.AND.INPCMP(3,'REAL').NE.0.AND. - INPCMP(4,'SIZE').NE.0)THEN IF(IFORM.NE.1.AND.IFORM.NE.0)PRINT *,' !!!!!! MAPFMR'// - ' WARNING : File ',FMAP(1:NCMAP),' seems to be in'// - ' Maxwell Parameter Extractor 2D format,'// - ' contrary to your indications.' CALL MAPFM2(FMAP,NCMAP,IDATA,IWMAP, - WXMIN,WYMIN,WZMIN,WXMAX,WYMAX,WZMAX,WINDOW,IFAIL1) MAPMAX=2 IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! MAPFMR WARNING : File ',FMAP(1:NCMAP), - ' could not successfully be read as Maxwell 2D.' CLOSE(12,STATUS='KEEP',ERR=2030,IOSTAT=IOS) RETURN ENDIF * Non-planar real data could be Maxwell Parameter Extractor 3D. ELSEIF(INPCMP(2,'REAL').NE.0.AND.INPCMP(3,'SIZE').NE.0)THEN IF(IFORM.NE.2.AND.IFORM.NE.0)PRINT *,' !!!!!! MAPFMR'// - ' WARNING : File ',FMAP(1:NCMAP),' seems to be in'// - ' Maxwell Parameter Extractor 3D format,'// - ' contrary to your indications.' CALL MAPFM3(FMAP,NCMAP,IDATA,IWMAP, - WXMIN,WYMIN,WZMIN,WXMAX,WYMAX,WZMAX,WINDOW,IFAIL1) MAPMAX=2 IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! MAPFMR WARNING : File ',FMAP(1:NCMAP), - ' could not successfully be read as Maxwell 3D.' CLOSE(12,STATUS='KEEP',ERR=2030,IOSTAT=IOS) RETURN ENDIF * Try Maxwell Field Simulator 3D. ELSEIF(INPCMP(1,'HYDRAS').NE.0.OR. - INPCMP(1,'POINTS').NE.0.OR. - (INPCMP(1,'SCALAR').NE.0.AND.INPCMP(2,'DATA').NE.0.AND. - NWORD.EQ.3).OR. - (INPCMP(1,'VECTOR').NE.0.AND.INPCMP(2,'DATA').NE.0.AND. - NWORD.EQ.3))THEN IF(IFORM.NE.4.AND.IFORM.NE.0)PRINT *,' !!!!!! MAPFMR'// - ' WARNING : File ',FMAP(1:NCMAP),' seems to be in'// - ' Maxwell Field Simulator 3D format,'// - ' contrary to your indications.' IF(INPCMP(1,'HYDRAS')+INPCMP(1,'POINTS').NE.0)IDATA=1 CALL MAPFM5(FMAP,NCMAP,IDATA,IWMAP, - WXMIN,WYMIN,WZMIN,WXMAX,WYMAX,WZMAX,WINDOW,DELBKG, - IFAIL1) MAPMAX=2 IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! MAPFMR WARNING : File ',FMAP(1:NCMAP), - ' could not successfully be read as Maxwell 3D.' CLOSE(12,STATUS='KEEP',ERR=2030,IOSTAT=IOS) RETURN ENDIF * Tosca. ELSEIF(IFORM.EQ.5)THEN CALL MAPFM6(FMAP,NCMAP,IDATA,IWMAP, - WXMIN,WYMIN,WZMIN,WXMAX,WYMAX,WZMAX,WINDOW,IFAIL1) MAPMAX=1 IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! MAPFMR WARNING : File ',FMAP(1:NCMAP), - ' could not successfully be read as Tosca.' CLOSE(12,STATUS='KEEP',ERR=2030,IOSTAT=IOS) RETURN ENDIF * Other formats are not currently known. ELSE PRINT *,' !!!!!! MAPFMR WARNING : Data in ',FMAP(1:NCMAP), - ' is in an unknown format; not read.' CALL INPSWI('RESTORE') CLOSE(12,STATUS='KEEP',ERR=2030,IOSTAT=IOS) RETURN ENDIF *** We should have read everything now. CLOSE(12,STATUS='KEEP',ERR=2030,IOSTAT=IOS) *** Debugging output. IF(LDEBUG)THEN WRITE(LUNOUT,'('' ++++++ MAPFMR DEBUG :'', - '' Current set of flags: '',13L1)') - (MAPFLG(I),I=1,13) IF(MAPFLG(1))WRITE(LUNOUT,'('' ++++++ MAPFMR'', - '' DEBUG : Grid covers: ''/ - 26X,E15.8,'' < x < '',E15.8/ - 26X,E15.8,'' < y < '',E15.8/ - 26X,E15.8,'' < z < '',E15.8)') - XMMIN,XMMAX,YMMIN,YMMAX,ZMMIN,ZMMAX IF(MAPFLG(5))WRITE(LUNOUT,'('' ++++++ MAPFMR'', - '' DEBUG : Potential range: ''/ - 26X,E15.8,'' < V < '',E15.8)') VMMIN,VMMAX ENDIF *** Seems to have worked, set error flag to OK and return. IFAIL=0 RETURN *** Handle error conditions. 2030 CONTINUE PRINT *,' !!!!!! MAPFMR WARNING : Error closing field map'// - ' file ',FMAP(1:NCMAP),'; map not available.' RETURN END +DECK,MAPFM2. SUBROUTINE MAPFM2(FMAP,NCMAP,IDATA,IWMAP, - WXMIN,WYMIN,WZMIN,WXMAX,WYMAX,WZMAX,WINDOW,IFAIL) *----------------------------------------------------------------------- * MAPFM2 - Reads a Maxwell 2D table of triangles. * (Last changed on 28/ 2/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. +SEQ,CELLDATA. +SEQ,FIELDMAP. +SEQ,CONSTANTS. INTEGER IMAP,IEPS,ICONT(3),IMAX,IWMAP, - I,J,IREAD,NCMAP,IFAIL,IFAIL1,IOS,NC, - INPCMP,IDATA,NDECL,NDELET REAL TEMPRE,TEMPIM,XAUX(3),YAUX(3),ZAUX(3),SUM, - WXMIN,WYMIN,WZMIN,WXMAX,WYMAX,WZMAX,T1,T2,T3,T4,ECOMP,DCOMP, - DXCOMP,DYCOMP CHARACTER*(*) FMAP CHARACTER*80 STRING CHARACTER*8 STRAUX LOGICAL SCALAR,WINDOW,NEWEPS EXTERNAL INPCMP *** Identify the routine if requested. IF(LIDENT)PRINT *,' /// ROUTINE MAPFM2 ///' C print *,' Cutting window: ',window C print *,wxmin,' < x < ',wxmax C print *,wymin,' < x < ',wymax *** Assume that this will fail. IFAIL=1 *** First read the line with number of triangles. CALL INPCHK(5,1,IFAIL1) CALL INPRDI(5,NDECL,0) IF(IFAIL1.NE.0.OR.NDECL.LE.0)THEN PRINT *,' !!!!!! MAPFM2 WARNING : The file ', - FMAP(1:NCMAP),' has an unreadable number'// - ' of triangles; not read.' CALL INPSWI('RESTORE') RETURN ENDIF * Debugging output. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM2 DEBUG : Number'', - '' of triangles: '',I5)') NDECL *** Progress printing. CALL PROFLD(2,'Triangles',REAL(NDECL)) *** See whether the data is scalar or vector. IF(INPCMP(2,'SCALAR').NE.0)THEN SCALAR=.TRUE. ELSEIF(INPCMP(2,'VECTOR').NE.0)THEN SCALAR=.FALSE. ELSE PRINT *,' !!!!!! MAPFM2 WARNING : The file ', - FMAP(1:NCMAP),' contains neither scalar nor'// - ' vectorial data; not read.' CALL INPSWI('RESTORE') RETURN ENDIF *** Next determine the contents of the file, read the next record. CALL INPGET * Set the expected word count. IF(SCALAR)THEN IMAX=1 ELSE IMAX=3 ENDIF * Initial contents flags. ICONT(1)=0 ICONT(2)=0 ICONT(3)=0 NEWEPS=.FALSE. * Loop over the words. DO 40 I=1,IMAX * Ex or EWx or Er or EWr. IF(INPCMP(I,'smooth(E(x))')+INPCMP(I,'E(x)')+ - INPCMP(I,'smooth(E(r))')+INPCMP(I,'E(r)').NE.0)THEN ICONT(I)=2 IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM2 DEBUG :'', - '' Field '',I1,'': x/r-component E field.'')') I IF(IDATA.EQ.0.OR.IDATA.EQ.2)THEN IF(MAPFLG(2))PRINT *,' ------ MAPFM2 MESSAGE :'// - ' Overwriting current Ex/r map.' MAPFLG(2)=.FALSE. ELSEIF(IDATA.EQ.10)THEN IF(MAPFLG(10+3*IWMAP-2)) - PRINT *,' ------ MAPFM2 MESSAGE :'// - ' Overwriting current weighting Ex/r map.' MAPFLG(10+3*IWMAP-2)=.FALSE. ENDIF IF(INPCMP(I,'smooth(E(r))')+INPCMP(I,'E(r)').NE.0) - PERRZ=.TRUE. * Ey or EWy. ELSEIF(INPCMP(I,'smooth(E(y))')+INPCMP(I,'E(y)').NE.0)THEN ICONT(I)=3 IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM2 DEBUG :'', - '' Field '',I1,'': y-component E field.'')') I IF(IDATA.EQ.0.OR.IDATA.EQ.2)THEN IF(MAPFLG(3))PRINT *,' ------ MAPFM2 MESSAGE :'// - ' Overwriting current Ey map.' MAPFLG(3)=.FALSE. ELSEIF(IDATA.EQ.10)THEN IF(MAPFLG(11+3*IWMAP-2)) - PRINT *,' ------ MAPFM2 MESSAGE :'// - ' Overwriting current weighting Ey map.' MAPFLG(11+3*IWMAP-2)=.FALSE. ENDIF * Ez or EWz. ELSEIF(INPCMP(I,'smooth(E(z))')+INPCMP(I,'E(z)').NE.0)THEN ICONT(I)=4 IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM2 DEBUG :'', - '' Field '',I1,'': z-component E field.'')') I IF(IDATA.EQ.0.OR.IDATA.EQ.2)THEN IF(MAPFLG(4))PRINT *,' ------ MAPFM2 MESSAGE :'// - ' Overwriting current Ez map.' MAPFLG(4)=.FALSE. ELSEIF(IDATA.EQ.10)THEN IF(MAPFLG(12+3*IWMAP-2)) - PRINT *,' ------ MAPFM2 MESSAGE :'// - ' Overwriting current weighting Ez map.' MAPFLG(12+3*IWMAP-2)=.FALSE. ENDIF * Dx or Dr. ELSEIF(INPCMP(I,'smooth(D(x))')+INPCMP(I,'D(x)')+ - INPCMP(I,'smooth(D(r))')+INPCMP(I,'D(r)').NE.0)THEN ICONT(I)=-9 IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM2 DEBUG :'', - '' Field '',I1,'': x-component D field.'')') I IF(MAPFLG(9))PRINT *,' ------ MAPFM2 MESSAGE :'// - ' Overwriting current material map.' MAPFLG(9)=.FALSE. MATSRC='EPSILON' * Dy. ELSEIF(INPCMP(I,'smooth(D(y))')+INPCMP(I,'D(y)').NE.0)THEN ICONT(I)=-9 IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM2 DEBUG :'', - '' Field '',I1,'': y-component D field.'')') I IF(MAPFLG(9))PRINT *,' ------ MAPFM2 MESSAGE :'// - ' Overwriting current material map.' MAPFLG(9)=.FALSE. MATSRC='EPSILON' * Dz. ELSEIF(INPCMP(I,'smooth(D(z))')+INPCMP(I,'D(z)').NE.0)THEN ICONT(I)=-9 IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM2 DEBUG :'', - '' Field '',I1,'': z-component D field.'')') I IF(MAPFLG(9))PRINT *,' ------ MAPFM2 MESSAGE :'// - ' Overwriting current material map.' MAPFLG(9)=.FALSE. MATSRC='EPSILON' * V ELSEIF(INPCMP(I,'smooth(voltage)')+INPCMP(I,'voltage').NE.0)THEN ICONT(I)=5 IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM2 DEBUG :'', - '' Field '',I1,'': potential.'')') I IF(MAPFLG(5))PRINT *,' ------ MAPFM2 MESSAGE :'// - ' Overwriting current potential map.' MAPFLG(5)=.FALSE. * Bx ELSEIF(INPCMP(I,'smooth(B(x))')+INPCMP(I,'B(x)')+ - INPCMP(I,'smooth(B(r))')+INPCMP(I,'B(r)').NE.0)THEN ICONT(I)=6 IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM2 DEBUG :'', - '' Field '',I1,'': x/r-component B field.'')') I IF(MAPFLG(6))PRINT *,' ------ MAPFM2 MESSAGE :'// - ' Overwriting current Bx/r map.' MAPFLG(6)=.FALSE. IF(INPCMP(I,'smooth(B(r))')+INPCMP(I,'B(r)').NE.0) - PERRZ=.TRUE. * By ELSEIF(INPCMP(I,'smooth(B(y))')+INPCMP(I,'B(y)').NE.0)THEN ICONT(I)=7 IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM2 DEBUG :'', - '' Field '',I1,'': y-component B field.'')') I IF(MAPFLG(7))PRINT *,' ------ MAPFM2 MESSAGE :'// - ' Overwriting current By map.' MAPFLG(7)=.FALSE. * Bz ELSEIF(INPCMP(I,'smooth(B(z))')+INPCMP(I,'B(z)').NE.0)THEN ICONT(I)=8 IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM2 DEBUG :'', - '' Field '',I1,'': z-component B field.'')') I IF(MAPFLG(8))PRINT *,' ------ MAPFM2 MESSAGE :'// - ' Overwriting current Bz map.' MAPFLG(8)=.FALSE. * epsilon ELSEIF(INPCMP(I,'(r( 1.00000e+00) * epsilon)')+ - INPCMP(I,'(r( 1.00000e+000) * epsilon)').NE.0)THEN ICONT(I)=9 IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM2 DEBUG :'', - '' Field '',I1,'': dielectric constant.'')') I IF(MAPFLG(9))PRINT *,' ------ MAPFM2 MESSAGE :'// - ' Overwriting material map.' MAPFLG(9)=.FALSE. MATSRC='EPSILON' * sigma. ELSEIF(INPCMP(I,'(r( 1.00000e+00) * sigma)')+ - INPCMP(I,'(r( 1.00000e+000) * sigma)').NE.0)THEN ICONT(I)=9 IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM2 DEBUG :'', - '' Field '',I1,'': Conductivity.'')') I IF(MAPFLG(9))PRINT *,' ------ MAPFM2 MESSAGE :'// - ' Overwriting material map.' MAPFLG(9)=.FALSE. MATSRC='SIGMA' * dummy field ELSEIF(INPCMP(I,'smooth(0)')+INPCMP(I,'0')+ - INPCMP(I,'r( 0.00000e+00)')+ - INPCMP(I,'(r( 1.00000e+00) * )')+ - INPCMP(I,'(r( 0.00000e+000) * epsilon)')+ - INPCMP(I,'(r( 0.00000e+00) * epsilon)')+ - INPCMP(I,'(r( 0.00000e+000) * sigma)')+ - INPCMP(I,'(r( 0.00000e+00) * sigma)').NE.0)THEN ICONT(I)=0 IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM2 DEBUG :'', - '' Field '',I1,'': dummy.'')') I * unrecognised items. ELSE CALL INPSTR(I,I,STRING,NC) PRINT *,' !!!!!! MAPFM2 WARNING : The file ', - FMAP(1:NCMAP),' contains a "'//STRING(1:NC)// - '" field which is not known; field ignored.' ICONT(I)=0 IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM2 DEBUG :'', - '' Field '',I1,'': not recognised.'')') I ENDIF * Ensure that the data type matches the declared type. IF(((ICONT(I).EQ.2.OR.ICONT(I).EQ.3.OR.ICONT(I).EQ.4).AND. - (IDATA.NE.0.AND.IDATA.NE.2.AND.IDATA.NE.10)).OR. - (ICONT(I).EQ.5.AND.(IDATA.NE.0.AND.IDATA.NE.5)).OR. - ((ICONT(I).EQ.6.OR.ICONT(I).EQ.7.OR.ICONT(I).EQ.8).AND. - (IDATA.NE.0.AND.IDATA.NE.6)).OR. - ((ICONT(I).EQ.9.OR.ICONT(I).EQ.-9).AND. - (IDATA.NE.0.AND.IDATA.NE.9)))THEN PRINT *,' !!!!!! MAPFM2 WARNING : Field ',I,' of file ', - FMAP(1:NCMAP),' does not contain the declared', - ' kind of data; skipped.' ICONT(I)=0 ENDIF 40 CONTINUE *** Switch back to regular input. CALL INPSWI('RESTORE') *** Loop over the triangles. I=0 NDELET=0 DO 10 IREAD=1,NDECL IF(IREAD.EQ.MAX(1,NDECL/100)*(IREAD/MAX(1,NDECL/100))) - CALL PROSTA(2,REAL(IREAD)) *** Increment triangle count, checking there is space. IF(I+1.GT.MXMAP)THEN PRINT *,' !!!!!! MAPFM2 WARNING : Number of'// - ' triangles in ',FMAP(1:NCMAP), - ' exceeds compilation limit; file not read.' RETURN ELSE I=I+1 ENDIF *** Skip until the line with the word "Vertices". 21 CONTINUE READ(12,'(A8)',END=2000,ERR=2010,IOSTAT=IOS) STRAUX IF(STRAUX.NE.'Vertices')GOTO 21 *** Read vertex coordinates. DO 20 J=1,3 * If the grid is already defined, merely store for check. IF(MAPFLG(1))THEN READ(12,'(E27.20,1X,E27.20,1X,E27.7)',END=2000,ERR=2010, - IOSTAT=IOS) XAUX(J),YAUX(J),ZAUX(J) XAUX(J)=XAUX(J)*100 YAUX(J)=YAUX(J)*100 ZAUX(J)=ZAUX(J)*100 * See whether the triangle fits in the window. IF(WINDOW.AND.(XAUX(J).LT.WXMIN.OR.XAUX(J).GT.WXMAX.OR. - YAUX(J).LT.WYMIN.OR.YAUX(J).GT.WYMAX))THEN NDELET=NDELET+1 I=I-1 GOTO 10 ENDIF * Otherwise store the grid, converting units from m to cm. ELSE READ(12,'(E27.20,1X,E27.20,1X,E27.7)',END=2000,ERR=2010, - IOSTAT=IOS) XMAP(I,J),YMAP(I,J),ZMAP(I,J) XMAP(I,J)=XMAP(I,J)*100 YMAP(I,J)=YMAP(I,J)*100 ZMAP(I,J)=ZMAP(I,J)*100 * See whether the triangle fits in the window. IF(WINDOW.AND. - (XMAP(I,J).LT.WXMIN.OR.XMAP(I,J).GT.WXMAX.OR. - YMAP(I,J).LT.WYMIN.OR.YMAP(I,J).GT.WYMAX))THEN NDELET=NDELET+1 C print *,' Elimination ',ndelet,' at triangle ',iread C print *,' point: ',xmap(i,j),ymap(i,j) I=I-1 GOTO 10 ENDIF * Update maxima and minima. IF(I.EQ.1.AND.J.EQ.1)THEN XMMIN=XMAP(I,J) XMMAX=XMAP(I,J) YMMIN=YMAP(I,J) YMMAX=YMAP(I,J) ELSE XMMIN=MIN(XMMIN,XMAP(I,J)) XMMAX=MAX(XMMAX,XMAP(I,J)) YMMIN=MIN(YMMIN,YMAP(I,J)) YMMAX=MAX(YMMAX,YMAP(I,J)) ENDIF * Update angular range. IF(XMAP(I,J).NE.0.OR.YMAP(I,J).NE.0)THEN IF(SETAZ)THEN ZAMIN=MIN(ZAMIN,ATAN2(YMAP(I,J),XMAP(I,J))) ZAMAX=MAX(ZAMAX,ATAN2(YMAP(I,J),XMAP(I,J))) ELSE ZAMIN=ATAN2(YMAP(I,J),XMAP(I,J)) ZAMAX=ATAN2(YMAP(I,J),XMAP(I,J)) SETAZ=.TRUE. ENDIF ENDIF ENDIF 20 CONTINUE * Now check that the triangles fit. IF(MAPFLG(1))THEN CALL MAPIND((XAUX(1)+XAUX(2)+XAUX(3))/3, - (YAUX(1)+YAUX(2)+YAUX(3))/3, - (ZAUX(1)+ZAUX(2)+ZAUX(3))/3,T1,T2,T3,T4,IMAP) IF(I.NE.IMAP)THEN PRINT *,' !!!!!! MAPFM2 WARNING : The grid in ', - FMAP(1:NCMAP),' does not match the current'// - ' grid; file not read.' RETURN ENDIF ENDIF *** Read scalar field values over the triangle. IF(SCALAR)THEN SUM=0 ** Read field values over the triangle. DO 60 J=1,6 READ(12,'(E27.20,1X,E27.20)',END=2000,ERR=2010, - IOSTAT=IOS) TEMPRE,TEMPIM * Can be either a potential. IF(ICONT(1).EQ.5)THEN IF(J.EQ.1)THEN VMAP(I,1)=TEMPRE ELSEIF(J.EQ.4)THEN VMAP(I,2)=TEMPRE ELSEIF(J.EQ.6)THEN VMAP(I,3)=TEMPRE ELSEIF(J.EQ.2)THEN VMAP(I,4)=TEMPRE ELSEIF(J.EQ.3)THEN VMAP(I,5)=TEMPRE ELSEIF(J.EQ.5)THEN VMAP(I,6)=TEMPRE ENDIF * Or a dielectricum. ELSEIF(ICONT(1).EQ.9)THEN SUM=SUM+TEMPRE ENDIF 60 CONTINUE ** If dielectricum, identify the material. IF(ICONT(1).EQ.9)THEN SUM=SUM/(600*EPS0) IEPS=-1 DO 100 J=1,NEPS IF(ABS(SUM-EPSMAT(J)).LT.1E-4*(ABS(SUM)+ - ABS(EPSMAT(J))))IEPS=J 100 CONTINUE IF(IEPS.LT.0.AND.NEPS.GE.MXEPS)THEN PRINT *,' !!!!!! MAPFM2 WARNING : Unable'// - ' to store a dielectricum from file ', - FMAP(1:NCMAP),'; file not read.' RETURN ELSEIF(IEPS.LT.0)THEN NEPS=NEPS+1 IEPS=NEPS EPSMAT(IEPS)=SUM IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM2'', - '' DEBUG : Adding dielectricum with'', - '' eps='',E10.3,''.'')') EPSMAT(IEPS) ENDIF MATMAP(I)=IEPS NEWEPS=.TRUE. ** If a potential, keep track of potential range. ELSEIF(ICONT(1).EQ.5)THEN IF(I.EQ.1)THEN VMMIN=VMAP(I,1) VMMAX=VMAP(I,1) ENDIF VMMIN=MIN(VMMIN,VMAP(I,1),VMAP(I,2),VMAP(I,3), - VMAP(I,4),VMAP(I,5),VMAP(I,6)) VMMAX=MAX(VMMAX,VMAP(I,1),VMAP(I,2),VMAP(I,3), - VMAP(I,4),VMAP(I,5),VMAP(I,6)) ENDIF *** Read vectorial field values over the triangle. ELSE * Take care of knowing |D| either from Ex or by summing. IF(ICONT(1).EQ.-9.AND.ICONT(2).EQ.-9)THEN DXCOMP=0 DYCOMP=0 ELSEIF(MAPFLG(10))THEN DXCOMP=EXMAP(I,1) DYCOMP=EYMAP(I,1) ENDIF * Prepare a summing scalar for epsilons entered as such. SUM=0 * Read the various fields. DO 30 J=1,18 READ(12,'(E27.20,1X,E27.20)',END=2000,ERR=2010, - IOSTAT=IOS) TEMPRE,TEMPIM * Averaging of epsilons. IF(ICONT(1).EQ.9)THEN IF(J.LE.6)SUM=SUM+TEMPRE ELSEIF(ICONT(2).EQ.9)THEN IF(J.GT.6.AND.J.LE.12)SUM=SUM+TEMPRE ELSEIF(ICONT(3).EQ.9)THEN IF(J.GT.13.AND.J.LE.18)SUM=SUM+TEMPRE ENDIF * Ex or Bx corner 1. IF(J.EQ.1)THEN IF(ICONT(1).EQ.2)THEN IF(IDATA.EQ.0.OR.IDATA.EQ.2)THEN EXMAP(I,1)=TEMPRE/100 ELSEIF(IDATA.EQ.10)THEN EWXMAP(I,1,IWMAP)=TEMPRE/100 ENDIF ELSEIF(ICONT(1).EQ.6)THEN BXMAP(I,1)=TEMPRE ELSEIF(ICONT(1).EQ.-9)THEN DXCOMP=DXCOMP+TEMPRE/100 ENDIF * Ex or Bx corner 2. ELSEIF(J.EQ.4)THEN IF(ICONT(1).EQ.2)THEN IF(IDATA.EQ.0.OR.IDATA.EQ.2)THEN EXMAP(I,2)=TEMPRE/100 ELSEIF(IDATA.EQ.10)THEN EWXMAP(I,2,IWMAP)=TEMPRE/100 ENDIF ELSEIF(ICONT(1).EQ.6)THEN BXMAP(I,2)=TEMPRE ELSEIF(ICONT(1).EQ.-9)THEN DXCOMP=DXCOMP+TEMPRE/100 ENDIF * Ex or Bx corner 3. ELSEIF(J.EQ.6)THEN IF(ICONT(1).EQ.2)THEN IF(IDATA.EQ.0.OR.IDATA.EQ.2)THEN EXMAP(I,3)=TEMPRE/100 ELSEIF(IDATA.EQ.10)THEN EWXMAP(I,3,IWMAP)=TEMPRE/100 ENDIF ELSEIF(ICONT(1).EQ.6)THEN BXMAP(I,3)=TEMPRE ELSEIF(ICONT(1).EQ.-9)THEN DXCOMP=DXCOMP+TEMPRE/100 ENDIF * Ex or Bx corner 4. ELSEIF(J.EQ.2)THEN IF(ICONT(1).EQ.2)THEN IF(IDATA.EQ.0.OR.IDATA.EQ.2)THEN EXMAP(I,4)=TEMPRE/100 ELSEIF(IDATA.EQ.10)THEN EWXMAP(I,4,IWMAP)=TEMPRE/100 ENDIF ELSEIF(ICONT(1).EQ.6)THEN BXMAP(I,4)=TEMPRE ELSEIF(ICONT(1).EQ.-9)THEN DXCOMP=DXCOMP+TEMPRE/100 ENDIF * Ex or Bx corner 5. ELSEIF(J.EQ.3)THEN IF(ICONT(1).EQ.2)THEN IF(IDATA.EQ.0.OR.IDATA.EQ.2)THEN EXMAP(I,5)=TEMPRE/100 ELSEIF(IDATA.EQ.10)THEN EWXMAP(I,5,IWMAP)=TEMPRE/100 ENDIF ELSEIF(ICONT(1).EQ.6)THEN BXMAP(I,5)=TEMPRE ELSEIF(ICONT(1).EQ.-9)THEN DXCOMP=DXCOMP+TEMPRE/100 ENDIF * Ex or Bx corner 6. ELSEIF(J.EQ.5)THEN IF(ICONT(1).EQ.2)THEN IF(IDATA.EQ.0.OR.IDATA.EQ.2)THEN EXMAP(I,6)=TEMPRE/100 ELSEIF(IDATA.EQ.10)THEN EWXMAP(I,6,IWMAP)=TEMPRE/100 ENDIF ELSEIF(ICONT(1).EQ.6)THEN BXMAP(I,6)=TEMPRE ELSEIF(ICONT(1).EQ.-9)THEN DXCOMP=DXCOMP+TEMPRE/100 ENDIF * Ey or By corner 1. ELSEIF(J.EQ.7)THEN IF(ICONT(2).EQ.3)THEN IF(IDATA.EQ.0.OR.IDATA.EQ.2)THEN EYMAP(I,1)=TEMPRE/100 ELSEIF(IDATA.EQ.10)THEN EWYMAP(I,1,IWMAP)=TEMPRE/100 ENDIF ELSEIF(ICONT(2).EQ.7)THEN BYMAP(I,1)=TEMPRE ELSEIF(ICONT(2).EQ.-9)THEN DYCOMP=DYCOMP+TEMPRE/100 ENDIF * Ey or By corner 2. ELSEIF(J.EQ.10)THEN IF(ICONT(2).EQ.3)THEN IF(IDATA.EQ.0.OR.IDATA.EQ.2)THEN EYMAP(I,2)=TEMPRE/100 ELSEIF(IDATA.EQ.10)THEN EWYMAP(I,2,IWMAP)=TEMPRE/100 ENDIF ELSEIF(ICONT(2).EQ.7)THEN BYMAP(I,2)=TEMPRE ELSEIF(ICONT(2).EQ.-9)THEN DYCOMP=DYCOMP+TEMPRE/100 ENDIF * Ey or By corner 3. ELSEIF(J.EQ.12)THEN IF(ICONT(2).EQ.3)THEN IF(IDATA.EQ.0.OR.IDATA.EQ.2)THEN EYMAP(I,3)=TEMPRE/100 ELSEIF(IDATA.EQ.10)THEN EWYMAP(I,3,IWMAP)=TEMPRE/100 ENDIF ELSEIF(ICONT(2).EQ.7)THEN BYMAP(I,3)=TEMPRE ELSEIF(ICONT(2).EQ.-9)THEN DYCOMP=DYCOMP+TEMPRE/100 ENDIF * Ey or By corner 4. ELSEIF(J.EQ.8)THEN IF(ICONT(2).EQ.3)THEN IF(IDATA.EQ.0.OR.IDATA.EQ.2)THEN EYMAP(I,4)=TEMPRE/100 ELSEIF(IDATA.EQ.10)THEN EWYMAP(I,4,IWMAP)=TEMPRE/100 ENDIF ELSEIF(ICONT(2).EQ.7)THEN BYMAP(I,4)=TEMPRE ELSEIF(ICONT(2).EQ.-9)THEN DYCOMP=DYCOMP+TEMPRE/100 ENDIF * Ey or By corner 5. ELSEIF(J.EQ.9)THEN IF(ICONT(2).EQ.3)THEN IF(IDATA.EQ.0.OR.IDATA.EQ.2)THEN EYMAP(I,5)=TEMPRE/100 ELSEIF(IDATA.EQ.10)THEN EWYMAP(I,5,IWMAP)=TEMPRE/100 ENDIF ELSEIF(ICONT(2).EQ.7)THEN BYMAP(I,5)=TEMPRE ELSEIF(ICONT(2).EQ.-9)THEN DYCOMP=DYCOMP+TEMPRE/100 ENDIF * Ey or By corner 6. ELSEIF(J.EQ.11)THEN IF(ICONT(2).EQ.3)THEN IF(IDATA.EQ.0.OR.IDATA.EQ.2)THEN EYMAP(I,6)=TEMPRE/100 ELSEIF(IDATA.EQ.10)THEN EWYMAP(I,6,IWMAP)=TEMPRE/100 ENDIF ELSEIF(ICONT(2).EQ.7)THEN BYMAP(I,6)=TEMPRE ELSEIF(ICONT(2).EQ.-9)THEN DYCOMP=DYCOMP+TEMPRE/100 ENDIF * Ez or Bz corner 1. ELSEIF(J.EQ.13)THEN IF(ICONT(3).EQ.4)THEN IF(IDATA.EQ.0.OR.IDATA.EQ.2)THEN EZMAP(I,1)=TEMPRE/100 ELSEIF(IDATA.EQ.10)THEN EWZMAP(I,1,IWMAP)=TEMPRE/100 ENDIF ELSEIF(ICONT(3).EQ.8)THEN BZMAP(I,1)=TEMPRE ENDIF * Ez or Bz corner 2. ELSEIF(J.EQ.16)THEN IF(ICONT(3).EQ.4)THEN IF(IDATA.EQ.0.OR.IDATA.EQ.2)THEN EZMAP(I,2)=TEMPRE/100 ELSEIF(IDATA.EQ.10)THEN EWZMAP(I,2,IWMAP)=TEMPRE/100 ENDIF ELSEIF(ICONT(3).EQ.8)THEN BZMAP(I,2)=TEMPRE ENDIF * Ez or Bz corner 3. ELSEIF(J.EQ.18)THEN IF(ICONT(3).EQ.4)THEN IF(IDATA.EQ.0.OR.IDATA.EQ.2)THEN EZMAP(I,3)=TEMPRE/100 ELSEIF(IDATA.EQ.10)THEN EWZMAP(I,3,IWMAP)=TEMPRE/100 ENDIF ELSEIF(ICONT(3).EQ.8)THEN BZMAP(I,3)=TEMPRE ENDIF * Ez or Bz corner 4. ELSEIF(J.EQ.14)THEN IF(ICONT(3).EQ.4)THEN IF(IDATA.EQ.0.OR.IDATA.EQ.2)THEN EZMAP(I,4)=TEMPRE/100 ELSEIF(IDATA.EQ.10)THEN EWZMAP(I,4,IWMAP)=TEMPRE/100 ENDIF ELSEIF(ICONT(3).EQ.8)THEN BZMAP(I,4)=TEMPRE ENDIF * Ez or Bz corner 5. ELSEIF(J.EQ.15)THEN IF(ICONT(3).EQ.4)THEN IF(IDATA.EQ.0.OR.IDATA.EQ.2)THEN EZMAP(I,5)=TEMPRE/100 ELSEIF(IDATA.EQ.10)THEN EWZMAP(I,5,IWMAP)=TEMPRE/100 ENDIF ELSEIF(ICONT(3).EQ.8)THEN BZMAP(I,5)=TEMPRE ENDIF * Ez or Bz corner 6. ELSEIF(J.EQ.17)THEN IF(ICONT(3).EQ.4)THEN IF(IDATA.EQ.0.OR.IDATA.EQ.2)THEN EZMAP(I,6)=TEMPRE/100 ELSEIF(IDATA.EQ.10)THEN EWZMAP(I,6,IWMAP)=TEMPRE/100 ENDIF ELSEIF(ICONT(3).EQ.8)THEN BZMAP(I,6)=TEMPRE ENDIF ENDIF 30 CONTINUE ** If dielectricum, identify the material. IF(ICONT(1).EQ.9.OR.ICONT(2).EQ.9.OR.ICONT(3).EQ.9)THEN SUM=SUM/(600*EPS0) IEPS=-1 DO 160 J=1,NEPS IF(ABS(SUM-EPSMAT(J)).LT.1E-4*(ABS(SUM)+ - ABS(EPSMAT(J))))IEPS=J 160 CONTINUE IF(IEPS.LT.0.AND.NEPS.GE.MXEPS)THEN PRINT *,' !!!!!! MAPFM2 WARNING : Unable'// - ' to store a dielectricum from file ', - FMAP(1:NCMAP),'; file not read.' RETURN ELSEIF(IEPS.LT.0)THEN NEPS=NEPS+1 IEPS=NEPS EPSMAT(IEPS)=SUM IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM2'', - '' DEBUG : Adding dielectricum with'', - '' eps='',E10.3,''.'')') EPSMAT(IEPS) ENDIF MATMAP(I)=IEPS ** Dielectricum identification via D/E comparison. ELSEIF((MAPFLG(2).AND.MAPFLG(3).AND. - (.NOT.MAPFLG(9)).AND. - ICONT(1).EQ.-9.AND.ICONT(2).EQ.-9).OR. - (MAPFLG(10).AND.(.NOT.MAPFLG(9)).AND. - ICONT(1).EQ.2.AND.ICONT(2).EQ.3))THEN IEPS=-1 DCOMP=DXCOMP**2+DYCOMP**2 ECOMP=(EXMAP(I,1)+EXMAP(I,2)+EXMAP(I,3)+ - EXMAP(I,4)+EXMAP(I,5)+EXMAP(I,6))**2+ - (EYMAP(I,1)+EYMAP(I,2)+EYMAP(I,3)+ - EYMAP(I,4)+EYMAP(I,5)+EYMAP(I,6))**2 DO 170 J=1,NEPS IF(ABS(ECOMP*(100*EPS0*EPSMAT(J))**2-DCOMP).LT.1E-4* - (ABS(ECOMP*(100*EPS0*EPSMAT(J))**2)+ - ABS(DCOMP)))IEPS=J 170 CONTINUE IF(ECOMP.LE.0.AND.DCOMP.GT.0)THEN PRINT *,' !!!!!! MAPFM2 WARNING : Found'// - ' a dielectric constant of 0; skipped.' ELSEIF(IEPS.LT.0.AND.NEPS.GE.MXEPS)THEN PRINT *,' !!!!!! MAPFM2 WARNING : Unable'// - ' to store a dielectricum from file ', - FMAP(1:NCMAP),'; file not read.' RETURN ELSEIF(IEPS.LT.0)THEN NEPS=NEPS+1 IEPS=NEPS IF(ECOMP.LE.0)THEN PRINT *,' ------ MAPFM2 MESSAGE : Unable'// - ' to determine epsilon in an E=0'// - ' tetrahedron; epsilon set to 0.' EPSMAT(IEPS)=0 ELSE EPSMAT(IEPS)=SQRT(DCOMP/ECOMP)/(100*EPS0) ENDIF IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM2'', - '' DEBUG : Adding dielectricum with'', - '' eps='',E10.3,''.'')') EPSMAT(IEPS) ENDIF MATMAP(I)=IEPS NEWEPS=.TRUE. * Otherwise store the field. ELSEIF(ICONT(1).EQ.-9.AND.ICONT(2).EQ.-9.AND. - (.NOT.MAPFLG(2)).AND.(.NOT.MAPFLG(3)))THEN EXMAP(I,1)=DXCOMP EYMAP(I,1)=DYCOMP ENDIF ENDIF * Skip blank line at the end. READ(12,'()',END=2000,ERR=2010,IOSTAT=IOS) 10 CONTINUE *** Assign triangle count. IF(MAPFLG(1))THEN IF(I.NE.NMAP)THEN PRINT *,' !!!!!! MAPFM2 WARNING : Number of'// - ' triangles in ',FMAP(1:NCMAP),' does'// - ' not agree with previous files; not read.' RETURN ENDIF ELSE IF(I.LE.0)THEN PRINT *,' !!!!!! MAPFM2 WARNING : ',FMAP(1:NCMAP), - ' contain no triangles; not read.' RETURN ELSE NMAP=I ENDIF IF(WINDOW.AND.NDELET.NE.0)PRINT *,' ------ MAPFM2'// - ' MESSAGE : Found ',NDELET,' triangles partially'// - ' outside the WINDOW.' ENDIF *** Material has been defined is NEWEPS is set. IF(NEWEPS)MAPFLG(9)=.TRUE. *** Flag those elements which have been defined. MAPFLG(1)=.TRUE. DO 70 I=1,3 IF(ICONT(I).EQ.2.OR.ICONT(I).EQ.3.OR.ICONT(I).EQ.4)THEN IF(IDATA.EQ.0.OR.IDATA.EQ.2)THEN MAPFLG(ICONT(I))=.TRUE. ELSEIF(IDATA.EQ.10)THEN MAPFLG(8+ICONT(I)+3*IWMAP-2)=.TRUE. ENDIF ELSEIF(ICONT(I).GT.0)THEN MAPFLG(ICONT(I))=.TRUE. ELSEIF(ICONT(I).EQ.-9)THEN MAPFLG(10)=.TRUE. ENDIF 70 CONTINUE *** Seems to have worked, set error flag to OK and return. IFAIL=0 MAPTYP=2 RETURN *** Handle error conditions. 2000 CONTINUE PRINT *,' !!!!!! MAPFM2 WARNING : Premature end of file on ', - FMAP(1:NCMAP),'; map not available.' RETURN 2010 CONTINUE PRINT *,' !!!!!! MAPFM2 WARNING : Error reading field map'// - ' file ',FMAP(1:NCMAP),'; map not available.' RETURN END +DECK,MAPFM3. SUBROUTINE MAPFM3(FMAP,NCMAP,IDATA,IWMAP, - WXMIN,WYMIN,WZMIN,WXMAX,WYMAX,WZMAX,WINDOW,IFAIL) *----------------------------------------------------------------------- * MAPFM3 - Reads a Maxwell 3D table of tetrahedrons. * (Last changed on 29/11/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. +SEQ,FIELDMAP. +SEQ,CONSTANTS. INTEGER NDECL,IMAP,IEPS,ICONT(3),IMAX,IWMAP, - I,J,K,NCMAP,IFAIL,IFAIL1,IOS,NC,INPCMP, - NREAD,IDATA REAL TEMP(10),XAUX(4),YAUX(4),ZAUX(4),SUM,ECOMP,DCOMP, - WXMIN,WYMIN,WZMIN,WXMAX,WYMAX,WZMAX,T1,T2,T3,T4 CHARACTER*(*) FMAP CHARACTER*80 STRING LOGICAL SCALAR,READ,WINDOW,NEWEPS EXTERNAL INPCMP *** Identify the routine if requested. IF(LIDENT)PRINT *,' /// ROUTINE MAPFM3 ///' *** Assume that this will fail. IFAIL=1 *** First read the line with number of tetrahedrons. CALL INPCHK(4,1,IFAIL1) CALL INPRDI(4,NDECL,0) IF(IFAIL1.NE.0.OR.NDECL.LE.0)THEN PRINT *,' !!!!!! MAPFM3 WARNING : The file ', - FMAP(1:NCMAP),' has an unreadable number'// - ' of tetrahedrons; not read.' CALL INPSWI('RESTORE') RETURN ENDIF * Debugging output. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM3 DEBUG : Number'', - '' of tetrahedrons: '',I5)') NDECL * Progress printing. CALL PROFLD(2,'Tetrahedrons',REAL(NDECL)) *** See whether the data is scalar or vector. IF(INPCMP(1,'SCALAR').NE.0)THEN SCALAR=.TRUE. ELSEIF(INPCMP(1,'VECTOR').NE.0)THEN SCALAR=.FALSE. ELSE PRINT *,' !!!!!! MAPFM3 WARNING : The file ', - FMAP(1:NCMAP),' contains neither scalar nor'// - ' vectorial data; not read.' CALL INPSWI('RESTORE') RETURN ENDIF *** Next determine the contents of the file, read the next record. CALL INPGET * Set the expected word count. IF(SCALAR)THEN IMAX=1 ELSE IMAX=3 ENDIF * Initial contents flags. ICONT(1)=0 ICONT(2)=0 ICONT(3)=0 READ=.FALSE. NEWEPS=.FALSE. * Loop over the words. DO 40 I=1,IMAX * Ex. IF(INPCMP(I,'smh(E(x))').NE.0)THEN ICONT(I)=2 IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM3 DEBUG :'', - '' Field '',I1,'': x-component E field.'')') I IF(IDATA.EQ.0.OR.IDATA.EQ.2)THEN IF(MAPFLG(2))PRINT *,' ------ MAPFM3 MESSAGE :'// - ' Overwriting current Ex map.' MAPFLG(2)=.FALSE. ELSEIF(IDATA.EQ.10)THEN IF(MAPFLG(10+3*IWMAP-2)) - PRINT *,' ------ MAPFM3 MESSAGE :'// - ' Overwriting current weighting Ex map.' MAPFLG(10+3*IWMAP-2)=.FALSE. ENDIF * Ey. ELSEIF(INPCMP(I,'smh(E(y))').NE.0)THEN ICONT(I)=3 IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM3 DEBUG :'', - '' Field '',I1,'': y-component E field.'')') I IF(IDATA.EQ.0.OR.IDATA.EQ.2)THEN IF(MAPFLG(3))PRINT *,' ------ MAPFM3 MESSAGE :'// - ' Overwriting current Ey map.' MAPFLG(3)=.FALSE. ELSEIF(IDATA.EQ.10)THEN IF(MAPFLG(11+3*IWMAP-2)) - PRINT *,' ------ MAPFM3 MESSAGE :'// - ' Overwriting current weighting Ey map.' MAPFLG(11+3*IWMAP-2)=.FALSE. ENDIF * Ez. ELSEIF(INPCMP(I,'smh(E(z))').NE.0)THEN ICONT(I)=4 IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM3 DEBUG :'', - '' Field '',I1,'': z-component E field.'')') I IF(IDATA.EQ.0.OR.IDATA.EQ.2)THEN IF(MAPFLG(4))PRINT *,' ------ MAPFM3 MESSAGE :'// - ' Overwriting current Ez map.' MAPFLG(4)=.FALSE. ELSEIF(IDATA.EQ.10)THEN IF(MAPFLG(12+3*IWMAP-2)) - PRINT *,' ------ MAPFM3 MESSAGE :'// - ' Overwriting current weighting Ez map.' MAPFLG(12+3*IWMAP-2)=.FALSE. ENDIF * Dx. ELSEIF(INPCMP(I,'smh(D(x))').NE.0)THEN ICONT(I)=-9 IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM3 DEBUG :'', - '' Field '',I1,'': x-component D field.'')') I IF(MAPFLG(9))PRINT *,' ------ MAPFM3 MESSAGE :'// - ' Overwriting current material map.' MAPFLG(9)=.FALSE. MATSRC='EPSILON' * Dy. ELSEIF(INPCMP(I,'smh(D(y))').NE.0)THEN ICONT(I)=-9 IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM3 DEBUG :'', - '' Field '',I1,'': y-component D field.'')') I IF(MAPFLG(9))PRINT *,' ------ MAPFM3 MESSAGE :'// - ' Overwriting current material map.' MAPFLG(9)=.FALSE. MATSRC='EPSILON' * Dz. ELSEIF(INPCMP(I,'smh(D(z))').NE.0)THEN ICONT(I)=-9 IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM3 DEBUG :'', - '' Field '',I1,'': z-component D field.'')') I IF(MAPFLG(9))PRINT *,' ------ MAPFM3 MESSAGE :'// - ' Overwriting current material map.' MAPFLG(9)=.FALSE. MATSRC='EPSILON' * Unsmoothed electric fields. ELSEIF(INPCMP(I,'E(x)')+INPCMP(I,'E(y)')+INPCMP(I,'E(z)')+ - INPCMP(I,'D(x)')+INPCMP(I,'D(y)')+INPCMP(I,'D(z)').NE. - 0)THEN ICONT(I)=0 PRINT *,' !!!!!! MAPFM3 WARNING : Maxwell 3D fields must'// - ' be smoothed; field not read.' * V. ELSEIF(INPCMP(I,'smh(phi)')+INPCMP(I,'phi').NE.0)THEN ICONT(I)=5 IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM3 DEBUG :'', - '' Field '',I1,'': potential.'')') I IF(MAPFLG(5))PRINT *,' ------ MAPFM3 MESSAGE :'// - ' Overwriting current potential map.' MAPFLG(5)=.FALSE. * Bx. ELSEIF(INPCMP(I,'smh(B(x))')+INPCMP(I,'B(x)').NE.0)THEN ICONT(I)=6 IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM3 DEBUG :'', - '' Field '',I1,'': x-component B field.'')') I IF(MAPFLG(6))PRINT *,' ------ MAPFM3 MESSAGE :'// - ' Overwriting current Bx map.' MAPFLG(6)=.FALSE. * By. ELSEIF(INPCMP(I,'smh(B(y))')+INPCMP(I,'B(y)').NE.0)THEN ICONT(I)=7 IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM3 DEBUG :'', - '' Field '',I1,'': y-component B field.'')') I IF(MAPFLG(7))PRINT *,' ------ MAPFM3 MESSAGE :'// - ' Overwriting current By map.' MAPFLG(7)=.FALSE. * Bz. ELSEIF(INPCMP(I,'smh(B(z))')+INPCMP(I,'B(z)').NE.0)THEN ICONT(I)=8 IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM3 DEBUG :'', - '' Field '',I1,'': z-component B field.'')') I IF(MAPFLG(8))PRINT *,' ------ MAPFM3 MESSAGE :'// - ' Overwriting current Bz map.' MAPFLG(8)=.FALSE. * epsilon. ELSEIF(INPCMP(I,'(r( 1.00000e+00) * epsilon)')+ - INPCMP(I,'(r( 1.00000e+000) * epsilon)').NE.0)THEN ICONT(I)=9 IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM3 DEBUG :'', - '' Field '',I1,'': dielectric constant.'')') I IF(MAPFLG(9))PRINT *,' ------ MAPFM3 MESSAGE :'// - ' Overwriting material map.' MAPFLG(9)=.FALSE. MATSRC='EPSILON' * sigma. ELSEIF(INPCMP(I,'(r( 1.00000e+00) * sigma)')+ - INPCMP(I,'(r( 1.00000e+000) * sigma)').NE.0)THEN ICONT(I)=9 IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM3 DEBUG :'', - '' Field '',I1,'': conductivity.'')') I IF(MAPFLG(9))PRINT *,' ------ MAPFM3 MESSAGE :'// - ' Overwriting material map.' MAPFLG(9)=.FALSE. MATSRC='SIGMA' * dummy field. ELSEIF(INPCMP(I,'smh(0)')+INPCMP(I,'0')+ - INPCMP(I,'r( 0.00000e+00)')+ - INPCMP(I,'(r( 1.00000e+00) * )')+ - INPCMP(I,'(r( 0.00000e+000) * epsilon)')+ - INPCMP(I,'(r( 0.00000e+00) * epsilon)')+ - INPCMP(I,'(r( 0.00000e+000) * sigma)')+ - INPCMP(I,'(r( 0.00000e+00) * sigma)').NE.0)THEN ICONT(I)=0 IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM3 DEBUG :'', - '' Field '',I1,'': dummy.'')') I * unrecognised items. ELSE CALL INPSTR(I,I,STRING,NC) PRINT *,' !!!!!! MAPFM3 WARNING : The file ', - FMAP(1:NCMAP),' contains a "'//STRING(1:NC)// - '" field which is not known; field ignored.' ICONT(I)=0 IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM3 DEBUG :'', - '' Field '',I1,'': not recognised.'')') I ENDIF * Check whether reading is required. IF(ICONT(I).NE.0)READ=.TRUE. * Ensure that the data type matches the declared type. IF(((ICONT(I).EQ.2.OR.ICONT(I).EQ.3.OR.ICONT(I).EQ.4).AND. - (IDATA.NE.0.AND.IDATA.NE.2.AND.IDATA.NE.10)).OR. - (ICONT(I).EQ.5.AND.(IDATA.NE.0.AND.IDATA.NE.5)).OR. - ((ICONT(I).EQ.6.OR.ICONT(I).EQ.7.OR.ICONT(I).EQ.8).AND. - (IDATA.NE.0.AND.IDATA.NE.6)).OR. - ((ICONT(I).EQ.9.OR.ICONT(I).EQ.-9).AND. - (IDATA.NE.0.AND.IDATA.NE.9)))THEN PRINT *,' !!!!!! MAPFM3 WARNING : Field ',I,' of file ', - FMAP(1:NCMAP),' does not contain the declared', - ' kind of data; skipped.' ICONT(I)=0 ENDIF 40 CONTINUE *** Switch back to regular input. CALL INPSWI('RESTORE') * See whether any item is left. IF(.NOT.READ)THEN PRINT *,' !!!!!! MAPFM3 WARNING : The file ', - FMAP(1:NCMAP),' contains no useable'// - ' information; file not read.' RETURN ENDIF *** Loop over the tetrahedrons. NREAD=0 DO 10 I=1,NDECL IF(I.EQ.MAX(1,NDECL/100)*(I/MAX(1,NDECL/100))) - CALL PROSTA(2,REAL(I)) *** Read the line with the word "Vertices" or with "x". 50 CONTINUE READ(12,'(A80)',END=2000,ERR=2010,IOSTAT=IOS) STRING IF(STRING(1:8).NE.'Vertices')GOTO 50 * Ensure there is still space in memory. IF(.NOT.MAPFLG(1))THEN IF(NREAD+1.GT.MXMAP)THEN PRINT *,' !!!!!! MAPFM3 WARNING : Number of'// - ' tetrahedrons in ',FMAP(1:NCMAP), - ' exceeds compilation limit; file not read.' RETURN ENDIF ENDIF *** Read vertex coordinates. DO 20 J=1,4 * If the grid is already defined, merely store for check. IF(MAPFLG(1))THEN READ(12,'(E27.20,1X,E27.20,1X,E27.7)',END=2000,ERR=2010, - IOSTAT=IOS) XAUX(J),YAUX(J),ZAUX(J) XAUX(J)=XAUX(J)*100 YAUX(J)=YAUX(J)*100 ZAUX(J)=ZAUX(J)*100 * Otherwise store the grid, converting units from m to cm. ELSE READ(12,'(E27.20,1X,E27.20,1X,E27.7)',END=2000,ERR=2010, - IOSTAT=IOS) XMAP(I,J),YMAP(I,J),ZMAP(I,J) XMAP(I,J)=XMAP(I,J)*100 YMAP(I,J)=YMAP(I,J)*100 ZMAP(I,J)=ZMAP(I,J)*100 IF(I.EQ.1.AND.J.EQ.1)THEN XMMIN=XMAP(I,J) XMMAX=XMAP(I,J) YMMIN=YMAP(I,J) YMMAX=YMAP(I,J) ZMMIN=ZMAP(I,J) ZMMAX=ZMAP(I,J) ELSE XMMIN=MIN(XMMIN,XMAP(I,J)) XMMAX=MAX(XMMAX,XMAP(I,J)) YMMIN=MIN(YMMIN,YMAP(I,J)) YMMAX=MAX(YMMAX,YMAP(I,J)) ZMMIN=MIN(ZMMIN,ZMAP(I,J)) ZMMAX=MAX(ZMMAX,ZMAP(I,J)) ENDIF * Update angular range. IF(YMAP(I,J).NE.0.OR.ZMAP(I,J).NE.0)THEN IF(SETAX)THEN XAMIN=MIN(XAMIN,ATAN2(ZMAP(I,J),YMAP(I,J))) XAMAX=MAX(XAMAX,ATAN2(ZMAP(I,J),YMAP(I,J))) ELSE XAMIN=ATAN2(ZMAP(I,J),YMAP(I,J)) XAMAX=ATAN2(ZMAP(I,J),YMAP(I,J)) SETAX=.TRUE. ENDIF ENDIF IF(ZMAP(I,J).NE.0.OR.XMAP(I,J).NE.0)THEN IF(SETAY)THEN YAMIN=MIN(YAMIN,ATAN2(XMAP(I,J),ZMAP(I,J))) YAMAX=MAX(YAMAX,ATAN2(XMAP(I,J),ZMAP(I,J))) ELSE YAMIN=ATAN2(XMAP(I,J),ZMAP(I,J)) YAMAX=ATAN2(XMAP(I,J),ZMAP(I,J)) SETAY=.TRUE. ENDIF ENDIF IF(XMAP(I,J).NE.0.OR.YMAP(I,J).NE.0)THEN IF(SETAZ)THEN ZAMIN=MIN(ZAMIN,ATAN2(YMAP(I,J),XMAP(I,J))) ZAMAX=MAX(ZAMAX,ATAN2(YMAP(I,J),XMAP(I,J))) ELSE ZAMIN=ATAN2(YMAP(I,J),XMAP(I,J)) ZAMAX=ATAN2(YMAP(I,J),XMAP(I,J)) SETAZ=.TRUE. ENDIF ENDIF ENDIF 20 CONTINUE * Now check that the tetrahedrons fit. IF(MAPFLG(1))THEN CALL MAPIND((XAUX(1)+XAUX(2)+XAUX(3)+XAUX(4))/4, - (YAUX(1)+YAUX(2)+YAUX(3)+YAUX(4))/4, - (ZAUX(1)+ZAUX(2)+ZAUX(3)+ZAUX(4))/4,T1,T2,T3,T4,IMAP) IF(IMAP.NE.I)THEN PRINT *,' !!!!!! MAPFM3 WARNING : The grid in ', - FMAP(1:NCMAP),' does not match the current'// - ' grid; file not read.' WRITE(LUNOUT,'('' Read tetrahedron '',I6, - 4(/'' (x,y,z) = '',3F15.6)/ - '' Found tetrahedron '',I6, - 4(/'' (x,y,z) = '',3F15.6))') - I,(XAUX(J),YAUX(J),ZAUX(J),J=1,4), - IMAP,(XMAP(IMAP,J),YMAP(IMAP,J),ZMAP(IMAP,J),J=1,4) C RETURN ENDIF ENDIF *** Read scalar field values over the tetrahedron. IF(SCALAR)THEN ** Read field values over the tetrahedron. READ(12,'(10(E27.20,1X))',END=2000,ERR=2010, - IOSTAT=IOS) (TEMP(J),J=1,10) * Can be either a potential. IF(ICONT(1).EQ.5)THEN VMAP(I,1)=TEMP(1) VMAP(I,2)=TEMP(5) VMAP(I,3)=TEMP(8) VMAP(I,4)=TEMP(10) VMAP(I,5)=TEMP(2) VMAP(I,6)=TEMP(3) VMAP(I,7)=TEMP(4) VMAP(I,8)=TEMP(6) VMAP(I,9)=TEMP(7) VMAP(I,10)=TEMP(9) * Or a dielectricum. ELSEIF(ICONT(1).EQ.9)THEN SUM=0 DO 60 J=1,10 SUM=SUM+TEMP(J) 60 CONTINUE SUM=SUM/(1000*EPS0) ENDIF ** If dielectricum, identify the material. IF(ICONT(1).EQ.9)THEN IEPS=-1 DO 100 J=1,NEPS IF(ABS(SUM-EPSMAT(J)).LT.1E-4*(ABS(SUM)+ - ABS(EPSMAT(J))))IEPS=J 100 CONTINUE IF(IEPS.LT.0.AND.NEPS.GE.MXEPS)THEN PRINT *,' !!!!!! MAPFM3 WARNING : Unable'// - ' to store a dielectricum from file ', - FMAP(1:NCMAP),'; file not read.' RETURN ELSEIF(IEPS.LT.0)THEN NEPS=NEPS+1 IEPS=NEPS EPSMAT(IEPS)=SUM IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM3'', - '' DEBUG : Adding dielectricum with'', - '' eps='',E10.3,''.'')') EPSMAT(IEPS) ENDIF MATMAP(I)=IEPS ** If a potential, keep track of potential range. ELSEIF(ICONT(1).EQ.5)THEN IF(I.EQ.1)THEN VMMIN=VMAP(I,1) VMMAX=VMAP(I,1) ENDIF VMMIN=MIN(VMMIN,VMAP(I,1),VMAP(I,2),VMAP(I,3), - VMAP(I,4),VMAP(I,5),VMAP(I,6),VMAP(I,7), - VMAP(I,8),VMAP(I,9),VMAP(I,10)) VMMAX=MAX(VMMAX,VMAP(I,1),VMAP(I,2),VMAP(I,3), - VMAP(I,4),VMAP(I,5),VMAP(I,6),VMAP(I,7), - VMAP(I,8),VMAP(I,9),VMAP(I,10)) ENDIF *** Read vectorial field values over the tetrahedron. ELSE * Take care of knowing |D| either from Ex or by summing. IF(ICONT(1).EQ.-9.AND.ICONT(2).EQ.-9.AND. - ICONT(3).EQ.-9)THEN DCOMP=0 ELSEIF(MAPFLG(10))THEN DCOMP=EXMAP(I,1) ENDIF * Loop over the vectors. DO 30 J=1,3 READ(12,'(10(E27.20,1X))',END=2000,ERR=2010, - IOSTAT=IOS) (TEMP(K),K=1,10) * Averaging of epsilons. IF(ICONT(J).EQ.9)THEN SUM=0 DO 80 K=1,10 SUM=SUM+TEMP(K) 80 CONTINUE SUM=SUM/(1000*EPS0) ELSEIF(ICONT(J).EQ.-9)THEN DCOMP=DCOMP+(TEMP(1)+TEMP(5)+TEMP(8)+TEMP(10))**2/ - 160000 ENDIF * Ex or EWx IF(ICONT(J).EQ.2)THEN IF(IDATA.EQ.0.OR.IDATA.EQ.2)THEN EXMAP(I,1)=TEMP(1)/100 EXMAP(I,2)=TEMP(5)/100 EXMAP(I,3)=TEMP(8)/100 EXMAP(I,4)=TEMP(10)/100 EXMAP(I,5)=TEMP(2)/100 EXMAP(I,6)=TEMP(3)/100 EXMAP(I,7)=TEMP(4)/100 EXMAP(I,8)=TEMP(6)/100 EXMAP(I,9)=TEMP(7)/100 EXMAP(I,10)=TEMP(9)/100 ELSEIF(IDATA.EQ.10)THEN EWXMAP(I,1,IWMAP)=TEMP(1)/100 EWXMAP(I,2,IWMAP)=TEMP(5)/100 EWXMAP(I,3,IWMAP)=TEMP(8)/100 EWXMAP(I,4,IWMAP)=TEMP(10)/100 EWXMAP(I,5,IWMAP)=TEMP(2)/100 EWXMAP(I,6,IWMAP)=TEMP(3)/100 EWXMAP(I,7,IWMAP)=TEMP(4)/100 EWXMAP(I,8,IWMAP)=TEMP(6)/100 EWXMAP(I,9,IWMAP)=TEMP(7)/100 EWXMAP(I,10,IWMAP)=TEMP(9)/100 ENDIF * Bx. ELSEIF(ICONT(J).EQ.6)THEN BXMAP(I,1)=TEMP(1) BXMAP(I,2)=TEMP(5) BXMAP(I,3)=TEMP(8) BXMAP(I,4)=TEMP(10) BXMAP(I,5)=TEMP(2) BXMAP(I,6)=TEMP(3) BXMAP(I,7)=TEMP(4) BXMAP(I,8)=TEMP(6) BXMAP(I,9)=TEMP(7) BXMAP(I,10)=TEMP(9) * Ey or EWy. ELSEIF(ICONT(J).EQ.3)THEN IF(IDATA.EQ.0.OR.IDATA.EQ.2)THEN EYMAP(I,1)=TEMP(1)/100 EYMAP(I,2)=TEMP(5)/100 EYMAP(I,3)=TEMP(8)/100 EYMAP(I,4)=TEMP(10)/100 EYMAP(I,5)=TEMP(2)/100 EYMAP(I,6)=TEMP(3)/100 EYMAP(I,7)=TEMP(4)/100 EYMAP(I,8)=TEMP(6)/100 EYMAP(I,9)=TEMP(7)/100 EYMAP(I,10)=TEMP(9)/100 ELSEIF(IDATA.EQ.10)THEN EWYMAP(I,1,IWMAP)=TEMP(1)/100 EWYMAP(I,2,IWMAP)=TEMP(5)/100 EWYMAP(I,3,IWMAP)=TEMP(8)/100 EWYMAP(I,4,IWMAP)=TEMP(10)/100 EWYMAP(I,5,IWMAP)=TEMP(2)/100 EWYMAP(I,6,IWMAP)=TEMP(3)/100 EWYMAP(I,7,IWMAP)=TEMP(4)/100 EWYMAP(I,8,IWMAP)=TEMP(6)/100 EWYMAP(I,9,IWMAP)=TEMP(7)/100 EWYMAP(I,10,IWMAP)=TEMP(9)/100 ENDIF * By. ELSEIF(ICONT(J).EQ.7)THEN BYMAP(I,1)=TEMP(1) BYMAP(I,2)=TEMP(5) BYMAP(I,3)=TEMP(8) BYMAP(I,4)=TEMP(10) BYMAP(I,5)=TEMP(2) BYMAP(I,6)=TEMP(3) BYMAP(I,7)=TEMP(4) BYMAP(I,8)=TEMP(6) BYMAP(I,9)=TEMP(7) BYMAP(I,10)=TEMP(9) * Ez or EWz. ELSEIF(ICONT(J).EQ.4)THEN IF(IDATA.EQ.0.OR.IDATA.EQ.2)THEN EZMAP(I,1)=TEMP(1)/100 EZMAP(I,2)=TEMP(5)/100 EZMAP(I,3)=TEMP(8)/100 EZMAP(I,4)=TEMP(10)/100 EZMAP(I,5)=TEMP(2)/100 EZMAP(I,6)=TEMP(3)/100 EZMAP(I,7)=TEMP(4)/100 EZMAP(I,8)=TEMP(6)/100 EZMAP(I,9)=TEMP(7)/100 EZMAP(I,10)=TEMP(9)/100 ELSEIF(IDATA.EQ.10)THEN EWZMAP(I,1,IWMAP)=TEMP(1)/100 EWZMAP(I,2,IWMAP)=TEMP(5)/100 EWZMAP(I,3,IWMAP)=TEMP(8)/100 EWZMAP(I,4,IWMAP)=TEMP(10)/100 EWZMAP(I,5,IWMAP)=TEMP(2)/100 EWZMAP(I,6,IWMAP)=TEMP(3)/100 EWZMAP(I,7,IWMAP)=TEMP(4)/100 EWZMAP(I,8,IWMAP)=TEMP(6)/100 EWZMAP(I,9,IWMAP)=TEMP(7)/100 EWZMAP(I,10,IWMAP)=TEMP(9)/100 ENDIF * Bz. ELSEIF(ICONT(J).EQ.8)THEN BZMAP(I,1)=TEMP(1) BZMAP(I,2)=TEMP(5) BZMAP(I,3)=TEMP(8) BZMAP(I,4)=TEMP(10) BZMAP(I,5)=TEMP(2) BZMAP(I,6)=TEMP(3) BZMAP(I,7)=TEMP(4) BZMAP(I,8)=TEMP(6) BZMAP(I,9)=TEMP(7) BZMAP(I,10)=TEMP(9) ENDIF 30 CONTINUE ** If dielectricum, identify the material. IF(ICONT(1).EQ.9.OR.ICONT(2).EQ.9.OR.ICONT(3).EQ.9)THEN IEPS=-1 DO 160 J=1,NEPS IF(ABS(SUM-EPSMAT(J)).LT.1E-4*(ABS(SUM)+ - ABS(EPSMAT(J))))IEPS=J 160 CONTINUE IF(IEPS.LT.0.AND.NEPS.GE.MXEPS)THEN PRINT *,' !!!!!! MAPFM3 WARNING : Unable'// - ' to store a dielectricum from file ', - FMAP(1:NCMAP),'; file not read.' RETURN ELSEIF(IEPS.LT.0)THEN NEPS=NEPS+1 IEPS=NEPS EPSMAT(IEPS)=SUM IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM3'', - '' DEBUG : Adding dielectricum with'', - '' eps='',E10.3,''.'')') EPSMAT(IEPS) ENDIF MATMAP(I)=IEPS NEWEPS=.TRUE. ** Dielectricum identification via D/E comparison. ELSEIF((MAPFLG(2).AND.MAPFLG(3).AND.MAPFLG(4).AND. - (.NOT.MAPFLG(9)).AND.ICONT(1).EQ.-9.AND. - ICONT(2).EQ.-9.AND.ICONT(3).EQ.-9).OR. - (MAPFLG(10).AND.(.NOT.MAPFLG(9)).AND. - ICONT(1).EQ.2.AND.ICONT(2).EQ.3.AND. - ICONT(3).EQ.4))THEN IEPS=-1 ECOMP=((EXMAP(I,1)+EXMAP(I,2)+EXMAP(I,3)+ - EXMAP(I,4))**2+(EYMAP(I,1)+EYMAP(I,2)+ - EYMAP(I,3)+EYMAP(I,4))**2+(EZMAP(I,1)+ - EZMAP(I,2)+EZMAP(I,3)+EZMAP(I,4))**2)/16 DO 170 J=1,NEPS IF(ABS(ECOMP*(100*EPS0*EPSMAT(J))**2-DCOMP).LT.1E-4* - (ABS(ECOMP*(100*EPS0*EPSMAT(J))**2)+ - ABS(DCOMP)))IEPS=J 170 CONTINUE IF(ECOMP.LE.0.AND.DCOMP.GT.0)THEN PRINT *,' !!!!!! MAPFM3 WARNING : Found'// - ' a dielectric constant of 0; skipped.' ELSEIF(IEPS.LT.0.AND.NEPS.GE.MXEPS)THEN PRINT *,' !!!!!! MAPFM3 WARNING : Unable'// - ' to store a dielectricum from file ', - FMAP(1:NCMAP),'; file not read.' RETURN ELSEIF(IEPS.LT.0)THEN NEPS=NEPS+1 IEPS=NEPS IF(ECOMP.LE.0)THEN PRINT *,' ------ MAPFM3 MESSAGE : Unable'// - ' to determine epsilon in an E=0'// - ' tetrahedron; epsilon set to 0.' EPSMAT(IEPS)=0 ELSE EPSMAT(IEPS)=SQRT(DCOMP/ECOMP)/(100*EPS0) ENDIF IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM3'', - '' DEBUG : Adding dielectricum with'', - '' eps='',E10.3,''.'')') EPSMAT(IEPS) ENDIF MATMAP(I)=IEPS NEWEPS=.TRUE. * Otherwise store the field. ELSEIF(ICONT(1).EQ.-9.AND.ICONT(2).EQ.-9.AND. - ICONT(3).EQ.-9.AND.(.NOT.MAPFLG(2)))THEN EXMAP(I,1)=DCOMP ENDIF ENDIF * Update the count. NREAD=NREAD+1 * Skip the line with "h" at the end. READ(12,'()',END=2000,ERR=2010,IOSTAT=IOS) 10 CONTINUE *** Be sure something has been read. 2000 CONTINUE IF(MAPFLG(1))THEN IF(NREAD.NE.NMAP)THEN PRINT *,' !!!!!! MAPFM3 WARNING : Number of'// - ' tetrahedrons in ',FMAP(1:NCMAP),' does'// - ' not agree with previous files; not read.' RETURN ENDIF ELSE IF(NREAD.LE.0)THEN PRINT *,' !!!!!! MAPFM3 WARNING : ',FMAP(1:NCMAP), - ' contain no tetrahedrons; not read.' RETURN ELSE NMAP=NREAD ENDIF ENDIF *** Materials have been defined is NEWEPS is set. IF(NEWEPS)MAPFLG(9)=.TRUE. *** Flag those elements which have been defined. MAPFLG(1)=.TRUE. DO 70 I=1,3 IF(ICONT(I).EQ.2.OR.ICONT(I).EQ.3.OR.ICONT(I).EQ.4)THEN IF(IDATA.EQ.0.OR.IDATA.EQ.2)THEN MAPFLG(ICONT(I))=.TRUE. ELSEIF(IDATA.EQ.10)THEN MAPFLG(8+ICONT(I)+3*IWMAP-2)=.TRUE. ENDIF ELSEIF(ICONT(I).GT.0)THEN MAPFLG(ICONT(I))=.TRUE. ELSEIF(ICONT(I).EQ.-9)THEN MAPFLG(10)=.TRUE. ENDIF 70 CONTINUE *** Seems to have worked, set error flag to OK and return. IFAIL=0 MAPTYP=12 RETURN *** Handle error conditions. 2010 CONTINUE PRINT *,' !!!!!! MAPFM3 WARNING : Error reading field map'// - ' file ',FMAP(1:NCMAP),'; map not available.' RETURN END +DECK,MAPFM5. SUBROUTINE MAPFM5(FMAP,NCMAP,IDATA,IWMAP, - WXMIN,WYMIN,WZMIN,WXMAX,WYMAX,WZMAX,WINDOW,DELBKG,IFAIL) *----------------------------------------------------------------------- * MAPFM5 - Reads a Maxwell 3D Field Simulator version 4.0 table of * tetrahedrons. * (Last changed on 29/11/99.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. +SEQ,FIELDMAP. +SEQ,CONSTANTS. INTEGER IEPS,ICONT(3),IMAX,NUSE,IWMAP, - I,J,K,NCMAP,IFAIL,IFAIL1,IFAIL2,IFAIL3,IFAIL4,IFAIL5, - IT1,IT2,IT3,IT4,ITETRA,IOS,NC,INPCMP, - IDATA,NWORD,NCAUX,IEND,IP,NTETRA,NTOTAL,NPOINT, - MTETRA,MPOINT,LOOKUP(10),NDELET REAL TEMP(10),SUM,ECOMP,DCOMP,DX,DY,DZ, - WXMIN,WYMIN,WZMIN,WXMAX,WYMAX,WZMAX,XP,YP,ZP CHARACTER*(*) FMAP CHARACTER*(MXNAME) FAUX CHARACTER*80 STRING LOGICAL SCALAR,READ,NEWEPS,WINDOW,EXIST,EXIST2,DELBKG, - DELFLG(MXMAP),FIRST EXTERNAL INPCMP +SELF,IF=SAVE. SAVE NTETRA,NPOINT,LOOKUP +SELF. DATA NTETRA/0/, NPOINT/0/ DATA LOOKUP/1, 5, 6, 7, 2, 8, 9, 3, 10, 4/ **** Identify the routine if requested. IF(LIDENT)PRINT *,' /// ROUTINE MAPFM5 ///' *** Assume that this will fail. IFAIL=1 *** Make sure the file names are not too long. IF(NCMAP.GT.MXNAME)THEN PRINT *,' !!!!!! MAPFM5 WARNING : Field map file name ', - FMAP(1:NCMAP),' is too long; not read.' CALL INPSWI('RESTORE') RETURN ENDIF *** Check for mesh files - or guess mesh name if there is no mesh yet. IF(IDATA.EQ.1)THEN * Get rid of extensions, if any. IEND=0 DO 1050 I=NCMAP,1,-1 IF(FMAP(I:I).NE.' '.AND.IEND.EQ.0)IEND=I IF(FMAP(I:I).EQ.'/')THEN IF(IEND.GT.0)THEN FAUX=FMAP(1:IEND)//'.' NCAUX=IEND+1 ELSE FAUX=FMAP NCAUX=NCMAP ENDIF GOTO 1060 ELSEIF(FMAP(I:I).EQ.'.')THEN FAUX=FMAP(1:I) NCAUX=I GOTO 1060 ENDIF 1050 CONTINUE IF(IEND.EQ.0)THEN PRINT *,' !!!!!! MAPFM5 WARNING : Mesh file name'// - ' empty ; not read.' CALL INPSWI('RESTORE') RETURN ENDIF FAUX=FMAP(1:IEND)//'.' NCAUX=IEND+1 1060 CONTINUE * Verify that the resulting file name is not too long. IF(NCAUX+3.GT.MXNAME)THEN PRINT *,' !!!!!! MAPFM5 WARNING : Mesh file name'// - ' too long after expansion ; not read.' CALL INPSWI('RESTORE') RETURN ENDIF * Check for the existence of the files. CALL DSNINQ(FAUX(1:NCAUX)//'hyd',NCAUX+3,EXIST) IF(.NOT.EXIST)THEN PRINT *,' !!!!!! MAPFM5 WARNING : Hydra file '// - FAUX(1:NCAUX)//'hyd not found; map not read.' CALL INPSWI('RESTORE') RETURN ENDIF CALL DSNINQ(FAUX(1:NCAUX)//'pnt',NCAUX+3,EXIST) IF(.NOT.EXIST)THEN PRINT *,' !!!!!! MAPFM5 WARNING : Point file '// - FAUX(1:NCAUX)//'pnt not found; map not read.' CALL INPSWI('RESTORE') RETURN ENDIF IF(DELBKG)THEN CALL DSNINQ(FAUX(1:NCAUX)//'shd',NCAUX+3,EXIST) IF(.NOT.EXIST)THEN PRINT *,' !!!!!! MAPFM5 WARNING : Solid file '// - FAUX(1:NCAUX)//'shd not found; map not read.' CALL INPSWI('RESTORE') RETURN ENDIF ENDIF ** If we didn't get a mesh file, try to guess the name. ELSEIF(.NOT.MAPFLG(1))THEN * Locate the directory name. IEND=0 DO 1070 I=NCMAP,1,-1 IF(FMAP(I:I).NE.' '.AND.IEND.EQ.0)IEND=I IF(FMAP(I:I).EQ.'/')THEN FAUX=FMAP(1:I) NCAUX=I GOTO 1080 ENDIF 1070 CONTINUE IF(IEND.EQ.0)THEN PRINT *,' !!!!!! MAPFM5 WARNING : Field file name'// - ' empty ; not read.' CALL INPSWI('RESTORE') RETURN ENDIF FAUX='./' NCAUX=2 1080 CONTINUE * Test for various files. CALL DSNINQ(FAUX(1:NCAUX)//'fileset2.hyd',NCAUX+12,EXIST) IF(EXIST)THEN CALL DSNINQ(FAUX(1:NCAUX)//'fileset2.pnt',NCAUX+12, - EXIST) IF(DELBKG)THEN CALL DSNINQ(FAUX(1:NCAUX)//'fileset2.shd', - NCAUX+12,EXIST2) ELSE EXIST2=.TRUE. ENDIF IF(EXIST.AND.EXIST2)THEN FAUX=FAUX(:NCAUX)//'fileset2.' NCAUX=NCAUX+9 PRINT *,' ------ MAPFM5 MESSAGE : Taking the'// - ' "fileset2" mesh.' GOTO 1090 ENDIF ENDIF CALL DSNINQ(FAUX(1:NCAUX)//'fileset1.hyd',NCAUX+12,EXIST) IF(EXIST)THEN CALL DSNINQ(FAUX(1:NCAUX)//'fileset1.pnt',NCAUX+12, - EXIST) IF(DELBKG)THEN CALL DSNINQ(FAUX(1:NCAUX)//'fileset1.shd', - NCAUX+12,EXIST2) ELSE EXIST2=.TRUE. ENDIF IF(EXIST.AND.EXIST2)THEN FAUX=FAUX(:NCAUX)//'fileset1.' NCAUX=NCAUX+9 PRINT *,' ------ MAPFM5 MESSAGE : Taking the'// - ' "fileset1" mesh.' GOTO 1090 ENDIF ENDIF CALL DSNINQ(FAUX(1:NCAUX)//'current.hyd',NCAUX+11,EXIST) IF(EXIST)THEN CALL DSNINQ(FAUX(1:NCAUX)//'current.pnt',NCAUX+11, - EXIST) IF(DELBKG)THEN CALL DSNINQ(FAUX(1:NCAUX)//'current.shd', - NCAUX+11,EXIST2) ELSE EXIST2=.TRUE. ENDIF IF(EXIST.AND.EXIST2)THEN FAUX=FAUX(:NCAUX)//'current.' NCAUX=NCAUX+8 PRINT *,' ------ MAPFM5 MESSAGE : Taking the'// - ' "current" mesh.' GOTO 1090 ENDIF ENDIF CALL DSNINQ(FAUX(1:NCAUX)//'efs3d.hyd',NCAUX+9,EXIST) IF(EXIST)THEN CALL DSNINQ(FAUX(1:NCAUX)//'efs3d.pnt',NCAUX+9, - EXIST) IF(DELBKG)THEN CALL DSNINQ(FAUX(1:NCAUX)//'efs3d.shd', - NCAUX+9,EXIST2) ELSE EXIST2=.TRUE. ENDIF IF(EXIST.AND.EXIST2)THEN FAUX=FAUX(:NCAUX)//'efs3d.' NCAUX=NCAUX+6 PRINT *,' ------ MAPFM5 MESSAGE : Taking the'// - ' "efs3d" mesh.' GOTO 1090 ENDIF ENDIF CALL DSNINQ(FAUX(1:NCAUX)//'previous.hyd',NCAUX+12,EXIST) IF(EXIST)THEN CALL DSNINQ(FAUX(1:NCAUX)//'previous.pnt',NCAUX+12, - EXIST) IF(DELBKG)THEN CALL DSNINQ(FAUX(1:NCAUX)//'previous.shd', - NCAUX+12,EXIST2) ELSE EXIST2=.TRUE. ENDIF IF(EXIST.AND.EXIST2)THEN FAUX=FAUX(:NCAUX)//'previous.' NCAUX=NCAUX+9 PRINT *,' ------ MAPFM5 MESSAGE : Taking the'// - ' "previous" mesh.' GOTO 1090 ENDIF ENDIF CALL DSNINQ(FAUX(1:NCAUX)//'initial.hyd',NCAUX+11,EXIST) IF(EXIST)THEN CALL DSNINQ(FAUX(1:NCAUX)//'initial.pnt',NCAUX+11, - EXIST) IF(DELBKG)THEN CALL DSNINQ(FAUX(1:NCAUX)//'initial.shd', - NCAUX+11,EXIST2) ELSE EXIST2=.TRUE. ENDIF IF(EXIST.AND.EXIST2)THEN FAUX=FAUX(:NCAUX)//'initial.' NCAUX=NCAUX+8 PRINT *,' ------ MAPFM5 MESSAGE : Taking the'// - ' "initial" mesh.' GOTO 1090 ENDIF ENDIF PRINT *,' !!!!!! MAPFM5 WARNING : Hydra, point and'// - ' solid files not found; specify mesh explicitely.' CALL INPSWI('RESTORE') RETURN * Verify that the resulting file name is not too long. 1090 CONTINUE IF(NCAUX+3.GT.MXNAME)THEN PRINT *,' !!!!!! MAPFM5 WARNING : Mesh file name'// - ' too long after expansion ; not read.' CALL INPSWI('RESTORE') RETURN ENDIF ENDIF *** Skip the mesh decoding if this has already been done. IF(IDATA.NE.1.AND.MAPFLG(1))GOTO 1000 * Close the current file, re-open later. CALL INPSWI('RESTORE') CLOSE(12,ERR=2030,IOSTAT=IOS) *** If background suppression has been requested, read .shd file. DO 1150 I=1,MXMAP DELFLG(I)=.FALSE. 1150 CONTINUE IF(DELBKG)THEN * Construct the hydra file name. FAUX=FAUX(1:NCAUX)//'shd' NCAUX=NCAUX+3 * Open the hydra file. CALL DSNOPN(FAUX,NCAUX,12,'READ-FILE',IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! MAPFM5 WARNING : Unable to open the'// - ' solid file '//FAUX(1:NCAUX)//'; map not read.' RETURN ENDIF * Record the opening. CALL DSNLOG(FAUX(1:NCAUX),'Solids ','Sequential', - 'Read only ') * Switch to reading the file. CALL INPSWI('UNIT12') ** Read the header records, switch to the data file. CALL INPGET CALL INPNUM(NWORD) * Check for empty files. IF(NWORD.EQ.0)THEN PRINT *,' !!!!!! MAPFM5 WARNING : The file '// - FAUX(1:NCAUX)//' seems to be empty; map not read.' CALL INPSWI('RESTORE') CLOSE(12,STATUS='KEEP',ERR=2030,IOSTAT=IOS) RETURN ENDIF * Read the number of tetrahedrons. CALL INPNUM(NWORD) CALL INPCHK(2,1,IFAIL1) CALL INPRDI(2,NTOTAL,0) IF(IFAIL1.NE.0.OR.NTOTAL.LE.0.OR.NWORD.NE.2)THEN PRINT *,' !!!!!! MAPFM5 WARNING : The file '// - FAUX(1:NCAUX)//' has an unreadable number'// - ' of tetrahedrons; not read.' CALL INPSWI('RESTORE') RETURN ELSEIF(NTOTAL.GT.MXMAP)THEN PRINT *,' !!!!!! MAPFM5 WARNING : Number of'// - ' tetrahedrons in '//FAUX(1:NCAUX)// - ' exceeds compilation limit; file not read.' CALL INPSWI('RESTORE') RETURN ENDIF * Debugging output. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM5 DEBUG :'', - '' Number of .shd tetrahedrons (incl bkg): '',I5)') - NTOTAL ** Loop over the tetrahedrons, with progress printing. CALL PROFLD(2,'Volumes',REAL(NTOTAL)) NDELET=0 DO 1160 I=1,NTOTAL IF(I.EQ.MAX(1,NTOTAL/100)*(I/MAX(1,NTOTAL/100))) - CALL PROSTA(2,REAL(I)) * Read the data line. CALL INPGET CALL INPNUM(NWORD) IF(NWORD.EQ.3)THEN DELFLG(I)=.TRUE. NDELET=NDELET+1 ENDIF 1160 CONTINUE * Switch back to regular input. CALL INPSWI('RESTORE') * Close the solids file. CLOSE(12,ERR=2030,IOSTAT=IOS) * Reestablish the root name length. NCAUX=NCAUX-3 ENDIF * Construct the hydra file name. FAUX=FAUX(1:NCAUX)//'hyd' NCAUX=NCAUX+3 * Open the hydra file. CALL DSNOPN(FAUX,NCAUX,12,'READ-FILE',IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! MAPFM5 WARNING : Unable to open the'// - ' hydra file '//FAUX(1:NCAUX)//'; map not read.' RETURN ENDIF * Record the opening. CALL DSNLOG(FAUX(1:NCAUX),'Hydra ','Sequential', - 'Read only ') * Switch to reading the file. CALL INPSWI('UNIT12') ** Read the header records, switch to the data file. CALL INPGET CALL INPNUM(NWORD) * Check for empty files. IF(NWORD.EQ.0)THEN PRINT *,' !!!!!! MAPFM5 WARNING : The file '// - FAUX(1:NCAUX)//' seems to be empty; map not read.' CALL INPSWI('RESTORE') CLOSE(12,STATUS='KEEP',ERR=2030,IOSTAT=IOS) RETURN ENDIF * Read the number of tetrahedrons. CALL INPNUM(NWORD) CALL INPCHK(2,1,IFAIL1) CALL INPRDI(2,NTOTAL,0) IF(IFAIL1.NE.0.OR.NTOTAL.LE.0.OR.NWORD.NE.2)THEN PRINT *,' !!!!!! MAPFM5 WARNING : The file '// - FAUX(1:NCAUX)//' has an unreadable number'// - ' of tetrahedrons; not read.' CALL INPSWI('RESTORE') RETURN ELSEIF(NTOTAL.GT.MXMAP)THEN PRINT *,' !!!!!! MAPFM5 WARNING : Number of'// - ' tetrahedrons in '//FAUX(1:NCAUX)// - ' exceeds compilation limit; file not read.' CALL INPSWI('RESTORE') RETURN ENDIF * Debugging output. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM5 DEBUG : Number'', - '' of .hyd tetrahedrons (incl bkg): '',I5)') NTOTAL ** Loop over the tetrahedrons, with progress printing. CALL PROFLD(2,'Hydra',REAL(NTOTAL)) NTETRA=0 DO 1030 I=1,NTOTAL IF(I.EQ.MAX(1,NTOTAL/100)*(I/MAX(1,NTOTAL/100))) - CALL PROSTA(2,REAL(I)) * Skip tetrahedron or increment counter. IF(DELBKG.AND.DELFLG(I))THEN READ(12,'(/////)',ERR=2015,END=2005,IOSTAT=IOS) GOTO 1030 ELSE NTETRA=NTETRA+1 ENDIF * Skip the blank header. CALL INPGET * Read the data line. CALL INPGET CALL INPNUM(NWORD) IF(NWORD.NE.6)THEN PRINT *,' !!!!!! MAPFM5 WARNING : The format of '// - FAUX(1:NCAUX)//' is not known; map not read.' CALL INPSWI('RESTORE') RETURN ENDIF * Find the pointers to the .pnt file. CALL INPCHK(2,1,IFAIL1) CALL INPCHK(3,1,IFAIL2) CALL INPCHK(4,1,IFAIL3) CALL INPCHK(5,1,IFAIL4) CALL INPCHK(6,1,IFAIL5) CALL INPRDI(2,ITETRA,0) CALL INPRDI(3,IT1,0) CALL INPRDI(4,IT2,0) CALL INPRDI(5,IT3,0) CALL INPRDI(6,IT4,0) IF(IFAIL1.NE.0.OR.IFAIL2.NE.0.OR. - IFAIL3.NE.0.OR.IFAIL4.NE.0.OR.IFAIL5.NE.0.OR. - IT1.LE.0.OR.IT2.LE.0.OR.IT3.LE.0.OR.IT4.LE.0.OR. - ITETRA.LE.0.OR.ITETRA.GT.NTOTAL)THEN PRINT *,' !!!!!! MAPFM5 WARNING : Reference to points'// - ' unreadable in '//FAUX(1:NCAUX)//'; map not read.' CALL INPSWI('RESTORE') RETURN ENDIF * Store the reference pointers temporarily in Ex. EXMAP(NTETRA,1)=IT1 EXMAP(NTETRA,2)=IT2 EXMAP(NTETRA,3)=IT3 EXMAP(NTETRA,4)=IT4 * Skip the 4 lines of additional information. READ(12,'(///)',ERR=2015,END=2005,IOSTAT=IOS) 1030 CONTINUE * Make sure we're at the end. READ(12,'(A9)',ERR=2015,END=2005,IOSTAT=IOS) STRING(1:9) IF(STRING(1:9).NE.'end_hydra')PRINT *,' !!!!!! MAPFM5 WARNING'// - ' : Didn''t find the hydra EOF marker ; map probably'// - ' incomplete.' * Switch back to regular input. CALL INPSWI('RESTORE') * Close the hydra file. CLOSE(12,ERR=2030,IOSTAT=IOS) ** Construct the name of the .pnt file. FAUX(NCAUX-2:NCAUX)='pnt' * Open the points file. CALL DSNOPN(FAUX,NCAUX,12,'READ-FILE',IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! MAPFM5 WARNING : Unable to open the'// - ' points file '//FAUX(1:NCAUX)//'; map not read.' RETURN ENDIF * Record the opening. CALL DSNLOG(FAUX(1:NCAUX),'Points ','Sequential', - 'Read only ') ** Read the header records, switch to the data file. CALL INPSWI('UNIT12') * Read the number of points. CALL INPGET CALL INPNUM(NWORD) CALL INPCHK(2,1,IFAIL1) CALL INPRDI(2,NPOINT,0) IF(IFAIL1.NE.0.OR.NPOINT.LE.0.OR.NWORD.NE.2)THEN PRINT *,' !!!!!! MAPFM5 WARNING : The file '// - FAUX(1:NCAUX)//' has an unreadable number'// - ' of points; not read.' CALL INPSWI('RESTORE') RETURN ENDIF * Debugging output. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM5 DEBUG : Number'', - '' of points: '',I5)') NPOINT ** Loop over the tetrahedrons, with progress printing. CALL PROFLD(2,'Points',REAL(NPOINT)) FIRST=.TRUE. DO 1040 I=1,NPOINT IF(I.EQ.MAX(1,NPOINT/100)*(I/MAX(1,NPOINT/100))) - CALL PROSTA(2,REAL(I)) * Read the data line. CALL INPGET CALL INPNUM(NWORD) IF(NWORD.NE.5)THEN PRINT *,' !!!!!! MAPFM5 WARNING : The format of '// - FAUX(1:NCAUX)//' is not known; map not read.' CALL INPSWI('RESTORE') RETURN ENDIF * Read the point coordinates and the reference to the .hyd file. CALL INPCHK(2,1,IFAIL2) CALL INPCHK(3,2,IFAIL3) CALL INPCHK(4,2,IFAIL4) CALL INPCHK(5,2,IFAIL5) CALL INPRDI(2,IP,0) CALL INPRDR(3,XP,0.0) CALL INPRDR(4,YP,0.0) CALL INPRDR(5,ZP,0.0) IF(IFAIL2.NE.0.OR.IFAIL3.NE.0.OR.IFAIL4.NE.0.OR.IFAIL5.NE.0.OR. - IP.LE.0)THEN PRINT *,' !!!!!! MAPFM5 WARNING : Reference to hydra'// - ' unreadable in '//FAUX(1:NCAUX)//'; map not read.' CALL INPSWI('RESTORE') RETURN ENDIF * Convert from m to cm. XP=XP*100 YP=YP*100 ZP=ZP*100 * Store the tetrahedron parameters that refer to this point. NUSE=0 DO 1100 K=1,NTETRA DO 1110 J=1,4 IF(NINT(EXMAP(K,J)).EQ.IP)THEN NUSE=NUSE+1 XMAP(K,J)=XP YMAP(K,J)=YP ZMAP(K,J)=ZP EXMAP(K,J)=-1 ENDIF 1110 CONTINUE 1100 CONTINUE * If this point was not used, skip the rest. IF(NUSE.LE.0)GOTO 1040 * Update the chamber dimensions. IF(FIRST)THEN FIRST=.FALSE. XMMIN=XP XMMAX=XP YMMIN=YP YMMAX=YP ZMMIN=ZP ZMMAX=ZP ELSE XMMIN=MIN(XMMIN,XP) XMMAX=MAX(XMMAX,XP) YMMIN=MIN(YMMIN,YP) YMMAX=MAX(YMMAX,YP) ZMMIN=MIN(ZMMIN,ZP) ZMMAX=MAX(ZMMAX,ZP) ENDIF * Update angular ranges. IF(YP.NE.0.OR.ZP.NE.0)THEN IF(SETAX)THEN XAMIN=MIN(XAMIN,ATAN2(ZP,YP)) XAMAX=MAX(XAMAX,ATAN2(ZP,YP)) ELSE XAMIN=ATAN2(ZP,YP) XAMAX=ATAN2(ZP,YP) SETAX=.TRUE. ENDIF ENDIF IF(ZP.NE.0.OR.XP.NE.0)THEN IF(SETAY)THEN YAMIN=MIN(YAMIN,ATAN2(XP,ZP)) YAMAX=MAX(YAMAX,ATAN2(XP,ZP)) ELSE YAMIN=ATAN2(XP,ZP) YAMAX=ATAN2(XP,ZP) SETAY=.TRUE. ENDIF ENDIF IF(XP.NE.0.OR.YP.NE.0)THEN IF(SETAZ)THEN ZAMIN=MIN(ZAMIN,ATAN2(YP,XP)) ZAMAX=MAX(ZAMAX,ATAN2(YP,XP)) ELSE ZAMIN=ATAN2(YP,XP) ZAMAX=ATAN2(YP,XP) SETAZ=.TRUE. ENDIF ENDIF * Next point. 1040 CONTINUE * Make sure we're at the end. READ(12,'(A11)',ERR=2015,END=2005,IOSTAT=IOS) STRING(1:11) IF(STRING(1:11).NE.'end_points')PRINT *,' !!!!!! MAPFM5'// - ' WARNING : Didn''t find the points EOF marker ; map'// - ' probably incomplete.' ** Switch back to regular input. CALL INPSWI('RESTORE') * End of reading, make sure that all hydra references are solved. DO 1120 I=1,NTETRA DO 1130 J=1,4 IF(EXMAP(I,J).GE.0)THEN PRINT *,' !!!!!! MAPFM5 WARNING : Unresolved references'// - ' in hydra ; map rejected.' RETURN ENDIF 1130 CONTINUE 1120 CONTINUE * Store the number of tetrahedrons. NMAP=NTETRA ** Set the flag that the mesh is now defined. MAPFLG(1)=.TRUE. ** Print number of deletec tetrahedrons. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM5 DEBUG :'', - '' Tetrahedrons: '',I5,'' Background: '',I5)') - NTETRA,NDELET IF(NDELET.NE.0)PRINT *,' ------ MAPFM5 MESSAGE : Found ',NDELET, - ' background tetrahedrons.' ** In case this was an explicit mesh, return with success status. IF(IDATA.EQ.1)THEN IFAIL=0 RETURN * Otherwise, close the points file and re-open mesh file. ELSE CLOSE(12,ERR=2030,IOSTAT=IOS) CALL DSNOPN(FMAP,NCMAP,12,'READ-FILE',IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! MAPFM5 WARNING : Re-opening the'// - ' field map failed ; map not read.' RETURN ENDIF * Record the opening. CALL DSNLOG(FMAP(1:NCMAP),'Field map ','Sequential', - 'Re-read ') * Read the header records, switch to the data file. CALL INPSWI('UNIT12') CALL INPGET CALL INPNUM(NWORD) * Check for empty files. IF(NWORD.EQ.0)THEN PRINT *,' !!!!!! MAPFM5 WARNING : The file ', - FMAP(1:NCMAP),' seems to be empty; not read.' CALL INPSWI('RESTORE') CLOSE(12,STATUS='KEEP',ERR=2030,IOSTAT=IOS) RETURN ENDIF ENDIF *** Read the field map. 1000 CONTINUE * See whether the data is scalar or vector. IF(INPCMP(1,'SCALAR').NE.0)THEN SCALAR=.TRUE. ELSEIF(INPCMP(1,'VECTOR').NE.0)THEN SCALAR=.FALSE. ELSEIF(INPCMP(1,'HYDRAS')+INPCMP(1,'POINTS').NE.0)THEN PRINT *,' !!!!!! MAPFM5 WARNING : The file ', - FMAP(1:NCMAP),' contains a mesh, the mesh is'// - ' already defined ; file not read.' CALL INPSWI('RESTORE') RETURN ELSE PRINT *,' !!!!!! MAPFM5 WARNING : The file ', - FMAP(1:NCMAP),' contains neither scalar nor'// - ' vectorial data; not read.' CALL INPSWI('RESTORE') RETURN ENDIF * Initial contents flags. READ=.FALSE. NEWEPS=.FALSE. *** Determine the contents of the file, first for scalar files. IF(SCALAR)THEN * They contain 1 data word per line. IMAX=1 * Potentials. IF(INPCMP(3,'Phi')+INPCMP(3,'smh(Phi)').NE.0)THEN ICONT(1)=5 IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM5 DEBUG :'', - '' File contains a potential.'')') IF(MAPFLG(5))PRINT *,' ------ MAPFM5 MESSAGE :'// - ' Overwriting current potential map.' MAPFLG(5)=.FALSE. READ=.TRUE. * Dielectric constants. ELSEIF(INPCMP(3,'epsilon').NE.0)THEN ICONT(1)=9 IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM5 DEBUG :'', - '' File contains an epsilon map.'')') IF(MAPFLG(9))PRINT *,' ------ MAPFM5 MESSAGE :'// - ' Overwriting current material map.' MAPFLG(9)=.FALSE. NEWEPS=.TRUE. READ=.TRUE. MATSRC='EPSILON' * Conductivity. ELSEIF(INPCMP(3,'sigma').NE.0)THEN ICONT(1)=9 IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM5 DEBUG :'', - '' File contains a conductivity map.'')') IF(MAPFLG(9))PRINT *,' ------ MAPFM5 MESSAGE :'// - ' Overwriting current material map.' MAPFLG(9)=.FALSE. NEWEPS=.TRUE. READ=.TRUE. MATSRC='SIGMA' * All the rest is not known. ELSE CALL INPSTR(3,3,STRING,NC) PRINT *,' !!!!!! MAPFM5 WARNING : The file ', - FMAP(1:NCMAP),' contains the unknown "'// - STRING(1:NC)//'" field; ignored.' ICONT(1)=0 READ=.TRUE. ENDIF ICONT(2)=0 ICONT(3)=0 ** Next for vector files. ELSE * Which have 3 words per line. IMAX=3 * E field, either main field or weighting field. IF(INPCMP(3,'')+ - INPCMP(3,'').NE.0)THEN ICONT(1)=2 ICONT(2)=3 ICONT(3)=4 IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM5 DEBUG :'', - '' File contains an E field.'')') IF(IDATA.EQ.0.OR.IDATA.EQ.2)THEN IF(MAPFLG(2).OR.MAPFLG(3).OR.MAPFLG(4)) - PRINT *,' ------ MAPFM5 MESSAGE :'// - ' Overwriting current E field map.' MAPFLG(2)=.FALSE. MAPFLG(3)=.FALSE. MAPFLG(4)=.FALSE. ELSEIF(IDATA.EQ.10)THEN IF(MAPFLG(10+3*IWMAP-2).OR. - MAPFLG(11+3*IWMAP-2).OR. - MAPFLG(12+3*IWMAP-2)) - PRINT *,' ------ MAPFM5 MESSAGE :'// - ' Overwriting current weighting field map.' MAPFLG(10+3*IWMAP-2)=.FALSE. MAPFLG(11+3*IWMAP-2)=.FALSE. MAPFLG(12+3*IWMAP-2)=.FALSE. ENDIF READ=.TRUE. * B field. ELSEIF(INPCMP(3,'')+ - INPCMP(3,'').NE.0)THEN ICONT(1)=6 ICONT(2)=7 ICONT(3)=8 IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM5 DEBUG :'', - '' File contains a B field.'')') IF(MAPFLG(6).OR.MAPFLG(7).OR.MAPFLG(8)) - PRINT *,' ------ MAPFM5 MESSAGE :'// - ' Overwriting current E field map.' MAPFLG(6)=.FALSE. MAPFLG(7)=.FALSE. MAPFLG(8)=.FALSE. READ=.TRUE. * D field. ELSEIF(INPCMP(3,'')+ - INPCMP(3,'').NE.0)THEN ICONT(1)=-9 ICONT(2)=-9 ICONT(3)=-9 IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM5 DEBUG :'', - '' File contains a D field.'')') IF(MAPFLG(9))PRINT *,' ------ MAPFM5 MESSAGE :'// - ' Overwriting current material map.' MAPFLG(9)=.FALSE. READ=.TRUE. MATSRC='EPSILON' * All the rest is not known. ELSE CALL INPSTR(3,3,STRING,NC) PRINT *,' !!!!!! MAPFM5 WARNING : The file ', - FMAP(1:NCMAP),' contains the unknown "'// - STRING(1:NC)//' field; ignored.' ICONT(1)=0 ICONT(2)=0 ICONT(3)=0 READ=.TRUE. ENDIF ENDIF ** Ensure that the data type matches the declared type. DO 40 I=1,IMAX IF(((ICONT(I).EQ.2.OR.ICONT(I).EQ.3.OR.ICONT(I).EQ.4).AND. - (IDATA.NE.0.AND.IDATA.NE.2.AND.IDATA.NE.10)).OR. - (ICONT(I).EQ.5.AND.(IDATA.NE.0.AND.IDATA.NE.5)).OR. - ((ICONT(I).EQ.6.OR.ICONT(I).EQ.7.OR.ICONT(I).EQ.8).AND. - (IDATA.NE.0.AND.IDATA.NE.6)).OR. - ((ICONT(I).EQ.9.OR.ICONT(I).EQ.-9).AND. - (IDATA.NE.0.AND.IDATA.NE.9)))THEN PRINT *,' !!!!!! MAPFM5 WARNING : Field ',I,' of file ', - FMAP(1:NCMAP),' does not contain the declared', - ' kind of data; skipped.' ICONT(I)=0 ENDIF 40 CONTINUE *** Read the number of points and number of tetrahedrons. CALL INPGET CALL INPNUM(NWORD) * Verify the tetrahedron and points count. CALL INPCHK(2,1,IFAIL1) CALL INPCHK(4,1,IFAIL2) CALL INPRDI(2,MTETRA,0) CALL INPRDI(4,MPOINT,0) IF(IFAIL1.NE.0.OR.IFAIL2.NE.0.OR.NWORD.NE.4)THEN PRINT *,' !!!!!! MAPFM5 WARNING : The file ', - FMAP(1:NCMAP),' has an unreadable number'// - ' of tetrahedrons or points; not read.' CALL INPSWI('RESTORE') RETURN ENDIF * Debugging output. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM5 DEBUG : Number'', - '' of field tetrahedrons (incl bkg): '',I5)') NTOTAL * Progress printing. CALL PROFLD(2,'Tetrahedrons',REAL(NTOTAL)) *** Switch back to regular input. CALL INPSWI('RESTORE') * See whether any item is left. IF(.NOT.READ)THEN PRINT *,' !!!!!! MAPFM5 WARNING : The file ', - FMAP(1:NCMAP),' contains no useable'// - ' information; file not read.' RETURN ENDIF *** Loop over the tetrahedrons. NTETRA=0 DO 10 I=1,NTOTAL IF(I.EQ.MAX(1,NTOTAL/100)*(I/MAX(1,NTOTAL/100))) - CALL PROSTA(2,REAL(I)) *** Read the line with the word "Tet". 20 CONTINUE READ(12,'(A80)',END=2000,ERR=2010,IOSTAT=IOS) STRING IF(STRING(1:3).NE.'Tet')GOTO 20 * Read the tetrahedron number. READ(STRING,'(3X,BN,I10)',ERR=2010,IOSTAT=IOS) ITETRA * Ensure this number is in range. IF(ITETRA.LE.0.OR.ITETRA.GT.NTOTAL)THEN PRINT *,' !!!!!! MAPFM5 WARNING : Tetrahedron number ', - ITETRA,' out of range in ',FMAP(1:NCMAP) READ(12,'(/////////)',ERR=2010,END=2000,IOSTAT=IOS) GOTO 10 * Skip tetrahedron or increment counter. ELSEIF(DELBKG.AND.DELFLG(ITETRA))THEN READ(12,'(/////////)',ERR=2010,END=2000,IOSTAT=IOS) GOTO 10 ELSE NTETRA=NTETRA+1 ENDIF *** Read scalar field values over the tetrahedron. IF(SCALAR)THEN ** Can be either a potential, first read. IF(ICONT(1).EQ.5)THEN READ(12,*,END=2000,ERR=2010,IOSTAT=IOS) - (VMAP(NTETRA,LOOKUP(K)),K=1,10) * Then keep track of potential range. IF(I.EQ.1)THEN VMMIN=VMAP(NTETRA,1) VMMAX=VMAP(NTETRA,1) ENDIF VMMIN=MIN(VMMIN, - VMAP(NTETRA,1),VMAP(NTETRA,2),VMAP(NTETRA,3), - VMAP(NTETRA,4),VMAP(NTETRA,5),VMAP(NTETRA,6), - VMAP(NTETRA,7),VMAP(NTETRA,8),VMAP(NTETRA,9), - VMAP(NTETRA,10)) VMMAX=MAX(VMMAX, - VMAP(NTETRA,1),VMAP(NTETRA,2),VMAP(NTETRA,3), - VMAP(NTETRA,4),VMAP(NTETRA,5),VMAP(NTETRA,6), - VMAP(NTETRA,7),VMAP(NTETRA,8),VMAP(NTETRA,9), - VMAP(NTETRA,10)) ** Or a dielectricum, first read. ELSEIF(ICONT(1).EQ.9)THEN READ(12,*,END=2000,ERR=2010,IOSTAT=IOS) - (TEMP(K),K=1,10) * Average the epsilons/conductivity. SUM=0 DO 30 J=1,10 SUM=SUM+TEMP(J) 30 CONTINUE SUM=SUM/(1000*EPS0) * Identify the material. IEPS=-1 DO 80 J=1,NEPS IF(ABS(SUM-EPSMAT(J)).LT.1E-4*(ABS(SUM)+ - ABS(EPSMAT(J))))IEPS=J 80 CONTINUE IF(IEPS.LT.0.AND.NEPS.GE.MXEPS)THEN PRINT *,' !!!!!! MAPFM5 WARNING : Unable'// - ' to store a dielectricum from file ', - FMAP(1:NCMAP),'; file not read.' RETURN ELSEIF(IEPS.LT.0)THEN NEPS=NEPS+1 IEPS=NEPS EPSMAT(IEPS)=SUM IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM5'', - '' DEBUG : Adding dielectricum with'', - '' eps='',E10.3,''.'')') EPSMAT(IEPS) ENDIF MATMAP(NTETRA)=IEPS ENDIF *** Read vectorial field values over the tetrahedron. ELSE * Take care of knowing |D| either from Ex or by summing. IF(MAPFLG(10))DCOMP=EXMAP(NTETRA,1) * E or EW. IF(ICONT(1).EQ.2.AND.ICONT(2).EQ.3.AND.ICONT(3).EQ.4)THEN IF(IDATA.EQ.0.OR.IDATA.EQ.2)THEN READ(12,*,END=2000,ERR=2010,IOSTAT=IOS) - (EXMAP(NTETRA,LOOKUP(K)), - EYMAP(NTETRA,LOOKUP(K)), - EZMAP(NTETRA,LOOKUP(K)),K=1,10) ELSEIF(IDATA.EQ.10)THEN READ(12,*,END=2000,ERR=2010,IOSTAT=IOS) - (EWXMAP(NTETRA,LOOKUP(K),IWMAP), - EWYMAP(NTETRA,LOOKUP(K),IWMAP), - EWZMAP(NTETRA,LOOKUP(K),IWMAP),K=1,10) ENDIF * B. ELSEIF(ICONT(1).EQ.6.AND.ICONT(2).EQ.7.AND. - ICONT(3).EQ.8)THEN READ(12,*,END=2000,ERR=2010,IOSTAT=IOS) - (BXMAP(NTETRA,LOOKUP(K)), - BYMAP(NTETRA,LOOKUP(K)), - BZMAP(NTETRA,LOOKUP(K)),K=1,10) * D field. ELSEIF(ICONT(1).EQ.-9.AND.ICONT(2).EQ.-9.AND. - ICONT(3).EQ.-9)THEN DX=0 DY=0 DZ=0 DO 50 J=1,10 READ(12,*,END=2000,ERR=2010,IOSTAT=IOS) - (TEMP(K),K=1,3) IF(J.EQ.1.OR.J.EQ.5.OR.J.EQ.8.OR.J.EQ.10)THEN DX=DX+TEMP(1) DY=DY+TEMP(2) DZ=DZ+TEMP(3) ENDIF 50 CONTINUE DCOMP=(DX**2+DY**2+DZ**2)/160000 ENDIF ** Dielectricum identification via D/E comparison. IF((MAPFLG(2).AND.MAPFLG(3).AND.MAPFLG(4).AND. - (.NOT.MAPFLG(9)).AND.ICONT(1).EQ.-9.AND. - ICONT(2).EQ.-9.AND.ICONT(3).EQ.-9).OR. - (MAPFLG(10).AND.(.NOT.MAPFLG(9)).AND. - ICONT(1).EQ.2.AND.ICONT(2).EQ.3.AND. - ICONT(3).EQ.4))THEN IEPS=-1 ECOMP=((EXMAP(NTETRA,1)+EXMAP(NTETRA,2)+ - EXMAP(NTETRA,3)+EXMAP(NTETRA,4))**2+ - (EYMAP(NTETRA,1)+EYMAP(NTETRA,2)+ - EYMAP(NTETRA,3)+EYMAP(NTETRA,4))**2+ - (EZMAP(NTETRA,1)+EZMAP(NTETRA,2)+ - EZMAP(NTETRA,3)+EZMAP(NTETRA,4))**2)/16 IF(ICONT(1).EQ.2.AND.ICONT(2).EQ.3.AND. - ICONT(3).EQ.4)ECOMP=ECOMP/10000 DO 60 J=1,NEPS IF(ABS(ECOMP*(100*EPS0*EPSMAT(J))**2-DCOMP).LE.1E-4* - (ABS(ECOMP*(100*EPS0*EPSMAT(J))**2)+ - ABS(DCOMP)))IEPS=J 60 CONTINUE IF(ECOMP.LE.0.AND.DCOMP.GT.0)THEN PRINT *,' !!!!!! MAPFM5 WARNING : Found'// - ' a dielectric constant of 0; skipped.' ELSEIF(IEPS.LT.0.AND.NEPS.GE.MXEPS)THEN PRINT *,' !!!!!! MAPFM5 WARNING : Unable'// - ' to store a dielectricum from file ', - FMAP(1:NCMAP),'; file not read.' RETURN ELSEIF(IEPS.LT.0)THEN NEPS=NEPS+1 IEPS=NEPS IF(ECOMP.LE.0)THEN PRINT *,' ------ MAPFM5 MESSAGE : Unable'// - ' to determine epsilon in an E=0'// - ' tetrahedron; epsilon set to 0.' EPSMAT(IEPS)=0 ELSE EPSMAT(IEPS)=SQRT(DCOMP/ECOMP)/(100*EPS0) ENDIF IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM5'', - '' DEBUG : Adding dielectricum with'', - '' eps='',E10.3,''.'')') EPSMAT(IEPS) ENDIF MATMAP(NTETRA)=IEPS NEWEPS=.TRUE. * Otherwise store the field. ELSEIF(ICONT(1).EQ.-9.AND.ICONT(2).EQ.-9.AND. - ICONT(3).EQ.-9.AND.(.NOT.MAPFLG(2)))THEN EXMAP(NTETRA,1)=DCOMP ENDIF ENDIF 10 CONTINUE *** Be sure something has been read. 2000 CONTINUE IF(NTETRA.NE.NMAP)THEN PRINT *,' !!!!!! MAPFM5 WARNING : Number of'// - ' tetrahedrons in ',FMAP(1:NCMAP),' does not'// - ' match current mesh; not read.' RETURN ENDIF *** Materials have been defined is NEWEPS is set. IF(NEWEPS)MAPFLG(9)=.TRUE. *** Scale electric fields if they have been entered. IF(ICONT(1).EQ.2.AND.(IDATA.EQ.0.OR.IDATA.EQ.2))THEN DO 200 I=1,NMAP DO 210 J=1,10 EXMAP(I,J)=EXMAP(I,J)/100 EYMAP(I,J)=EYMAP(I,J)/100 EZMAP(I,J)=EZMAP(I,J)/100 210 CONTINUE 200 CONTINUE ELSEIF(ICONT(1).EQ.2.AND.IDATA.EQ.10)THEN DO 220 I=1,NMAP DO 230 J=1,10 EWXMAP(I,J,IWMAP)=EWXMAP(I,J,IWMAP)/100 EWYMAP(I,J,IWMAP)=EWYMAP(I,J,IWMAP)/100 EWZMAP(I,J,IWMAP)=EWZMAP(I,J,IWMAP)/100 230 CONTINUE 220 CONTINUE ENDIF *** Flag those elements which have been defined. DO 70 I=1,3 IF(ICONT(I).EQ.2.OR.ICONT(I).EQ.3.OR.ICONT(I).EQ.4)THEN IF(IDATA.EQ.0.OR.IDATA.EQ.2)THEN MAPFLG(ICONT(I))=.TRUE. ELSEIF(IDATA.EQ.10)THEN MAPFLG(8+ICONT(I)+3*IWMAP-2)=.TRUE. ENDIF ELSEIF(ICONT(I).GT.0)THEN MAPFLG(ICONT(I))=.TRUE. ELSEIF(ICONT(I).EQ.-9)THEN MAPFLG(10)=.TRUE. ENDIF 70 CONTINUE *** Seems to have worked, set error flag to OK and return. IFAIL=0 MAPTYP=12 RETURN *** Handle error conditions. 2005 CONTINUE PRINT *,' !!!!!! MAPFM5 WARNING : Premature end of file'// - ' reading a mesh file; map not available.' IF(LDEBUG)CALL INPIOS(IOS) CLOSE(12,ERR=2030) RETURN 2010 CONTINUE PRINT *,' !!!!!! MAPFM5 WARNING : Error reading field map'// - ' file ',FMAP(1:NCMAP),'; map not available.' IF(LDEBUG)CALL INPIOS(IOS) RETURN 2015 CONTINUE PRINT *,' !!!!!! MAPFM5 WARNING : Error reading a mesh'// - ' file ; map not available.' IF(LDEBUG)CALL INPIOS(IOS) CLOSE(12,ERR=2030) RETURN 2030 CONTINUE PRINT *,' !!!!!! MAPFM5 WARNING : Error closing field map'// - ' file ',FMAP(1:NCMAP),'; map not available.' IF(LDEBUG)CALL INPIOS(IOS) RETURN END +DECK,MAPFM6. SUBROUTINE MAPFM6(FMAP,NCMAP,IDATA,IWMAP, - WXMIN,WYMIN,WZMIN,WXMAX,WYMAX,WZMAX,WINDOW,IFAIL) *----------------------------------------------------------------------- * MAPFM6 - Reads a Tosca table of boxes (hexhedrons). * (Last changed on 29/11/99.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. +SEQ,FIELDMAP. +SEQ,CONSTANTS. INTEGER MXCONT PARAMETER(MXCONT=20) INTEGER IEPS,ICONT(MXCONT),IMAX,I,J,JJ,K,L,M,NCMAP,IFAIL, - IH1,IH2,IH3,IH4,IH5,IH6,IH7,IH8,IHEX,IOS,INPCMP, - IDATA,IP,NHEX,NPOINT,IWMAP, - MPOINT,IMAP(MXMAP,8) REAL TEMP(MXCONT),ECOMP,DCOMP,WXMIN,WYMIN,WZMIN, - WXMAX,WYMAX,WZMAX,XP,YP,ZP DOUBLE PRECISION DXMAP(MXMAP),DYMAP(MXMAP),DZMAP(MXMAP) CHARACTER*(*) FMAP CHARACTER*5 DATA LOGICAL READ,WINDOW,BXOK,BYOK,BZOK,DXOK,DYOK,DZOK, - EXOK,EYOK,EZOK EXTERNAL INPCMP +SELF,IF=SAVE. SAVE NHEX,NPOINT,DXMAP,DYMAP,DZMAP,IMAP +SELF. DATA NHEX/0/, NPOINT/0/ **** Identify the routine if requested. IF(LIDENT)PRINT *,' /// ROUTINE MAPFM6 ///' *** Assume that this will fail. IFAIL=1 *** We will only do Fortran reads, and want to read from the start. CALL INPSWI('RESTORE') REWIND(UNIT=12,ERR=2040,IOSTAT=IOS) *** If this is a mesh file. IF(IDATA.EQ.1)THEN * Read the number of hexahedrons. READ(12,'(I10)',END=2000,ERR=2010,IOSTAT=IOS) NPOINT * Check the value. IF(NPOINT.LE.0)THEN PRINT *,' !!!!!! MAPFM6 WARNING : The file ', - FMAP(1:NCMAP),' contains 0 or fewer'// - ' vertices; not read.' RETURN ENDIF * Debugging output. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM6 DEBUG :'', - '' Number of vertices: '',I5)') NPOINT ** Skip to the hexahedron composition. CALL PROFLD(2,'Skipping',-1.0) CALL PROSTA(2,0.0) DO 1010 I=1,NPOINT READ(12,'(1X)',END=2000,ERR=2010,IOSTAT=IOS) 1010 CONTINUE * Read the number of hexahedrons. READ(12,'(I10)',END=2000,ERR=2010,IOSTAT=IOS) NHEX * Check the value. IF(NHEX.LE.0)THEN PRINT *,' !!!!!! MAPFM6 WARNING : The file ', - FMAP(1:NCMAP),' contains 0 or fewer'// - ' hexahedrons; not read.' RETURN ELSEIF(NHEX.GT.MXMAP)THEN PRINT *,' !!!!!! MAPFM6 WARNING : Number of'// - ' hexahedrons in ',FMAP(1:NCMAP), - ' exceeds compilation limit; file not read.' RETURN ENDIF * Debugging output. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM6 DEBUG :'', - '' Number of hexahedrons: '',I5)') NHEX * Initialise the tetrahedron to vertex pointers. DO 1050 J=1,8 DO 1060 I=1,NHEX IMAP(I,J)=0 1060 CONTINUE 1050 CONTINUE ** Loop over the hexahedrons. CALL PROFLD(2,'Hexahedrons',REAL(NHEX)) DO 1030 I=1,NHEX IF(I.EQ.MAX(1,NHEX/100)*(I/MAX(1,NHEX/100))) - CALL PROSTA(2,REAL(I)) * Read the hexahedron number. READ(12,'(I10)',END=2000,ERR=2010,IOSTAT=IOS) IHEX * Read the pointers for its vertices. READ(12,'(8I10)',END=2000,ERR=2010,IOSTAT=IOS) - IH1,IH2,IH3,IH4,IH5,IH6,IH7,IH8 * Ensure they all make sense. IF(IH1.LE.0.OR.IH2.LE.0.OR.IH3.LE.0.OR.IH4.LE.0.OR. - IH5.LE.0.OR.IH6.LE.0.OR.IH7.LE.0.OR.IH8.LE.0.OR. - IHEX.LE.0.OR.IHEX.GT.NHEX)THEN PRINT *,' !!!!!! MAPFM6 WARNING : Invalid hexahedron'// - ' reference in ',FMAP(1:NCMAP),'; map not read.' IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM6 DEBUG :'', - '' Hexahedron '',I5,'' / '',I5,'', Points: '',I5/ - 26X,''Vertices: '',4(2X,I5)/37X,4(2X,I5))') - IHEX,NHEX,NPOINT,IH1,IH2,IH3,IH4,IH5,IH6,IH7,IH8 RETURN ENDIF * Store the reference pointers (negative sign for checks). IMAP(IHEX,1)=-IH1 IMAP(IHEX,2)=-IH2 IMAP(IHEX,3)=-IH3 IMAP(IHEX,4)=-IH4 IMAP(IHEX,5)=-IH5 IMAP(IHEX,6)=-IH6 IMAP(IHEX,7)=-IH7 IMAP(IHEX,8)=-IH8 1030 CONTINUE ** Return to the start of the file. CALL PROFLD(2,'Rewind',-1.0) CALL PROSTA(2,0.0) REWIND(UNIT=12,ERR=2040,IOSTAT=IOS) * Skip the number of points. READ(12,'()',END=2000,ERR=2010,IOSTAT=IOS) ** Loop over the points. CALL PROFLD(2,'Vertices',REAL(NPOINT)) DO 1040 I=1,NPOINT IF(I.EQ.MAX(1,NPOINT/100)*(I/MAX(1,NPOINT/100))) - CALL PROSTA(2,REAL(I)) * Read the line. READ(12,'(I10,3F21.8)',END=2000,ERR=2010,IOSTAT=IOS) - IP,XP,YP,ZP IF(IP.LE.0)THEN PRINT *,' !!!!!! MAPFM6 WARNING : Invalid point'// - ' reference in ',FMAP(1:NCMAP),'; map not read.' RETURN ENDIF * Update the chamber dimensions. IF(I.EQ.1)THEN XMMIN=XP XMMAX=XP YMMIN=YP YMMAX=YP ZMMIN=ZP ZMMAX=ZP ELSE XMMIN=MIN(XMMIN,XP) XMMAX=MAX(XMMAX,XP) YMMIN=MIN(YMMIN,YP) YMMAX=MAX(YMMAX,YP) ZMMIN=MIN(ZMMIN,ZP) ZMMAX=MAX(ZMMAX,ZP) ENDIF * Update angular ranges. IF(YP.NE.0.OR.ZP.NE.0)THEN IF(SETAX)THEN XAMIN=MIN(XAMIN,ATAN2(ZP,YP)) XAMAX=MAX(XAMAX,ATAN2(ZP,YP)) ELSE XAMIN=ATAN2(ZP,YP) XAMAX=ATAN2(ZP,YP) SETAX=.TRUE. ENDIF ENDIF IF(ZP.NE.0.OR.XP.NE.0)THEN IF(SETAY)THEN YAMIN=MIN(YAMIN,ATAN2(XP,ZP)) YAMAX=MAX(YAMAX,ATAN2(XP,ZP)) ELSE YAMIN=ATAN2(XP,ZP) YAMAX=ATAN2(XP,ZP) SETAY=.TRUE. ENDIF ENDIF IF(XP.NE.0.OR.YP.NE.0)THEN IF(SETAZ)THEN ZAMIN=MIN(ZAMIN,ATAN2(YP,XP)) ZAMAX=MAX(ZAMAX,ATAN2(YP,XP)) ELSE ZAMIN=ATAN2(YP,XP) ZAMAX=ATAN2(YP,XP) SETAZ=.TRUE. ENDIF ENDIF * Find referring hexahedrons, trace resolved references with sign. DO 1100 J=1,8 IF(J.EQ.1.OR.J.EQ.2)THEN JJ=J ELSEIF(J.EQ.4.OR.J.EQ.5)THEN JJ=J-1 ELSE JJ=0 ENDIF DO 1110 K=1,NHEX IF(IP.EQ.ABS(IMAP(K,J)))THEN IF(JJ.NE.0)THEN XMAP(K,JJ)=XP YMAP(K,JJ)=YP ZMAP(K,JJ)=ZP ENDIF IMAP(K,J)=ABS(IMAP(K,J)) ENDIF 1110 CONTINUE 1100 CONTINUE * Next point. 1040 CONTINUE * End of reading, check reference resolution. CALL PROFLD(2,'Verifying',-1.0) CALL PROSTA(2,0.0) DO 1120 J=1,8 DO 1130 I=1,NHEX IF(IMAP(I,J).LE.0)THEN PRINT *,' !!!!!! MAPFM6 WARNING : Unresolved point'// - ' references in mesh ; map rejected.' RETURN ENDIF 1130 CONTINUE 1120 CONTINUE * Preset Dx, Dy, Dz and the material. DO 1160 I=1,NHEX DXMAP(I)=0 DYMAP(I)=0 DZMAP(I)=0 MATMAP(I)=-1 1160 CONTINUE * Now set the number of elements. NMAP=NHEX * Set the flag that the mesh is now defined. MAPFLG(1)=.TRUE. * Set the element type. MAPTYP=14 *** Read field map files. ELSE * Make sure that the mesh has been read. IF(.NOT.MAPFLG(1))THEN PRINT *,' !!!!!! MAPFM6 WARNING : Attempt to read'// - ' a field map before the mesh ; not read.' RETURN ENDIF * Read the number of points in this file, check it matches the mesh. CALL PROFLD(2,'Contents',-1.0) CALL PROSTA(2,0.0) READ(12,'(I12)',END=2000,ERR=2010,IOSTAT=IOS) MPOINT IF(MPOINT.NE.NPOINT)THEN PRINT *,' !!!!!! MAPFM6 WARNING : Number of'// - ' points in ',FMAP(1:NCMAP),' does not'// - ' match current mesh; not read.' RETURN ENDIF ** Determine the contents of this field map. READ=.FALSE. IMAX=0 BXOK=.FALSE. BYOK=.FALSE. BZOK=.FALSE. DXOK=.FALSE. DYOK=.FALSE. DZOK=.FALSE. EXOK=.FALSE. EYOK=.FALSE. EZOK=.FALSE. * Read up to the line stating the units. 100 CONTINUE READ(12,'(3X,A5)',END=2000,ERR=2010,IOSTAT=IOS) DATA IF(DATA.EQ.'[CGS]')THEN GOTO 110 ELSEIF(IMAX.GE.MXCONT)THEN PRINT *,' !!!!!! MAPFM6 WARNING : Number of data'// - ' fields in ',FMAP(1:NCMAP),' is too large;'// - ' not read.' RETURN ENDIF IMAX=IMAX+1 * Coordinates. IF(DATA.EQ.'X'.OR.DATA.EQ.'Y'.OR.DATA.EQ.'Z')THEN ICONT(IMAX)=1 * Ex or Ewx. ELSEIF(DATA.EQ.'EX')THEN IF(IDATA.EQ.10)THEN IF(MAPFLG(10+3*IWMAP-2)) - PRINT *,' ------ MAPFM6 MESSAGE :'// - ' Overwriting current weighting Ex map.' MAPFLG(10+3*IWMAP-2)=.FALSE. ICONT(IMAX)=10+3*IWMAP-2 ELSE IF(MAPFLG(2))PRINT *,' ------ MAPFM6 MESSAGE :'// - ' Overwriting current Ex field map.' MAPFLG(2)=.FALSE. ICONT(IMAX)=2 ENDIF EXOK=.TRUE. READ=.TRUE. * Ey or Ewy. ELSEIF(DATA.EQ.'EY')THEN IF(IDATA.EQ.10)THEN IF(MAPFLG(11+3*IWMAP-2)) - PRINT *,' ------ MAPFM6 MESSAGE :'// - ' Overwriting current weighting Ey map.' MAPFLG(11+3*IWMAP-2)=.FALSE. ICONT(IMAX)=11+3*IWMAP-2 ELSE IF(MAPFLG(3))PRINT *,' ------ MAPFM6 MESSAGE :'// - ' Overwriting current Ey field map.' MAPFLG(3)=.FALSE. ICONT(IMAX)=3 ENDIF EYOK=.TRUE. READ=.TRUE. * Ez or Ewz. ELSEIF(DATA.EQ.'EZ')THEN IF(IDATA.EQ.10)THEN IF(MAPFLG(12+3*IWMAP-2)) - PRINT *,' ------ MAPFM6 MESSAGE :'// - ' Overwriting current weighting Ez map.' MAPFLG(12+3*IWMAP-2)=.FALSE. ICONT(IMAX)=12+3*IWMAP-2 ELSE IF(MAPFLG(4))PRINT *,' ------ MAPFM6 MESSAGE :'// - ' Overwriting current Ez field map.' MAPFLG(4)=.FALSE. ICONT(IMAX)=4 ENDIF EZOK=.TRUE. READ=.TRUE. * Potential. ELSEIF(DATA.EQ.'V')THEN IF(MAPFLG(5))PRINT *,' ------ MAPFM6 MESSAGE :'// - ' Overwriting current potential map.' MAPFLG(5)=.FALSE. ICONT(IMAX)=5 READ=.TRUE. * Bx, By and Bz. ELSEIF(DATA.EQ.'BX')THEN IF(MAPFLG(6))PRINT *,' ------ MAPFM6 MESSAGE :'// - ' Overwriting current Bx field map.' MAPFLG(6)=.FALSE. ICONT(IMAX)=6 BXOK=.TRUE. READ=.TRUE. ELSEIF(DATA.EQ.'BY')THEN IF(MAPFLG(7))PRINT *,' ------ MAPFM6 MESSAGE :'// - ' Overwriting current Bx field map.' MAPFLG(7)=.FALSE. ICONT(IMAX)=7 BYOK=.TRUE. READ=.TRUE. ELSEIF(DATA.EQ.'BZ')THEN IF(MAPFLG(8))PRINT *,' ------ MAPFM6 MESSAGE :'// - ' Overwriting current Bx field map.' MAPFLG(8)=.FALSE. ICONT(IMAX)=8 BZOK=.TRUE. READ=.TRUE. * Dx, Dy and Dz. ELSEIF(DATA.EQ.'DX'.OR.DATA.EQ.'DY'.OR.DATA.EQ.'DZ')THEN IF(DATA.EQ.'DX')THEN ICONT(IMAX)=-2 DXOK=.TRUE. ELSEIF(DATA.EQ.'DY')THEN ICONT(IMAX)=-3 DYOK=.TRUE. ELSEIF(DATA.EQ.'DZ')THEN ICONT(IMAX)=-4 DZOK=.TRUE. ENDIF IF(DXOK.AND.DYOK.AND.DZOK)THEN IF(MAPFLG(9))PRINT *,' ------ MAPFM6 MESSAGE :'// - ' Overwriting current material map.' MAPFLG(9)=.FALSE. ENDIF READ=.TRUE. MATSRC='EPSILON' * Other fields. ELSE PRINT *,' !!!!!! MAPFM6 WARNING : The file ', - FMAP(1:NCMAP),' contains data of the unknown'// - ' kind '//DATA//'; item skipped.' ICONT(IMAX)=0 ENDIF GOTO 100 110 CONTINUE ** See whether any item is to be read. IF(.NOT.READ)THEN PRINT *,' !!!!!! MAPFM6 WARNING : The file ', - FMAP(1:NCMAP),' contains no useable'// - ' information; file not read.' RETURN * Make sure all 3 components of a vector are present. ELSEIF((BXOK.AND..NOT.(BYOK.AND.BZOK)).OR. - (BYOK.AND..NOT.(BXOK.AND.BZOK)).OR. - (BZOK.AND..NOT.(BXOK.AND.BYOK)))THEN PRINT *,' !!!!!! MAPFM6 WARNING : Bx, By and Bz must'// - ' appear in one file; ',FMAP(1:NCMAP),' not read.' RETURN ELSEIF((DXOK.AND..NOT.(DYOK.AND.DZOK)).OR. - (DYOK.AND..NOT.(DXOK.AND.DZOK)).OR. - (DZOK.AND..NOT.(DXOK.AND.DYOK)))THEN PRINT *,' !!!!!! MAPFM6 WARNING : Dx, Dy and Dz must'// - ' appear in one file; ',FMAP(1:NCMAP),' not read.' RETURN ELSEIF((EXOK.AND..NOT.(EYOK.AND.EZOK)).OR. - (EYOK.AND..NOT.(EXOK.AND.EZOK)).OR. - (EZOK.AND..NOT.(EXOK.AND.EYOK)))THEN PRINT *,' !!!!!! MAPFM6 WARNING : Ex, Ey and Ez must'// - ' appear in one file; ',FMAP(1:NCMAP),' not read.' RETURN ENDIF ** Read the list of points with associated field values. CALL PROFLD(2,'Vertices',REAL(NPOINT)) DO 10 I=1,NPOINT IF(I.EQ.MAX(1,NPOINT/100)*(I/MAX(1,NPOINT/100))) - CALL PROSTA(2,REAL(I)) * Read the data line. READ(12,'(10F13.4)',END=2000,ERR=2010,IOSTAT=IOS) - (TEMP(J),J=1,IMAX) * Assign the data to the arrays. DO 20 L=1,8 DO 30 K=1,NHEX DO 40 J=1,IMAX IF(ICONT(J).EQ.2.AND.IMAP(K,L).EQ.I)THEN EXMAP(K,L)=TEMP(J) ELSEIF(ICONT(J).EQ.3.AND.IMAP(K,L).EQ.I)THEN EYMAP(K,L)=TEMP(J) ELSEIF(ICONT(J).EQ.4.AND.IMAP(K,L).EQ.I)THEN EZMAP(K,L)=TEMP(J) ELSEIF(ICONT(J).EQ.5.AND.IMAP(K,L).EQ.I)THEN VMAP(K,L)=TEMP(J) IF(I.EQ.1)THEN VMMIN=TEMP(J) VMMAX=TEMP(J) ELSE VMMIN=MIN(VMMIN,TEMP(J)) VMMAX=MAX(VMMAX,TEMP(J)) ENDIF ELSEIF(ICONT(J).EQ.6.AND.IMAP(K,L).EQ.I)THEN BXMAP(K,L)=TEMP(J) ELSEIF(ICONT(J).EQ.7.AND.IMAP(K,L).EQ.I)THEN BYMAP(K,L)=TEMP(J) ELSEIF(ICONT(J).EQ.8.AND.IMAP(K,L).EQ.I)THEN BZMAP(K,L)=TEMP(J) ELSEIF(ICONT(J).EQ.9.AND.IMAP(K,L).EQ.I.AND.L.EQ.1)THEN IEPS=-1 DO 80 M=1,NEPS IF(ABS(TEMP(J)-EPSMAT(M)).LT.1E-4*(ABS(TEMP(J))+ - ABS(EPSMAT(M))))IEPS=M 80 CONTINUE IF(IEPS.LT.0.AND.NEPS.GE.MXEPS)THEN PRINT *,' !!!!!! MAPFM6 WARNING : More media'// - ' than storage allows in file ', - FMAP(1:NCMAP),'; medium not assigned.' RETURN ELSEIF(IEPS.LT.0)THEN NEPS=NEPS+1 IEPS=NEPS EPSMAT(IEPS)=TEMP(J) IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM6'', - '' DEBUG : Adding dielectricum with'', - '' eps='',E10.3,''.'')') EPSMAT(IEPS) ENDIF MATMAP(K)=IEPS ELSEIF(ICONT(J).EQ.-2.AND.IMAP(K,L).EQ.I)THEN DXMAP(K)=DXMAP(K)+TEMP(J) ELSEIF(ICONT(J).EQ.-3.AND.IMAP(K,L).EQ.I)THEN DYMAP(K)=DYMAP(K)+TEMP(J) ELSEIF(ICONT(J).EQ.-4.AND.IMAP(K,L).EQ.I)THEN DZMAP(K)=DZMAP(K)+TEMP(J) ELSEIF(ICONT(J).GE.11.AND.IMAP(K,L).EQ.I)THEN EWXMAP(K,L,IWMAP)=TEMP(J) ELSEIF(ICONT(J).GE.12.AND.IMAP(K,L).EQ.I)THEN EWYMAP(K,L,IWMAP)=TEMP(J) ELSEIF(ICONT(J).GE.13.AND.IMAP(K,L).EQ.I)THEN EWZMAP(K,L,IWMAP)=TEMP(J) ENDIF 40 CONTINUE 30 CONTINUE 20 CONTINUE * Next point. 10 CONTINUE ** Flag those elements which have been defined. DO 70 I=1,IMAX IF(ICONT(I).GT.0)THEN MAPFLG(ICONT(I))=.TRUE. ELSEIF(ICONT(I).EQ.-2.OR.ICONT(I).EQ.-3.OR. - ICONT(I).EQ.-4)THEN MAPFLG(10)=.TRUE. ENDIF 70 CONTINUE ** Identify materials if both D and E are now available. IF(MAPFLG(2).AND.MAPFLG(3).AND.MAPFLG(4).AND. - MAPFLG(10).AND..NOT.MAPFLG(9))THEN * Loop over the elements. CALL PROFLD(2,'Epsilons',REAL(NMAP)) DO 50 I=1,NMAP IF(I.EQ.MAX(1,NMAP/100)*(I/MAX(1,NMAP/100))) - CALL PROSTA(2,REAL(I)) IEPS=-1 * Compute |E| and |D| up to a factor 64. ECOMP=(EXMAP(I,1)+EXMAP(I,2)+EXMAP(I,3)+EXMAP(I,4)+ - EXMAP(I,5)+EXMAP(I,6)+EXMAP(I,7)+EXMAP(I,8))**2+ - (EYMAP(I,1)+EYMAP(I,2)+EYMAP(I,3)+EYMAP(I,4)+ - EYMAP(I,5)+EYMAP(I,6)+EYMAP(I,7)+EYMAP(I,8))**2+ - (EZMAP(I,1)+EZMAP(I,2)+EZMAP(I,3)+EZMAP(I,4)+ - EZMAP(I,5)+EZMAP(I,6)+EZMAP(I,7)+EZMAP(I,8))**2 DCOMP=DXMAP(I)**2+DYMAP(I)**2+DZMAP(I)**2 * Match with existing epsilons. DO 60 J=1,NEPS IF((ECOMP.LE.0.AND.EPSMAT(J).LE.0).OR.( - ABS(ECOMP*(EPS0*EPSMAT(J))**2-DCOMP).LE.1E-4* - (ABS(ECOMP*(EPS0*EPSMAT(J))**2)+ - ABS(DCOMP))))IEPS=J 60 CONTINUE * Check for |E|=|D|=0. IF(ECOMP.LE.0.AND.DCOMP.GT.0)THEN PRINT *,' !!!!!! MAPFM6 WARNING : Found'// - ' a dielectric constant of 0; skipped.' * Warn if we run out of spcae. ELSEIF(IEPS.LT.0.AND.NEPS.GE.MXEPS)THEN PRINT *,' !!!!!! MAPFM6 WARNING : More media'// - ' than storage allows in file ', - FMAP(1:NCMAP),'; medium not assigned.' RETURN * Add new epsilon to the table. ELSEIF(IEPS.LT.0)THEN NEPS=NEPS+1 IEPS=NEPS IF(ECOMP.LE.0)THEN PRINT *,' ------ MAPFM6 MESSAGE : Unable'// - ' to determine epsilon in an E=0'// - ' hexahedron; epsilon set to 0.' EPSMAT(IEPS)=0 ELSE EPSMAT(IEPS)=SQRT(DCOMP/ECOMP)/EPS0 ENDIF IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPFM6'', - '' DEBUG : Adding dielectricum with'', - '' eps='',E10.3,''.'')') EPSMAT(IEPS) ENDIF * Assign the value. MATMAP(I)=IEPS 50 CONTINUE * Set the flag. MAPFLG(9)=.TRUE. ENDIF ENDIF *** Seems to have worked, set error flag to OK and return. IFAIL=0 RETURN *** Error handling. 2000 CONTINUE PRINT *,' !!!!!! MAPFM6 WARNING : Premature end of file on ', - FMAP(1:NCMAP),'; file not read.' IF(LDEBUG)CALL INPIOS(IOS) RETURN 2010 CONTINUE PRINT *,' !!!!!! MAPFM6 WARNING : Error while reading ', - FMAP(1:NCMAP),'; file not read.' IF(LDEBUG)CALL INPIOS(IOS) RETURN 2040 CONTINUE PRINT *,' !!!!!! MAPFM6 WARNING : Error while rewinding ', - FMAP(1:NCMAP),'; file not read.' IF(LDEBUG)CALL INPIOS(IOS) RETURN END +DECK,MAPIND. SUBROUTINE MAPIND(X,Y,Z,T1,T2,T3,T4,IMAP) *----------------------------------------------------------------------- * MAPIND - Finds the index of the triangle or tetrahedron in which * (X,Y,Z) is located and returns the triangle / tetrahedron * coordinates of the point. * (Last changed on 10/ 3/99.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,FIELDMAP. +SEQ,PRINTPLOT. INTEGER MXFOUN PARAMETER(MXFOUN=10) REAL X,Y,Z,T1,T2,T3,T4,TT1,TT2,TT3,TT4,PAR(3,3),VEC(3),RAUX(3) INTEGER I,IMAP,IL,NFOUND,IFOUND(MXFOUN),IFAIL DATA IL/0/ +SELF,IF=SAVE. SAVE IL +SELF. *** Initial values. T1=0 T2=0 T3=0 T4=0 IMAP=0 *** Verify the count of volumes that contain the point. NFOUND=0 *** Check for the last volume, first tetrahedrons. IF((MAPTYP.EQ.11.OR.MAPTYP.EQ.12.OR.MAPTYP.EQ.13).AND. - IL.GE.1.AND.IL.LE.NMAP.AND..NOT.LMAPCH)THEN TT1=(X-XMAP(IL,2))*( - (YMAP(IL,3)-YMAP(IL,2))*(ZMAP(IL,4)-ZMAP(IL,2))- - (YMAP(IL,4)-YMAP(IL,2))*(ZMAP(IL,3)-ZMAP(IL,2)))+ - (Y-YMAP(IL,2))*( - (ZMAP(IL,3)-ZMAP(IL,2))*(XMAP(IL,4)-XMAP(IL,2))- - (ZMAP(IL,4)-ZMAP(IL,2))*(XMAP(IL,3)-XMAP(IL,2)))+ - (Z-ZMAP(IL,2))*( - (XMAP(IL,3)-XMAP(IL,2))*(YMAP(IL,4)-YMAP(IL,2))- - (XMAP(IL,4)-XMAP(IL,2))*(YMAP(IL,3)-YMAP(IL,2))) TT2=(X-XMAP(IL,3))*( - (YMAP(IL,1)-YMAP(IL,3))*(ZMAP(IL,4)-ZMAP(IL,3))- - (YMAP(IL,4)-YMAP(IL,3))*(ZMAP(IL,1)-ZMAP(IL,3)))+ - (Y-YMAP(IL,3))*( - (ZMAP(IL,1)-ZMAP(IL,3))*(XMAP(IL,4)-XMAP(IL,3))- - (ZMAP(IL,4)-ZMAP(IL,3))*(XMAP(IL,1)-XMAP(IL,3)))+ - (Z-ZMAP(IL,3))*( - (XMAP(IL,1)-XMAP(IL,3))*(YMAP(IL,4)-YMAP(IL,3))- - (XMAP(IL,4)-XMAP(IL,3))*(YMAP(IL,1)-YMAP(IL,3))) TT3=(X-XMAP(IL,4))*( - (YMAP(IL,1)-YMAP(IL,4))*(ZMAP(IL,2)-ZMAP(IL,4))- - (YMAP(IL,2)-YMAP(IL,4))*(ZMAP(IL,1)-ZMAP(IL,4)))+ - (Y-YMAP(IL,4))*( - (ZMAP(IL,1)-ZMAP(IL,4))*(XMAP(IL,2)-XMAP(IL,4))- - (ZMAP(IL,2)-ZMAP(IL,4))*(XMAP(IL,1)-XMAP(IL,4)))+ - (Z-ZMAP(IL,4))*( - (XMAP(IL,1)-XMAP(IL,4))*(YMAP(IL,2)-YMAP(IL,4))- - (XMAP(IL,2)-XMAP(IL,4))*(YMAP(IL,1)-YMAP(IL,4))) TT4=(X-XMAP(IL,1))*( - (YMAP(IL,3)-YMAP(IL,1))*(ZMAP(IL,2)-ZMAP(IL,1))- - (YMAP(IL,2)-YMAP(IL,1))*(ZMAP(IL,3)-ZMAP(IL,1)))+ - (Y-YMAP(IL,1))*( - (ZMAP(IL,3)-ZMAP(IL,1))*(XMAP(IL,2)-XMAP(IL,1))- - (ZMAP(IL,2)-ZMAP(IL,1))*(XMAP(IL,3)-XMAP(IL,1)))+ - (Z-ZMAP(IL,1))*( - (XMAP(IL,3)-XMAP(IL,1))*(YMAP(IL,2)-YMAP(IL,1))- - (XMAP(IL,2)-XMAP(IL,1))*(YMAP(IL,3)-YMAP(IL,1))) IF((TT1.GE.0.AND.TT2.GE.0.AND.TT3.GE.0.AND.TT4.GE.0).OR. - (TT1.LE.0.AND.TT2.LE.0.AND.TT3.LE.0.AND.TT4.LE.0))THEN T1=TT1/((XMAP(IL,1)-XMAP(IL,2))*( - (YMAP(IL,3)-YMAP(IL,2))*(ZMAP(IL,4)-ZMAP(IL,2))- - (YMAP(IL,4)-YMAP(IL,2))*(ZMAP(IL,3)-ZMAP(IL,2)))+ - (YMAP(IL,1)-YMAP(IL,2))*( - (ZMAP(IL,3)-ZMAP(IL,2))*(XMAP(IL,4)-XMAP(IL,2))- - (ZMAP(IL,4)-ZMAP(IL,2))*(XMAP(IL,3)-XMAP(IL,2)))+ - (ZMAP(IL,1)-ZMAP(IL,2))*( - (XMAP(IL,3)-XMAP(IL,2))*(YMAP(IL,4)-YMAP(IL,2))- - (XMAP(IL,4)-XMAP(IL,2))*(YMAP(IL,3)-YMAP(IL,2)))) T2=TT2/((XMAP(IL,2)-XMAP(IL,3))*( - (YMAP(IL,1)-YMAP(IL,3))*(ZMAP(IL,4)-ZMAP(IL,3))- - (YMAP(IL,4)-YMAP(IL,3))*(ZMAP(IL,1)-ZMAP(IL,3)))+ - (YMAP(IL,2)-YMAP(IL,3))*( - (ZMAP(IL,1)-ZMAP(IL,3))*(XMAP(IL,4)-XMAP(IL,3))- - (ZMAP(IL,4)-ZMAP(IL,3))*(XMAP(IL,1)-XMAP(IL,3)))+ - (ZMAP(IL,2)-ZMAP(IL,3))*( - (XMAP(IL,1)-XMAP(IL,3))*(YMAP(IL,4)-YMAP(IL,3))- - (XMAP(IL,4)-XMAP(IL,3))*(YMAP(IL,1)-YMAP(IL,3)))) T3=TT3/((XMAP(IL,3)-XMAP(IL,4))*( - (YMAP(IL,1)-YMAP(IL,4))*(ZMAP(IL,2)-ZMAP(IL,4))- - (YMAP(IL,2)-YMAP(IL,4))*(ZMAP(IL,1)-ZMAP(IL,4)))+ - (YMAP(IL,3)-YMAP(IL,4))*( - (ZMAP(IL,1)-ZMAP(IL,4))*(XMAP(IL,2)-XMAP(IL,4))- - (ZMAP(IL,2)-ZMAP(IL,4))*(XMAP(IL,1)-XMAP(IL,4)))+ - (ZMAP(IL,3)-ZMAP(IL,4))*( - (XMAP(IL,1)-XMAP(IL,4))*(YMAP(IL,2)-YMAP(IL,4))- - (XMAP(IL,2)-XMAP(IL,4))*(YMAP(IL,1)-YMAP(IL,4)))) T4=TT4/((XMAP(IL,4)-XMAP(IL,1))*( - (YMAP(IL,3)-YMAP(IL,1))*(ZMAP(IL,2)-ZMAP(IL,1))- - (YMAP(IL,2)-YMAP(IL,1))*(ZMAP(IL,3)-ZMAP(IL,1)))+ - (YMAP(IL,4)-YMAP(IL,1))*( - (ZMAP(IL,3)-ZMAP(IL,1))*(XMAP(IL,2)-XMAP(IL,1))- - (ZMAP(IL,2)-ZMAP(IL,1))*(XMAP(IL,3)-XMAP(IL,1)))+ - (ZMAP(IL,4)-ZMAP(IL,1))*( - (XMAP(IL,3)-XMAP(IL,1))*(YMAP(IL,2)-YMAP(IL,1))- - (XMAP(IL,2)-XMAP(IL,1))*(YMAP(IL,3)-YMAP(IL,1)))) IMAP=IL RETURN ENDIF * Triangles. ELSEIF((MAPTYP.EQ.1.OR.MAPTYP.EQ.2.OR.MAPTYP.EQ.3).AND. - IL.GE.1.AND.IL.LE.NMAP.AND..NOT.LMAPCH)THEN TT1=(X-XMAP(IL,2))*(YMAP(IL,3)-YMAP(IL,2))- - (Y-YMAP(IL,2))*(XMAP(IL,3)-XMAP(IL,2)) TT2=(X-XMAP(IL,3))*(YMAP(IL,1)-YMAP(IL,3))- - (Y-YMAP(IL,3))*(XMAP(IL,1)-XMAP(IL,3)) TT3=(X-XMAP(IL,1))*(YMAP(IL,2)-YMAP(IL,1))- - (Y-YMAP(IL,1))*(XMAP(IL,2)-XMAP(IL,1)) IF((TT1.GE.0.AND.TT2.GE.0.AND.TT3.GE.0).OR. - (TT1.LE.0.AND.TT2.LE.0.AND.TT3.LE.0))THEN T1=TT1/ - ((XMAP(IL,1)-XMAP(IL,2))*(YMAP(IL,3)-YMAP(IL,2))- - (XMAP(IL,3)-XMAP(IL,2))*(YMAP(IL,1)-YMAP(IL,2))) T2=TT2/ - ((XMAP(IL,2)-XMAP(IL,3))*(YMAP(IL,1)-YMAP(IL,3))- - (XMAP(IL,1)-XMAP(IL,3))*(YMAP(IL,2)-YMAP(IL,3))) T3=TT3/ - ((XMAP(IL,3)-XMAP(IL,1))*(YMAP(IL,2)-YMAP(IL,1))- - (XMAP(IL,2)-XMAP(IL,1))*(YMAP(IL,3)-YMAP(IL,1))) T4=0 IMAP=IL RETURN ENDIF * Regular hexahedrons. ELSEIF((MAPTYP.EQ.14.OR.MAPTYP.EQ.15.OR.MAPTYP.EQ.16).AND. - IL.GE.1.AND.IL.LE.NMAP.AND..NOT.LMAPCH)THEN PAR(1,1)=(XMAP(IL,2)-XMAP(IL,1))**2+ - (YMAP(IL,2)-YMAP(IL,1))**2+(ZMAP(IL,2)-ZMAP(IL,1))**2 PAR(2,2)=(XMAP(IL,3)-XMAP(IL,1))**2+ - (YMAP(IL,3)-YMAP(IL,1))**2+(ZMAP(IL,3)-ZMAP(IL,1))**2 PAR(3,3)=(XMAP(IL,4)-XMAP(IL,1))**2+ - (YMAP(IL,4)-YMAP(IL,1))**2+(ZMAP(IL,4)-ZMAP(IL,1))**2 PAR(1,2)= - (XMAP(IL,2)-XMAP(IL,1))*(XMAP(IL,3)-XMAP(IL,1))+ - (YMAP(IL,2)-YMAP(IL,1))*(YMAP(IL,3)-YMAP(IL,1))+ - (ZMAP(IL,2)-ZMAP(IL,1))*(ZMAP(IL,3)-ZMAP(IL,1)) PAR(2,1)=PAR(1,2) PAR(1,3)= - (XMAP(IL,2)-XMAP(IL,1))*(XMAP(IL,4)-XMAP(IL,1))+ - (YMAP(IL,2)-YMAP(IL,1))*(YMAP(IL,4)-YMAP(IL,1))+ - (ZMAP(IL,2)-ZMAP(IL,1))*(ZMAP(IL,4)-ZMAP(IL,1)) PAR(3,1)=PAR(1,3) PAR(2,3)= - (XMAP(IL,3)-XMAP(IL,1))*(XMAP(IL,4)-XMAP(IL,1))+ - (YMAP(IL,3)-YMAP(IL,1))*(YMAP(IL,4)-YMAP(IL,1))+ - (ZMAP(IL,3)-ZMAP(IL,1))*(ZMAP(IL,4)-ZMAP(IL,1)) PAR(2,3)=PAR(3,2) VEC(1)=(X-XMAP(IL,1))*(XMAP(IL,2)-XMAP(IL,1))+ - (Y-YMAP(IL,1))*(YMAP(IL,2)-YMAP(IL,1))+ - (Z-ZMAP(IL,1))*(ZMAP(IL,2)-ZMAP(IL,1)) VEC(2)=(X-XMAP(IL,1))*(XMAP(IL,3)-XMAP(IL,1))+ - (Y-YMAP(IL,1))*(YMAP(IL,3)-YMAP(IL,1))+ - (Z-ZMAP(IL,1))*(ZMAP(IL,3)-ZMAP(IL,1)) VEC(3)=(X-XMAP(IL,1))*(XMAP(IL,4)-XMAP(IL,1))+ - (Y-YMAP(IL,1))*(YMAP(IL,4)-YMAP(IL,1))+ - (Z-ZMAP(IL,1))*(ZMAP(IL,4)-ZMAP(IL,1)) CALL REQN(3,PAR,3,RAUX,IFAIL,1,VEC) IF(IFAIL.NE.0)THEN IMAP=0 RETURN ENDIF IF(VEC(1).GE.0.AND.VEC(1).LE.1.AND. - VEC(2).GE.0.AND.VEC(2).LE.1.AND. - VEC(3).GE.0.AND.VEC(3).LE.1)THEN T1=VEC(1) T2=VEC(2) T3=VEC(3) T4=0 IMAP=IL RETURN ENDIF ENDIF *** Loop over the volumes, first tetrahedrons. IF(MAPTYP.EQ.11.OR.MAPTYP.EQ.12.OR.MAPTYP.EQ.13)THEN DO 10 I=1,NMAP IF(X.LT.MIN(XMAP(I,1),XMAP(I,2),XMAP(I,3),XMAP(I,4)).OR. - X.GT.MAX(XMAP(I,1),XMAP(I,2),XMAP(I,3),XMAP(I,4)).OR. - Y.LT.MIN(YMAP(I,1),YMAP(I,2),YMAP(I,3),YMAP(I,4)).OR. - Y.GT.MAX(YMAP(I,1),YMAP(I,2),YMAP(I,3),YMAP(I,4)).OR. - Z.LT.MIN(ZMAP(I,1),ZMAP(I,2),ZMAP(I,3),ZMAP(I,4)).OR. - Z.GT.MAX(ZMAP(I,1),ZMAP(I,2),ZMAP(I,3),ZMAP(I,4))) - GOTO 10 TT1=(X-XMAP(I,2))*( - (YMAP(I,3)-YMAP(I,2))*(ZMAP(I,4)-ZMAP(I,2))- - (YMAP(I,4)-YMAP(I,2))*(ZMAP(I,3)-ZMAP(I,2)))+ - (Y-YMAP(I,2))*( - (ZMAP(I,3)-ZMAP(I,2))*(XMAP(I,4)-XMAP(I,2))- - (ZMAP(I,4)-ZMAP(I,2))*(XMAP(I,3)-XMAP(I,2)))+ - (Z-ZMAP(I,2))*( - (XMAP(I,3)-XMAP(I,2))*(YMAP(I,4)-YMAP(I,2))- - (XMAP(I,4)-XMAP(I,2))*(YMAP(I,3)-YMAP(I,2))) TT2=(X-XMAP(I,3))*( - (YMAP(I,1)-YMAP(I,3))*(ZMAP(I,4)-ZMAP(I,3))- - (YMAP(I,4)-YMAP(I,3))*(ZMAP(I,1)-ZMAP(I,3)))+ - (Y-YMAP(I,3))*( - (ZMAP(I,1)-ZMAP(I,3))*(XMAP(I,4)-XMAP(I,3))- - (ZMAP(I,4)-ZMAP(I,3))*(XMAP(I,1)-XMAP(I,3)))+ - (Z-ZMAP(I,3))*( - (XMAP(I,1)-XMAP(I,3))*(YMAP(I,4)-YMAP(I,3))- - (XMAP(I,4)-XMAP(I,3))*(YMAP(I,1)-YMAP(I,3))) TT3=(X-XMAP(I,4))*( - (YMAP(I,1)-YMAP(I,4))*(ZMAP(I,2)-ZMAP(I,4))- - (YMAP(I,2)-YMAP(I,4))*(ZMAP(I,1)-ZMAP(I,4)))+ - (Y-YMAP(I,4))*( - (ZMAP(I,1)-ZMAP(I,4))*(XMAP(I,2)-XMAP(I,4))- - (ZMAP(I,2)-ZMAP(I,4))*(XMAP(I,1)-XMAP(I,4)))+ - (Z-ZMAP(I,4))*( - (XMAP(I,1)-XMAP(I,4))*(YMAP(I,2)-YMAP(I,4))- - (XMAP(I,2)-XMAP(I,4))*(YMAP(I,1)-YMAP(I,4))) TT4=(X-XMAP(I,1))*( - (YMAP(I,3)-YMAP(I,1))*(ZMAP(I,2)-ZMAP(I,1))- - (YMAP(I,2)-YMAP(I,1))*(ZMAP(I,3)-ZMAP(I,1)))+ - (Y-YMAP(I,1))*( - (ZMAP(I,3)-ZMAP(I,1))*(XMAP(I,2)-XMAP(I,1))- - (ZMAP(I,2)-ZMAP(I,1))*(XMAP(I,3)-XMAP(I,1)))+ - (Z-ZMAP(I,1))*( - (XMAP(I,3)-XMAP(I,1))*(YMAP(I,2)-YMAP(I,1))- - (XMAP(I,2)-XMAP(I,1))*(YMAP(I,3)-YMAP(I,1))) IF((TT1.GE.0.AND.TT2.GE.0.AND.TT3.GE.0.AND.TT4.GE.0).OR. - (TT1.LE.0.AND.TT2.LE.0.AND.TT3.LE.0.AND.TT4.LE.0))THEN T1=TT1/((XMAP(I,1)-XMAP(I,2))*( - (YMAP(I,3)-YMAP(I,2))*(ZMAP(I,4)-ZMAP(I,2))- - (YMAP(I,4)-YMAP(I,2))*(ZMAP(I,3)-ZMAP(I,2)))+ - (YMAP(I,1)-YMAP(I,2))*( - (ZMAP(I,3)-ZMAP(I,2))*(XMAP(I,4)-XMAP(I,2))- - (ZMAP(I,4)-ZMAP(I,2))*(XMAP(I,3)-XMAP(I,2)))+ - (ZMAP(I,1)-ZMAP(I,2))*( - (XMAP(I,3)-XMAP(I,2))*(YMAP(I,4)-YMAP(I,2))- - (XMAP(I,4)-XMAP(I,2))*(YMAP(I,3)-YMAP(I,2)))) T2=TT2/((XMAP(I,2)-XMAP(I,3))*( - (YMAP(I,1)-YMAP(I,3))*(ZMAP(I,4)-ZMAP(I,3))- - (YMAP(I,4)-YMAP(I,3))*(ZMAP(I,1)-ZMAP(I,3)))+ - (YMAP(I,2)-YMAP(I,3))*( - (ZMAP(I,1)-ZMAP(I,3))*(XMAP(I,4)-XMAP(I,3))- - (ZMAP(I,4)-ZMAP(I,3))*(XMAP(I,1)-XMAP(I,3)))+ - (ZMAP(I,2)-ZMAP(I,3))*( - (XMAP(I,1)-XMAP(I,3))*(YMAP(I,4)-YMAP(I,3))- - (XMAP(I,4)-XMAP(I,3))*(YMAP(I,1)-YMAP(I,3)))) T3=TT3/((XMAP(I,3)-XMAP(I,4))*( - (YMAP(I,1)-YMAP(I,4))*(ZMAP(I,2)-ZMAP(I,4))- - (YMAP(I,2)-YMAP(I,4))*(ZMAP(I,1)-ZMAP(I,4)))+ - (YMAP(I,3)-YMAP(I,4))*( - (ZMAP(I,1)-ZMAP(I,4))*(XMAP(I,2)-XMAP(I,4))- - (ZMAP(I,2)-ZMAP(I,4))*(XMAP(I,1)-XMAP(I,4)))+ - (ZMAP(I,3)-ZMAP(I,4))*( - (XMAP(I,1)-XMAP(I,4))*(YMAP(I,2)-YMAP(I,4))- - (XMAP(I,2)-XMAP(I,4))*(YMAP(I,1)-YMAP(I,4)))) T4=TT4/((XMAP(I,4)-XMAP(I,1))*( - (YMAP(I,3)-YMAP(I,1))*(ZMAP(I,2)-ZMAP(I,1))- - (YMAP(I,2)-YMAP(I,1))*(ZMAP(I,3)-ZMAP(I,1)))+ - (YMAP(I,4)-YMAP(I,1))*( - (ZMAP(I,3)-ZMAP(I,1))*(XMAP(I,2)-XMAP(I,1))- - (ZMAP(I,2)-ZMAP(I,1))*(XMAP(I,3)-XMAP(I,1)))+ - (ZMAP(I,4)-ZMAP(I,1))*( - (XMAP(I,3)-XMAP(I,1))*(YMAP(I,2)-YMAP(I,1))- - (XMAP(I,2)-XMAP(I,1))*(YMAP(I,3)-YMAP(I,1)))) IMAP=I IL=I NFOUND=NFOUND+1 IF(NFOUND.LE.MXFOUN)IFOUND(NFOUND)=IMAP IF(.NOT.LMAPCH)RETURN ENDIF 10 CONTINUE * Triangles. ELSEIF(MAPTYP.EQ.1.OR.MAPTYP.EQ.2.OR.MAPTYP.EQ.3)THEN DO 20 I=1,NMAP IF(X.LT.MIN(XMAP(I,1),XMAP(I,2),XMAP(I,3)).OR. - X.GT.MAX(XMAP(I,1),XMAP(I,2),XMAP(I,3)).OR. - Y.LT.MIN(YMAP(I,1),YMAP(I,2),YMAP(I,3)).OR. - Y.GT.MAX(YMAP(I,1),YMAP(I,2),YMAP(I,3)))GOTO 20 TT1=(X-XMAP(I,2))*(YMAP(I,3)-YMAP(I,2))- - (Y-YMAP(I,2))*(XMAP(I,3)-XMAP(I,2)) TT2=(X-XMAP(I,3))*(YMAP(I,1)-YMAP(I,3))- - (Y-YMAP(I,3))*(XMAP(I,1)-XMAP(I,3)) TT3=(X-XMAP(I,1))*(YMAP(I,2)-YMAP(I,1))- - (Y-YMAP(I,1))*(XMAP(I,2)-XMAP(I,1)) IF((TT1.GE.0.AND.TT2.GE.0.AND.TT3.GE.0).OR. - (TT1.LE.0.AND.TT2.LE.0.AND.TT3.LE.0))THEN T1=TT1/((XMAP(I,1)-XMAP(I,2))*(YMAP(I,3)-YMAP(I,2))- - (XMAP(I,3)-XMAP(I,2))*(YMAP(I,1)-YMAP(I,2))) T2=TT2/((XMAP(I,2)-XMAP(I,3))*(YMAP(I,1)-YMAP(I,3))- - (XMAP(I,1)-XMAP(I,3))*(YMAP(I,2)-YMAP(I,3))) T3=TT3/((XMAP(I,3)-XMAP(I,1))*(YMAP(I,2)-YMAP(I,1))- - (XMAP(I,2)-XMAP(I,1))*(YMAP(I,3)-YMAP(I,1))) T4=0 IMAP=I IL=I NFOUND=NFOUND+1 IF(NFOUND.LE.MXFOUN)IFOUND(NFOUND)=IMAP IF(.NOT.LMAPCH)RETURN ENDIF 20 CONTINUE * Regular hexahedrons. ELSEIF(MAPTYP.EQ.14.OR.MAPTYP.EQ.15.OR.MAPTYP.EQ.16)THEN DO 30 I=1,NMAP IF(X.LT.MIN(XMAP(I,1),XMAP(I,2),XMAP(I,3),XMAP(I,4)).OR. - X.GT.MAX(XMAP(I,1),XMAP(I,2),XMAP(I,3),XMAP(I,4)).OR. - Y.LT.MIN(YMAP(I,1),YMAP(I,2),YMAP(I,3),YMAP(I,4)).OR. - Y.GT.MAX(YMAP(I,1),YMAP(I,2),YMAP(I,3),YMAP(I,4)).OR. - Z.LT.MIN(ZMAP(I,1),ZMAP(I,2),ZMAP(I,3),ZMAP(I,4)).OR. - Z.GT.MAX(ZMAP(I,1),ZMAP(I,2),ZMAP(I,3),ZMAP(I,4))) - GOTO 30 PAR(1,1)=(XMAP(I,2)-XMAP(I,1))**2+ - (YMAP(I,2)-YMAP(I,1))**2+(ZMAP(I,2)-ZMAP(I,1))**2 PAR(2,2)=(XMAP(I,3)-XMAP(I,1))**2+ - (YMAP(I,3)-YMAP(I,1))**2+(ZMAP(I,3)-ZMAP(I,1))**2 PAR(3,3)=(XMAP(I,4)-XMAP(I,1))**2+ - (YMAP(I,4)-YMAP(I,1))**2+(ZMAP(I,4)-ZMAP(I,1))**2 PAR(1,2)= - (XMAP(I,2)-XMAP(I,1))*(XMAP(I,3)-XMAP(I,1))+ - (YMAP(I,2)-YMAP(I,1))*(YMAP(I,3)-YMAP(I,1))+ - (ZMAP(I,2)-ZMAP(I,1))*(ZMAP(I,3)-ZMAP(I,1)) PAR(2,1)=PAR(1,2) PAR(1,3)= - (XMAP(I,2)-XMAP(I,1))*(XMAP(I,4)-XMAP(I,1))+ - (YMAP(I,2)-YMAP(I,1))*(YMAP(I,4)-YMAP(I,1))+ - (ZMAP(I,2)-ZMAP(I,1))*(ZMAP(I,4)-ZMAP(I,1)) PAR(3,1)=PAR(1,3) PAR(2,3)= - (XMAP(I,3)-XMAP(I,1))*(XMAP(I,4)-XMAP(I,1))+ - (YMAP(I,3)-YMAP(I,1))*(YMAP(I,4)-YMAP(I,1))+ - (ZMAP(I,3)-ZMAP(I,1))*(ZMAP(I,4)-ZMAP(I,1)) PAR(2,3)=PAR(3,2) VEC(1)=(X-XMAP(I,1))*(XMAP(I,2)-XMAP(I,1))+ - (Y-YMAP(I,1))*(YMAP(I,2)-YMAP(I,1))+ - (Z-ZMAP(I,1))*(ZMAP(I,2)-ZMAP(I,1)) VEC(2)=(X-XMAP(I,1))*(XMAP(I,3)-XMAP(I,1))+ - (Y-YMAP(I,1))*(YMAP(I,3)-YMAP(I,1))+ - (Z-ZMAP(I,1))*(ZMAP(I,3)-ZMAP(I,1)) VEC(3)=(X-XMAP(I,1))*(XMAP(I,4)-XMAP(I,1))+ - (Y-YMAP(I,1))*(YMAP(I,4)-YMAP(I,1))+ - (Z-ZMAP(I,1))*(ZMAP(I,4)-ZMAP(I,1)) CALL REQN(3,PAR,3,RAUX,IFAIL,1,VEC) IF(IFAIL.NE.0)THEN IMAP=0 RETURN ENDIF IF(VEC(1).GE.0.AND.VEC(1).LE.1.AND. - VEC(2).GE.0.AND.VEC(2).LE.1.AND. - VEC(3).GE.0.AND.VEC(3).LE.1)THEN T1=VEC(1) T2=VEC(2) T3=VEC(3) T4=0 IMAP=I IL=I NFOUND=NFOUND+1 IF(NFOUND.LE.MXFOUN)IFOUND(NFOUND)=IMAP IF(.NOT.LMAPCH)RETURN ENDIF 30 CONTINUE ELSE PRINT *,' !!!!!! MAPIND WARNING : Unknown element type ', - MAPTYP,' no map index returned.' IMAP=-1 T1=-1 T2=-1 T3=-1 T4=-1 RETURN ENDIF *** In checking mode, verify the tetrahedron/triangle count. IF(LMAPCH)THEN IF(NFOUND.LE.0)THEN IMAP=0 IL=0 ELSEIF(NFOUND.GT.1)THEN PRINT *,' ------ MAPIND MESSAGE : Found ',NFOUND, - ' elements for point ',X,Y,Z DO 40 I=1,MIN(NFOUND,MXFOUN) IF(MAPTYP.EQ.11.OR.MAPTYP.EQ.12.OR.MAPTYP.EQ.13)THEN WRITE(LUNOUT,'('' Tetrahedron '',I2, - '', index '',I5,'':''/ - '' (x1,y1,z1)='',3(E15.8,2X)/ - '' (x2,y2,z2)='',3(E15.8,2X)/ - '' (x3,y3,z3)='',3(E15.8,2X)/ - '' (x4,y4,z4)='',3(E15.8,2X))') - I,IFOUND(I), - XMAP(IFOUND(I),1),YMAP(IFOUND(I),1), - ZMAP(IFOUND(I),1), - XMAP(IFOUND(I),2),YMAP(IFOUND(I),2), - ZMAP(IFOUND(I),2), - XMAP(IFOUND(I),3),YMAP(IFOUND(I),3), - ZMAP(IFOUND(I),3), - XMAP(IFOUND(I),4),YMAP(IFOUND(I),4), - ZMAP(IFOUND(I),4) ELSEIF(MAPTYP.EQ.1.OR.MAPTYP.EQ.2.OR.MAPTYP.EQ.3)THEN WRITE(LUNOUT,'('' Triangle '',I2, - '', index '',I5,'':''/ - '' (x1,y1)='',2(E15.8,2X)/ - '' (x2,y2)='',2(E15.8,2X)/ - '' (x3,y3)='',2(E15.8,2X))') - I,IFOUND(I), - XMAP(IFOUND(I),1),YMAP(IFOUND(I),1), - XMAP(IFOUND(I),2),YMAP(IFOUND(I),2), - XMAP(IFOUND(I),3),YMAP(IFOUND(I),3) ELSEIF(MAPTYP.EQ.14.OR.MAPTYP.EQ.15.OR. - MAPTYP.EQ.16)THEN WRITE(LUNOUT,'('' Hexahedron '',I2, - '', index '',I5,'':''/ - '' (x1,y1,z1)='',3(E15.8,2X)/ - '' (x2,y2,z2)='',3(E15.8,2X)/ - '' (x3,y3,z3)='',3(E15.8,2X)/ - '' (x4,y4,z4)='',3(E15.8,2X))') - I,IFOUND(I), - XMAP(IFOUND(I),1),YMAP(IFOUND(I),1), - ZMAP(IFOUND(I),1), - XMAP(IFOUND(I),2),YMAP(IFOUND(I),2), - ZMAP(IFOUND(I),2), - XMAP(IFOUND(I),3),YMAP(IFOUND(I),3), - ZMAP(IFOUND(I),3), - XMAP(IFOUND(I),4),YMAP(IFOUND(I),4), - ZMAP(IFOUND(I),4) ENDIF 40 CONTINUE ENDIF IF((MAPTYP.EQ.1.OR.MAPTYP.EQ.2.OR.MAPTYP.EQ.3.OR. - MAPTYP.EQ.11.OR.MAPTYP.EQ.12.OR.MAPTYP.EQ.13).AND. - NFOUND.GE.1.AND.ABS(T1+T2+T3+T4-1).GT.1E-3)THEN PRINT *,' !!!!!! MAPIND WARNING : Triangular'// - ' coordinates do not add up to 1.' PRINT *,' T1=',T1,', T2=',T2,', T3=',T3,', T4=',T4 PRINT *,' X= ',X ,', Y= ',Y ,', Z= ',Z ENDIF *** No volume found. ELSE IMAP=0 IL=0 ENDIF RETURN *** Reset of volume. ENTRY MAPINR IL=0 END +DECK,MAPINT. SUBROUTINE MAPINT *----------------------------------------------------------------------- * MAPINT - Initialises the field map. * (Last changed on 29/11/99.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,FIELDMAP. INTEGER I,IFAIL,INIT +SELF,IF=SAVE. SAVE INIT +SELF. *** Set the number of triangles to 0. NMAP=0 *** Set the availability flags to "not available". DO 10 I=1,10+3*MXWMAP MAPFLG(I)=.FALSE. 10 CONTINUE *** Reset the list of materials, number of different media. NEPS=0 * Set all epsilons to -1 (i.e. unknown). DO 20 I=1,MXEPS EPSMAT(I)=-1 20 CONTINUE * Set drift medium to unknown. IDRMAT=-1 * Set the material source to unknown. MATSRC='?' *** Reset the material indices. DO 30 I=1,MXMAP MATMAP(I)=-1 30 CONTINUE *** Preset the ranges. XMMIN=0 XMMAX=0 YMMIN=0 YMMAX=0 ZMMIN=0 ZMMAX=0 XAMIN=0 XAMAX=0 YAMIN=0 YAMAX=0 ZAMIN=0 ZAMAX=0 SETAX=.FALSE. SETAY=.FALSE. SETAZ=.FALSE. VMMIN=0 VMMAX=0 *** Field map interpolation order. MAPORD=1 *** Volume element type. MAPTYP=0 *** Reset interpolation. CALL MAPINR *** Plot the material map in principle. LMAPPL=.TRUE. *** Reset the number of weighting fields to 0 ... NWMAP=0 * and reset the weighting field association string. DO 40 I=1,MXWMAP EWSTYP(I)='?' 40 CONTINUE *** Generate a booking entry on first call. DATA INIT/0/ IF(INIT.EQ.0)THEN CALL BOOK('INITIALISE','MAP',' ',IFAIL) IF(IFAIL.NE.0)PRINT *,' !!!!!! MAPINT WARNING : Unable'// - ' to allocate a booking entry for the field map;'// - ' field maps can not be used.' INIT=1 ENDIF END +DECK,MAPREA. SUBROUTINE MAPREA(IFAIL) *----------------------------------------------------------------------- * MAPREA - Reads an interpolation table. * (Last changed on 29/11/99.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. +SEQ,FIELDMAP. +SEQ,CELLDATA. +SEQ,BFIELD. +SEQ,GASDATA. +SEQ,CONSTANTS. INTEGER IFAIL,IFAIL1,IFAIL2,IFAIL3,IFAIL4,IFAIL5,IFAIL6,I,J,K,K0, - NWORD,INEXT,INPCMP,NCMAP,IFORM,IFILE(MXWORD),NFILE, - ISEL,INPTYP,IDATA(MXWORD),IWMAP(MXWORD),MAPMAX,MAPMXR,IORD, - NCAUX,IMESH REAL EPSSEL,ZMMINR,ZMMAXR,WXMIN,WYMIN,WZMIN,WXMAX,WYMAX, - WZMAX,AUX CHARACTER*(MXNAME) FMAP CHARACTER*20 AUXSTR LOGICAL OK,FLAG(MXWORD+2),WINDOW,NEWDRM,OLDFL9,LHISMP,DELBKG EXTERNAL INPCMP,INPTYP *** Inform that the routine has been called. IF(LIDENT)PRINT *,' /// ROUTINE MAPREA ///' *** Preset error flag. IFAIL=1 *** Count words. CALL INPNUM(NWORD) *** Without arguments, print current field map status. IF(NWORD.LE.1)THEN CALL MAPPRT IFAIL=0 RETURN ENDIF *** Preset all other parameters. NCMAP=0 NFILE=0 ISEL=0 EPSSEL=-1 NEWDRM=.FALSE. IMESH=0 ZMMIN=-50 ZMMAX=+50 WXMIN=-1 WXMAX=+1 WYMIN=-1 WYMAX=+1 WZMIN=-1 WZMAX=+1 WINDOW=.FALSE. DELBKG=.TRUE. IORD=0 PERX=.FALSE. PERY=.FALSE. PERZ=.FALSE. PERMX=.FALSE. PERMY=.FALSE. PERMZ=.FALSE. PERAX=.FALSE. PERAY=.FALSE. PERAZ=.FALSE. SETAX=.FALSE. SETAY=.FALSE. SETAZ=.FALSE. PERRX=.FALSE. PERRY=.FALSE. PERRZ=.FALSE. LHISMP=.FALSE. IFORM=0 *** Prepare for progress printing. CALL PROINT('FIELD-MAP',1,6) CALL PROFLD(1,'Reading command',-1.0) CALL PROSTA(1,0.0) *** Scan for known keywords. DO 10 I=1,MXWORD+2 FLAG(I)=.FALSE. IF(INPCMP(I,'FILE#S')+INPCMP(I,'RES#ET')+INPCMP(I,'Z-RAN#GE')+ - INPCMP(I,'DR#IFT-#MEDIUM')+INPCMP(I,'WIN#DOW')+ - INPCMP(I,'DEL#ETE-BACK#GROUND')+ - INPCMP(I,'KEEP-BACK#GROUND')+ - INPCMP(I,'X-PER#IODIC')+INPCMP(I,'X-MIR#ROR-PER#IODIC')+ - INPCMP(I,'Y-PER#IODIC')+INPCMP(I,'Y-MIR#ROR-PER#IODIC')+ - INPCMP(I,'Z-PER#IODIC')+INPCMP(I,'Z-MIR#ROR-PER#IODIC')+ - INPCMP(I,'X-AX#IALLY-PER#IODIC')+ - INPCMP(I,'Y-AX#IALLY-PER#IODIC')+ - INPCMP(I,'Z-AX#IALLY-PER#IODIC')+ - INPCMP(I,'NOT-X-PER#IODIC')+INPCMP(I,'NOT-Y-PER#IODIC')+ - INPCMP(I,'NOT-Z-PER#IODIC')+ - INPCMP(I,'NOPL#OT-MAP')+INPCMP(I,'PL#OT-MAP')+ - INPCMP(I,'NOHIST#OGRAM-#MAP')+INPCMP(I,'HIST#OGRAM-#MAP')+ - INPCMP(I,'LIN#EAR-#INTERPOLATION')+ - INPCMP(I,'QUA#DRATIC-#INTERPOLATION')+ - INPCMP(I,'CUB#IC-#INTERPOLATION')+ - INPCMP(I,'MAX#WELL-PAR#AMETER-EX#TRACTOR-2D')+ - INPCMP(I,'PAR#AMETER-EX#TRACTOR-2D')+ - INPCMP(I,'MAX#WELL-PAR#AMETER-EX#TRACTOR-3D')+ - INPCMP(I,'PAR#AMETER-EX#TRACTOR-3D')+ - INPCMP(I,'MAX#WELL-F#IELD-SIM#ULATOR-#3D')+ - INPCMP(I,'F#IELD-SIM#ULATOR-#3D')+ - INPCMP(I,'TOSCA').GT.0.OR.I.GT.NWORD) - FLAG(I)=.TRUE. 10 CONTINUE *** Read the arguments, INEXT=2 OK=.TRUE. DO 20 I=2,NWORD IF(I.LT.INEXT)GOTO 20 ** File name. IF(INPCMP(I,'FILE#S').NE.0)THEN * Ensure that at least 1 is present. IF(I+1.GT.NWORD.OR.FLAG(I+1))THEN CALL INPMSG(I,'Should have an argument.') OK=.FALSE. ELSE * Reset number of weighting fields. NWMAP=0 * Loop over the candidate names. DO 30 J=I+1,NWORD IF(J.LT.INEXT)GOTO 30 * Skip remainder if a keyword. IF(FLAG(J))THEN INEXT=J GOTO 40 * Store the file name with contents and format. ELSE * See whether this can be stored at all. IF(NFILE.GE.MXWORD)THEN CALL INPMSG(J,'Unable to store name.') INEXT=J+1 GOTO 40 ENDIF NFILE=NFILE+1 * Will usually not be a weighting field. IWMAP(NFILE)=0 * Look for contents. IF(INPCMP(J,'MESH').NE.0)THEN IDATA(NFILE)=1 INEXT=J+1 IMESH=NFILE ELSEIF(INPCMP(J,'POT#ENTIAL')+ - INPCMP(J,'VOLT#AGE').NE.0)THEN IDATA(NFILE)=5 INEXT=J+1 ELSEIF(INPCMP(J,'MAT#ERIAL')+ - INPCMP(J,'D-#FIELD').NE.0)THEN IDATA(NFILE)=9 INEXT=J+1 ELSEIF(INPCMP(J,'E#LECTRIC-#FIELD').NE.0)THEN IDATA(NFILE)=2 INEXT=J+1 ELSEIF(INPCMP(J,'B-#FIELD')+ - INPCMP(J,'MAG#NETIC-#FIELD').NE.0)THEN IDATA(NFILE)=6 INEXT=J+1 ELSEIF(INPCMP(J,'W#EIGHTING-#FIELD').NE.0)THEN IF(NWMAP+1.LE.MXWMAP)THEN NWMAP=NWMAP+1 IWMAP(NFILE)=NWMAP IDATA(NFILE)=10 INEXT=J+1 ELSE CALL INPMSG(J, - 'Too many weighting fields.') INEXT=J+1 NFILE=NFILE-1 GOTO 40 ENDIF ELSE IDATA(NFILE)=0 INEXT=J ENDIF * Pick up the file name. IF(FLAG(INEXT).OR.INEXT.GT.NWORD)THEN CALL INPMSG(J,'File name is missing.') INEXT=J+1 GOTO 40 ENDIF CALL INPSTR(INEXT,INEXT,FMAP,NCMAP) CALL STRBUF('STORE',IFILE(NFILE), - FMAP,NCMAP,IFAIL1) IF(IFAIL1.NE.0)THEN CALL INPMSG(INEXT,'String buffer error.') IFILE(NFILE)=0 ENDIF INEXT=INEXT+1 * See whether there is a format etc. K0=INEXT IF(IDATA(NFILE).EQ.10)EWSTYP(IWMAP(NFILE))='?' DO 60 K=K0,NWORD IF(K.LT.INEXT)THEN GOTO 60 ELSEIF(FLAG(K))THEN INEXT=K GOTO 40 ELSEIF(INPCMP(K,'SOL#IDS')+ - INPCMP(K,'LAB#EL').NE.0)THEN IF(FLAG(K+1).OR.K+1.GT.NWORD)THEN CALL INPMSG(K,'Solid label missing.') OK=.FALSE. ELSEIF(IDATA(NFILE).NE.10)THEN CALL INPMSG(K,'Only applicable to Ew.') ELSE CALL INPSTR(K+1,K+1,AUXSTR,NCAUX) IF(INDEX('ABCDEFGHIJKLMNOPQRSTUVWXYZ', - AUXSTR(1:1)).EQ.0.OR.NCAUX.LE. - 0)THEN CALL INPMSG(K+1, - 'The label must be a letter.') OK=.FALSE. ELSE EWSTYP(IWMAP(NFILE))=AUXSTR(1:1) ENDIF ENDIF INEXT=K+2 ELSE INEXT=K GOTO 30 ENDIF 60 CONTINUE ENDIF * Next file. 30 CONTINUE INEXT=NWORD+1 * Leave file loop. 40 CONTINUE ENDIF ** Field map format. ELSEIF(INPCMP(I,'MAX#WELL-PAR#AMETER-EX#TRACTOR-2D')+ - INPCMP(I,'PAR#AMETER-EX#TRACTOR-2D').NE.0)THEN IFORM=1 ELSEIF(INPCMP(I,'MAX#WELL-PAR#AMETER-EX#TRACTOR-3D')+ - INPCMP(I,'PAR#AMETER-EX#TRACTOR-3D').NE.0)THEN IFORM=2 ELSEIF(INPCMP(I,'MAX#WELL-F#IELD-SIM#ULATOR-#3D')+ - INPCMP(I,'F#IELD-SIM#ULATOR-#3D').NE.0)THEN IFORM=4 ELSEIF(INPCMP(I,'TOSCA').NE.0)THEN IFORM=5 ** Select a drift medium. ELSEIF(INPCMP(I,'DR#IFT-#MEDIUM').NE.0)THEN IF(FLAG(I+1).OR.I+1.GT.NWORD)THEN CALL INPMSG(I,'Should have an argument') OK=.FALSE. ELSEIF(INPTYP(I+1).EQ.1)THEN CALL INPCHK(I+1,1,IFAIL1) CALL INPRDI(I+1,ISEL,0) IF(ISEL.NE.0)THEN NEWDRM=.TRUE. EPSSEL=-1 ELSE CALL INPMSG(I+1,'Must be non-zero.') OK=.FALSE. ENDIF INEXT=I+2 ELSEIF(INPTYP(I+1).EQ.2)THEN CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,EPSSEL,-1.0) IF(EPSSEL.GT.0)THEN NEWDRM=.TRUE. ISEL=0 ELSE CALL INPMSG(I+1,'Must be > 0.') OK=.FALSE. ENDIF INEXT=I+2 ELSEIF(INPCMP(I+1,'SMALL#EST-#EPSILON')+ - INPCMP(I+1,'LOW#EST-#EPSILON')+ - INPCMP(I+1,'SMALL#EST-#SIGMA')+ - INPCMP(I+1,'LOW#EST-#SIGMA').NE.0)THEN NEWDRM=.TRUE. ISEL=1 EPSSEL=-1 INEXT=I+2 ELSEIF(INPCMP(I+1,'SEC#OND-SM#ALLEST-#EPSILON')+ - INPCMP(I+1,'ONE-BUT-SM#ALLEST-#EPSILON')+ - INPCMP(I+1,'SEC#OND-LOW#EST-#EPSILON')+ - INPCMP(I+1,'ONE-BUT-LOW#EST-#EPSILON')+ - INPCMP(I+1,'SEC#OND-SM#ALLEST-#SIGMA')+ - INPCMP(I+1,'ONE-BUT-SM#ALLEST-#SIGMA')+ - INPCMP(I+1,'SEC#OND-LOW#EST-#SIGMA')+ - INPCMP(I+1,'ONE-BUT-LOW#EST-#SIGMA').NE.0)THEN NEWDRM=.TRUE. ISEL=2 EPSSEL=-1 INEXT=I+2 ELSEIF(INPCMP(I+1,'LARG#EST-#EPSILON')+ - INPCMP(I+1,'BIG#GEST-#EPSILON')+ - INPCMP(I+1,'LARG#EST-#SIGMA')+ - INPCMP(I+1,'BIG#GEST-#SIGMA').NE.0)THEN NEWDRM=.TRUE. ISEL=-1 EPSSEL=-1 INEXT=I+2 ELSEIF(INPCMP(I+1,'SEC#OND-LARG#EST-#EPSILON')+ - INPCMP(I+1,'SEC#OND-BIG#GEST-#EPSILON')+ - INPCMP(I+1,'ONE-BUT-LARG#EST-#EPSILON')+ - INPCMP(I+1,'ONE-BUT-BIG#GEST-#EPSILON')+ - INPCMP(I+1,'SEC#OND-LARG#EST-#SIGMA')+ - INPCMP(I+1,'SEC#OND-BIG#GEST-#SIGMA')+ - INPCMP(I+1,'ONE-BUT-LARG#EST-#SIGMA')+ - INPCMP(I+1,'ONE-BUT-BIG#GEST-#SIGMA').NE.0)THEN NEWDRM=.TRUE. ISEL=-2 EPSSEL=-1 INEXT=I+2 ELSE CALL INPMSG(I+1,'Not a known keyword.') OK=.FALSE. INEXT=I+2 ENDIF ** Reset of the field maps. ELSEIF(INPCMP(I,'RES#ET').NE.0)THEN CALL MAPINT NEWDRM=.FALSE. ** Periodicities. ELSEIF(INPCMP(I,'NOT-X-PER#IODIC').NE.0)THEN PERX=.FALSE. PERAX=.FALSE. PERMX=.FALSE. PERRX=.FALSE. ELSEIF(INPCMP(I,'NOT-Y-PER#IODIC').NE.0)THEN PERY=.FALSE. PERAY=.FALSE. PERMY=.FALSE. PERRY=.FALSE. ELSEIF(INPCMP(I,'NOT-Z-PER#IODIC').NE.0)THEN PERZ=.FALSE. PERAZ=.FALSE. PERMZ=.FALSE. PERRZ=.FALSE. ELSEIF(INPCMP(I,'X-PER#IODIC').NE.0)THEN PERX=.TRUE. PERMX=.FALSE. ELSEIF(INPCMP(I,'Y-PER#IODIC').NE.0)THEN PERY=.TRUE. PERMY=.FALSE. ELSEIF(INPCMP(I,'Z-PER#IODIC').NE.0)THEN PERZ=.TRUE. PERMZ=.FALSE. ELSEIF(INPCMP(I,'X-MIR#ROR-PER#IODIC').NE.0)THEN PERMX=.TRUE. PERX=.FALSE. ELSEIF(INPCMP(I,'Y-MIR#ROR-PER#IODIC').NE.0)THEN PERMY=.TRUE. PERY=.FALSE. ELSEIF(INPCMP(I,'Z-MIR#ROR-PER#IODIC').NE.0)THEN PERMZ=.TRUE. PERZ=.FALSE. ELSEIF(INPCMP(I,'X-AX#IALLY-PER#IODIC').NE.0)THEN PERAX=.TRUE. ELSEIF(INPCMP(I,'Y-AX#IALLY-PER#IODIC').NE.0)THEN PERAY=.TRUE. ELSEIF(INPCMP(I,'Z-AX#IALLY-PER#IODIC').NE.0)THEN PERAZ=.TRUE. ELSEIF(INPCMP(I,'X-ROT#ATIONALLY-SYMM#ETRIC').NE.0)THEN PERRX=.TRUE. ELSEIF(INPCMP(I,'Y-ROT#ATIONALLY-SYMM#ETRIC').NE.0)THEN PERRY=.TRUE. ELSEIF(INPCMP(I,'Z-ROT#ATIONALLY-SYMM#ETRIC').NE.0)THEN PERRZ=.TRUE. ** Plotting options. ELSEIF(INPCMP(I,'PL#OT-MAP').NE.0)THEN LMAPPL=.TRUE. ELSEIF(INPCMP(I,'NOPL#OT-MAP').NE.0)THEN LMAPPL=.FALSE. ELSEIF(INPCMP(I,'HIST#OGRAM-#MAP').NE.0)THEN LHISMP=.TRUE. ELSEIF(INPCMP(I,'NOHIST#OGRAM-#MAP').NE.0)THEN LHISMP=.FALSE. ** Interpolation orders. ELSEIF(INPCMP(I,'LIN#EAR-#INTERPOLATION').NE.0)THEN IORD=1 ELSEIF(INPCMP(I,'QUA#DRATIC-#INTERPOLATION').NE.0)THEN IORD=2 ELSEIF(INPCMP(I,'CUB#IC-#INTERPOLATION').NE.0)THEN IORD=3 ** Specification of a range in z (for 2-dimensional field maps). ELSEIF(INPCMP(I,'Z-RAN#GE').NE.0)THEN IF(I+2.GT.NWORD.OR.FLAG(I+1).OR.FLAG(I+2).OR. - (INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2).OR. - (INPTYP(I+2).NE.1.AND.INPTYP(I+2).NE.2))THEN CALL INPMSG(I,'Should have 2 arguments.') ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPCHK(I+2,2,IFAIL2) CALL INPRDR(I+1,ZMMINR,ZMMIN) CALL INPRDR(I+2,ZMMAXR,ZMMAX) IF(ZMMINR.EQ.ZMMAXR)THEN CALL INPMSG(I+1,'Zero range not permitted.') CALL INPMSG(I+2,'See previous message.') ELSEIF(IFAIL1.EQ.0.AND.IFAIL2.EQ.0)THEN ZMMIN=MIN(ZMMINR,ZMMAXR) ZMMAX=MAX(ZMMINR,ZMMAXR) ENDIF ENDIF INEXT=I+3 ** Background deletion. ELSEIF(INPCMP(I,'DEL#ETE-BACK#GROUND').NE.0)THEN DELBKG=.TRUE. ELSEIF(INPCMP(I,'KEEP-BACK#GROUND').NE.0)THEN DELBKG=.FALSE. ** Window for cutting triangles. ELSEIF(INPCMP(I,'WIN#DOW').NE.0)THEN * Check argument types. IF(I+4.GT.NWORD.OR. - FLAG(I+1).OR.FLAG(I+2).OR.FLAG(I+3).OR.FLAG(I+4).OR. - (INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2).OR. - (INPTYP(I+2).NE.1.AND.INPTYP(I+2).NE.2).OR. - (INPTYP(I+3).NE.1.AND.INPTYP(I+3).NE.2).OR. - (INPTYP(I+4).NE.1.AND.INPTYP(I+4).NE.2))THEN CALL INPMSG(I,'Should have 4 or 6 arguments.') ELSE * 3-dimensional window specification. IF((INPTYP(I+5).EQ.1.OR.INPTYP(I+5).EQ.2).AND. - (INPTYP(I+6).EQ.1.OR.INPTYP(I+6).EQ.2))THEN CALL INPCHK(I+1,2,IFAIL1) CALL INPCHK(I+2,2,IFAIL2) CALL INPCHK(I+3,2,IFAIL3) CALL INPCHK(I+4,2,IFAIL4) CALL INPCHK(I+5,2,IFAIL5) CALL INPCHK(I+6,2,IFAIL6) CALL INPRDR(I+1,WXMIN,-1.0) CALL INPRDR(I+2,WYMIN,-1.0) CALL INPRDR(I+3,WZMIN,-1.0) CALL INPRDR(I+4,WXMAX,+1.0) CALL INPRDR(I+5,WYMAX,+1.0) CALL INPRDR(I+6,WZMAX,+1.0) WZMIN=-1 WZMAX=+1 IF(IFAIL1.EQ.0.AND.IFAIL2.EQ.0.AND. - IFAIL3.EQ.0.AND.IFAIL4.EQ.0.AND. - IFAIL5.EQ.0.AND.IFAIL6.EQ.0.AND. - WXMIN.NE.WXMAX.AND.WYMIN.NE.WYMAX.AND. - WZMIN.NE.WZMAX)THEN WINDOW=.TRUE. ELSE PRINT *,' !!!!!! MAPREA WARNING : Not a'// - ' valid window; ignored.' WINDOW=.FALSE. ENDIF INEXT=I+7 * 2-dimensional window specification. ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPCHK(I+2,2,IFAIL2) CALL INPCHK(I+3,2,IFAIL3) CALL INPCHK(I+4,2,IFAIL4) CALL INPRDR(I+1,WXMIN,-1.0) CALL INPRDR(I+2,WYMIN,-1.0) CALL INPRDR(I+3,WXMAX,+1.0) CALL INPRDR(I+4,WYMAX,+1.0) WZMIN=-1 WZMAX=+1 IF(IFAIL1.EQ.0.AND.IFAIL2.EQ.0.AND. - IFAIL3.EQ.0.AND.IFAIL4.EQ.0.AND. - WXMIN.NE.WXMAX.AND.WYMIN.NE.WYMAX)THEN WINDOW=.TRUE. ELSE PRINT *,' !!!!!! MAPREA WARNING : Not a'// - ' valid window; ignored.' WINDOW=.FALSE. ENDIF INEXT=I+5 ENDIF * Ordering of window limits. IF(WXMIN.GT.WXMAX)THEN AUX=WXMIN WXMIN=WXMAX WXMAX=AUX ENDIF IF(WYMIN.GT.WYMAX)THEN AUX=WYMIN WYMIN=WYMAX WYMAX=AUX ENDIF IF(WZMIN.GT.WZMAX)THEN AUX=WZMIN WZMIN=WZMAX WZMAX=AUX ENDIF ENDIF ** Other options not known. ELSE CALL INPMSG(I,'Not a known option') OK=.FALSE. ENDIF 20 CONTINUE *** Print the error messages. CALL INPERR *** Read the mesh file if there is one. IF(IMESH.GT.0)THEN * Progress print. CALL PROFLD(1,'Mesh',-1.0) CALL PROSTA(1,0.0) * Retrieve mesh file name. CALL STRBUF('READ',IFILE(IMESH),FMAP,NCMAP,IFAIL1) * Ensure that there was no string buffer error. IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! MAPREA WARNING : String buffer'// - ' error retrieving mesh file name.' OK=.FALSE. * Be sure the name is not empty. ELSEIF(NCMAP.LT.1)THEN PRINT *,' !!!!!! MAPREA WARNING : The mesh file has'// - ' a name of length zero; file not read.' OK=.FALSE. ELSE * And read the file. CALL PRORED(2) CALL MAPFMR(FMAP,NCMAP,IFORM,IDATA(IMESH),IWMAP(IMESH), - WXMIN,WYMIN,WZMIN,WXMAX,WYMAX,WZMAX,WINDOW,DELBKG, - MAPMXR,IFAIL1) CALL PRORED(1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! MAPREA WARNING : File '// - FMAP(1:NCMAP)//' could not be read.' OK=.FALSE. ENDIF ENDIF * Delete the string. CALL STRBUF('DELETE',IFILE(IMESH),' ',1,IFAIL1) ENDIF *** Now read the field maps. IF(IMESH.GT.0)THEN CALL PROFLD(1,'Field maps',REAL(NFILE-1)) ELSE CALL PROFLD(1,'Field maps',REAL(NFILE)) ENDIF MAPMAX=0 OLDFL9=MAPFLG(9) DO 50 I=1,NFILE * Progress print. CALL PROSTA(1,REAL(I)) * Skip if this is the mesh file. IF(I.EQ.IMESH)GOTO 50 * Retrieve file name. CALL STRBUF('READ',IFILE(I),FMAP,NCMAP,IFAIL1) * Ensure that there was no string buffer error. IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! MAPREA WARNING : String buffer error', - ' retrieving name of file ',I,' to be read.' OK=.FALSE. * Be sure the name is not empty. ELSEIF(NCMAP.LT.1)THEN PRINT *,' !!!!!! MAPREA WARNING : File ',I,' to be', - ' read has name of length zero; file not read.' OK=.FALSE. ELSE * And read the file. CALL PRORED(2) CALL MAPFMR(FMAP,NCMAP,IFORM,IDATA(I),IWMAP(I), - WXMIN,WYMIN,WZMIN,WXMAX,WYMAX,WZMAX,WINDOW,DELBKG, - MAPMXR,IFAIL1) CALL PRORED(1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! MAPREA WARNING : File '// - FMAP(1:NCMAP)//' could not be read.' OK=.FALSE. ENDIF IF(MAPMAX.EQ.0)THEN MAPMAX=MAPMXR ELSE MAPMAX=MIN(MAPMAX,MAPMXR) ENDIF ENDIF * Delete the string. CALL STRBUF('DELETE',IFILE(I),' ',1,IFAIL1) 50 CONTINUE *** Final progress printing. CALL PROFLD(1,'Post processing',-1.0) CALL PROSTA(1,0.0) *** Establish the final interpolation order. IF(MAPMAX.LE.0)THEN PRINT *,' !!!!!! MAPREA WARNING : Reading routines did'// - ' not return a maximum interpolation order; set to 1.' MAPORD=1 ELSEIF(IORD.EQ.0)THEN MAPORD=MAPMAX ELSEIF(IORD.GT.MAPMAX)THEN OK=.FALSE. PRINT *,' !!!!!! MAPREA WARNING : Requested interpolation'// - ' order exceeds field map granularity; set to maximum.' MAPORD=MAPMAX ELSE MAPORD=IORD ENDIF *** Sort the epsilons if a new epsilon map has been provided. IF(MAPFLG(9).AND..NOT.OLDFL9)CALL MAPEPS(IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! MAPREA WARNING : Sorting the'// - ' material properties failed.' OK=.FALSE. ENDIF *** Figure out which material is drift medium. IF(NEWDRM.AND..NOT.MAPFLG(9))THEN PRINT *,' !!!!!! MAPREA WARNING : Cannot set a drift'// - ' medium since there are no material properties.' OK=.FALSE. IDRMAT=-1 ELSEIF(NEWDRM.OR.(MAPFLG(9).AND..NOT.OLDFL9))THEN IF(NEPS.LT.1)THEN PRINT *,' !!!!!! MAPREA WARNING : No dielectric'// - ' media found; cannot select drift medium.' OK=.FALSE. IDRMAT=-1 ELSEIF(ISEL.GT.NEPS.OR. - (ISEL.LT.0.AND.NEPS+ISEL+1.LE.0).OR. - (ISEL.LT.0.AND.NEPS+ISEL+1.GT.NEPS))THEN PRINT *,' !!!!!! MAPREA WARNING : Selection of'// - ' dielectric constant via invalid sequence'// - ' number; no assignment.' OK=.FALSE. IDRMAT=1 ELSEIF(ISEL.LT.0)THEN IDRMAT=NEPS+ISEL+1 ELSEIF(ISEL.EQ.0.AND.EPSSEL.LT.0)THEN PRINT *,' ------ MAPREA MESSAGE : No drift medium'// - ' has been selected ; choosing' PRINT *,' the one with'// - ' the lowest dielectric constant.' IDRMAT=1 ELSEIF(ISEL.EQ.0)THEN IDRMAT=1 DO 130 I=1,NEPS IF(ABS(EPSSEL-EPSMAT(I)).LT. - ABS(EPSSEL-EPSMAT(IDRMAT)))IDRMAT=I 130 CONTINUE PRINT *,' ------ MAPREA MESSAGE : Dielectric'// - ' constant nearest to ',EPSSEL,' is ', - EPSMAT(IDRMAT) ELSE IDRMAT=ISEL ENDIF IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPREA DEBUG :'', - '' Drift medium index='',I3)') IDRMAT ENDIF *** Verify that there is no x or y axial symmetry in 2D. IF((PERAX.OR.PERAY).AND.MAPTYP.LT.10)THEN PRINT *,' !!!!!! MAPREA WARNING : Axial symmetry has been'// - ' requested around x or y for a 2D map; reset.' PERAX=.FALSE. PERAY=.FALSE. OK=.FALSE. ENDIF *** For rotational symmetries, ensure that the fields are present. IF((PERRX.AND.(PERRY.OR.PERRZ)).OR. - (PERRY.AND.(PERRX.OR.PERRZ)).OR. - (PERRZ.AND.(PERRX.OR.PERRY)))THEN PRINT *,' !!!!!! MAPREA WARNING : More than one'// - ' rotational symmetry; reset.' PERRX=.FALSE. PERRY=.FALSE. PERRZ=.FALSE. OK=.FALSE. ELSEIF((PERRX.OR.PERRY.OR.PERRZ).AND.MAPTYP.GE.11)THEN PRINT *,' !!!!!! MAPREA WARNING : Rotational symmetry'// - ' declared for a 3D field map; reset.' PERRX=.FALSE. PERRY=.FALSE. PERRZ=.FALSE. OK=.FALSE. ELSEIF((PERRX.AND.(MAPFLG(3).OR.MAPFLG(7))).OR. - (PERRY.AND.(MAPFLG(4).OR.MAPFLG(8))).OR. - (PERRZ.AND.(MAPFLG(3).OR.MAPFLG(7))))THEN PRINT *,' !!!!!! MAPREA WARNING : Rotational symmetry'// - ' for the axis perpendicular to the map; reset.' PERRX=.FALSE. PERRY=.FALSE. PERRZ=.FALSE. OK=.FALSE. ENDIF *** Verify the ranges for axial symmetry have been set. IF(PERAX.AND.((.NOT.SETAX).OR. - ABS(MOD(XAMAX-XAMIN,2*PI)).LT.0.01))THEN PRINT *,' !!!!!! MAPREA WARNING : Axial symmetry around x'// - ' requested but range could not be set; reset.' PERAX=.FALSE. OK=.FALSE. ENDIF IF(PERAY.AND.((.NOT.SETAY).OR. - ABS(MOD(YAMAX-YAMIN,2*PI)).LT.0.01))THEN PRINT *,' !!!!!! MAPREA WARNING : Axial symmetry around y'// - ' requested but range could not be set; reset.' PERAY=.FALSE. OK=.FALSE. ENDIF IF(PERAZ.AND.((.NOT.SETAZ).OR. - ABS(MOD(ZAMAX-ZAMIN,2*PI)).LT.0.01))THEN PRINT *,' !!!!!! MAPREA WARNING : Axial symmetry around z'// - ' requested but range could not be set; reset.' PERAZ=.FALSE. OK=.FALSE. ENDIF *** Correct the axial range if needed. IF(PERAX.AND.XAMAX-XAMIN.GT.PI)THEN AUX=XAMIN XAMIN=XAMAX XAMAX=AUX+2*PI ENDIF IF(PERAY.AND.YAMAX-YAMIN.GT.PI)THEN AUX=YAMIN YAMIN=YAMAX YAMAX=AUX+2*PI ENDIF IF(PERAZ.AND.ZAMAX-ZAMIN.GT.PI)THEN AUX=ZAMIN ZAMIN=ZAMAX ZAMAX=AUX+2*PI ENDIF *** Verify that the range is a integral fraction of 2 pi. IF(PERAX)THEN IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPREA DEBUG :'', - '' x-Angular coverage: '',2F10.3/26X, - ''Periods: '',F10.3)') - 180*XAMIN/PI,180*XAMAX/PI,ABS(2*PI/(XAMAX-XAMIN)) IF(ABS(2*PI/(XAMAX-XAMIN)-ANINT(2*PI/(XAMAX-XAMIN))).GT. - 0.001.OR.ANINT(2*PI/(XAMAX-XAMIN)).LT.2)THEN PRINT *,' !!!!!! MAPREA WARNING : The map doesn''t'// - ' cover an integral fraction of 2 pi around x;'// - ' axial periodicity reset.' PERAX=.FALSE. OK=.FALSE. ENDIF ENDIF IF(PERAY)THEN IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPREA DEBUG :'', - '' y-Angular coverage: '',2F10.3/26X, - ''Periods: '',F10.3)') - 180*YAMIN/PI,180*YAMAX/PI,ABS(2*PI/(YAMAX-YAMIN)) IF(ABS(2*PI/(YAMAX-YAMIN)-ANINT(2*PI/(YAMAX-YAMIN))).GT. - 0.001.OR.ANINT(2*PI/(YAMAX-YAMIN)).LT.2)THEN PRINT *,' !!!!!! MAPREA WARNING : The map doesn''t'// - ' cover an integral fraction of 2 pi around y;'// - ' axial periodicity reset.' PERAY=.FALSE. OK=.FALSE. ENDIF ENDIF IF(PERAZ)THEN IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ MAPREA DEBUG :'', - '' z-Angular coverage: '',2F10.3/26X, - ''Periods: '',F10.3)') - 180*ZAMIN/PI,180*ZAMAX/PI,ABS(2*PI/(ZAMAX-ZAMIN)) IF(ABS(2*PI/(ZAMAX-ZAMIN)-ANINT(2*PI/(ZAMAX-ZAMIN))).GT. - 0.001.OR.ANINT(2*PI/(ZAMAX-ZAMIN)).LT.2)THEN PRINT *,' !!!!!! MAPREA WARNING : The map doesn''t'// - ' cover an integral fraction of 2 pi around z;'// - ' axial periodicity reset.' PERAZ=.FALSE. OK=.FALSE. ENDIF ENDIF *** Verify that the weighting field has received a label. DO 70 I=1,NWMAP IF((MAPFLG(10+3*I-2).OR.MAPFLG(11+3*I-2).OR. - MAPFLG(12+3*I-2)))THEN IF(EWSTYP(I).EQ.'?')THEN PRINT *,' ------ MAPREA MESSAGE : Assigning label'// - ' "S" to weighting field ',I EWSTYP(I)='S' ENDIF ENDIF 70 CONTINUE *** End of progress printing. CALL PROEND *** Set magnetic field flag. IF(MAPFLG(6).AND.MAPFLG(7).AND.MAPFLG(8))THEN MAGOK=.TRUE. IF(MAGSRC.EQ.1)PRINT *,' ------ MAGREA MESSAGE : B field'// - ' from &MAGNETIC replaced by a field map.' MAGSRC=2 IF(GASSET)PRINT *,' ------ MAPREA MESSAGE : Previous gas'// - ' data deleted.' GASSET=.FALSE. ELSEIF(MAGSRC.EQ.2)THEN PRINT *,' ------ MAGREA MESSAGE : The new field map has'// - ' no magnetic field; currently no magnetic field.' MAGSRC=0 MAGOK=.FALSE. IF(GASSET)PRINT *,' ------ MAPREA MESSAGE : Previous gas'// - ' data deleted.' GASSET=.FALSE. ENDIF *** Check the map if requested. IF(LHISMP)THEN CALL MAPCHK(IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! MAPREA WARNING : Histogramming'// - ' found map errors ; map rejected.' OK=.FALSE. ENDIF ENDIF *** Check that reading worked, IF(JFAIL.EQ.2.AND..NOT.OK)THEN PRINT *,' ###### MAPREA ERROR : Field maps reset'// - ' because of the above errors.' CALL MAPINT RETURN ELSEIF(JFAIL.EQ.3.AND..NOT.OK)THEN PRINT *,' ###### MAPREA ERROR : Program terminated'// - ' because of the above errors.' CALL QUIT RETURN ENDIF *** Set the same limits for the cell. XMIN=XMMIN XMAX=XMMAX YMIN=YMMIN YMAX=YMMAX ZMIN=ZMMIN ZMAX=ZMMAX VMIN=VMMIN VMAX=VMMAX IF(PERX.OR.PERMX)SX=ABS(XMMAX-XMMIN) IF(PERY.OR.PERMY)SY=ABS(YMMAX-YMMIN) IF(PERZ.OR.PERMZ)SZ=ABS(ZMMAX-ZMMIN) IF(PERRX)THEN XMIN=YMMIN XMAX=YMMAX YMIN=-MAX(ABS(XMMIN),ABS(XMMAX)) YMAX=+MAX(ABS(XMMIN),ABS(XMMAX)) ZMIN=-MAX(ABS(XMMIN),ABS(XMMAX)) ZMAX=+MAX(ABS(XMMIN),ABS(XMMAX)) ELSEIF(PERRY)THEN XMIN=-MAX(ABS(XMMIN),ABS(XMMAX)) XMAX=+MAX(ABS(XMMIN),ABS(XMMAX)) YMIN=YMMIN YMAX=YMMAX ZMIN=-MAX(ABS(XMMIN),ABS(XMMAX)) ZMAX=+MAX(ABS(XMMIN),ABS(XMMAX)) ELSEIF(PERRZ)THEN XMIN=-MAX(ABS(XMMIN),ABS(XMMAX)) XMAX=+MAX(ABS(XMMIN),ABS(XMMAX)) YMIN=-MAX(ABS(XMMIN),ABS(XMMAX)) YMAX=+MAX(ABS(XMMIN),ABS(XMMAX)) ZMIN=YMMIN ZMAX=YMMAX ENDIF IF(PERAX)THEN YMIN=-MAX(ABS(YMMIN),ABS(YMMAX),ABS(ZMMIN),ABS(ZMMAX)) YMAX=+MAX(ABS(YMMIN),ABS(YMMAX),ABS(ZMMIN),ABS(ZMMAX)) ZMIN=-MAX(ABS(YMMIN),ABS(YMMAX),ABS(ZMMIN),ABS(ZMMAX)) ZMAX=+MAX(ABS(YMMIN),ABS(YMMAX),ABS(ZMMIN),ABS(ZMMAX)) ELSEIF(PERAY)THEN XMIN=-MAX(ABS(XMMIN),ABS(XMMAX),ABS(ZMMIN),ABS(ZMMAX)) XMAX=+MAX(ABS(XMMIN),ABS(XMMAX),ABS(ZMMIN),ABS(ZMMAX)) ZMIN=-MAX(ABS(XMMIN),ABS(XMMAX),ABS(ZMMIN),ABS(ZMMAX)) ZMAX=+MAX(ABS(XMMIN),ABS(XMMAX),ABS(ZMMIN),ABS(ZMMAX)) ELSEIF(PERAZ)THEN XMIN=-MAX(ABS(XMMIN),ABS(XMMAX),ABS(YMMIN),ABS(YMMAX)) XMAX=+MAX(ABS(XMMIN),ABS(XMMAX),ABS(YMMIN),ABS(YMMAX)) YMIN=-MAX(ABS(XMMIN),ABS(XMMAX),ABS(YMMIN),ABS(YMMAX)) YMAX=+MAX(ABS(XMMIN),ABS(XMMAX),ABS(YMMIN),ABS(YMMAX)) ENDIF *** Return with flag "successful". IFAIL=0 END +DECK,MAPPLT. SUBROUTINE MAPPLT(PPXMIN,PPYMIN,PPZMIN,PPXMAX,PPYMAX,PPZMAX) *----------------------------------------------------------------------- * MAPPLT - Plots the materials. * (Last changed on 13/ 5/99.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,FIELDMAP. +SEQ,CELLDATA. +SEQ,PARAMETERS. REAL PPXMIN,PPYMIN,PPZMIN,PPXMAX,PPYMAX,PPZMAX, - XPL(20),YPL(20) DOUBLE PRECISION X1,Y1,Z1,X2,Y2,Z2,X3,Y3,Z3,X4,Y4,Z4,X5,Y5,Z5, - X6,Y6,Z6,X7,Y7,Z7,X8,Y8,Z8,XCUT,YCUT INTEGER I,NX,NXMIN,NXMAX,NY,NYMIN,NYMAX,NZ,NZMIN,NZMAX,NPL LOGICAL CUT,CROSS,IN1,IN2,IN3,IN4,IN5,IN6,IN7,IN8 EXTERNAL CROSS *** Don't do anything if the material map is not present. IF(.NOT.MAPFLG(9).OR..NOT.LMAPPL)RETURN *** 2D maps make only sense in a z-projection. IF((MAPTYP.EQ.1.OR.MAPTYP.EQ.2.OR.MAPTYP.EQ.3).AND. - ABS(FPROJC).LT.0.999*FPROJN)RETURN *** Set the tolerances for butterfly elimination. CALL EPSSET('SET',1.0D-6*ABS(PPXMAX-PPXMIN), - 1.0D-6*ABS(PPYMAX-PPYMIN),1.0D-6*ABS(PPZMAX-PPZMIN)) *** Determine the number of periods present in the cell. NXMIN=0 NXMAX=0 NYMIN=0 NYMAX=0 NZMIN=0 NZMAX=0 IF(PERX.OR.PERMX)THEN NXMIN=INT(PPXMIN/SX)-1 NXMAX=INT(PPXMAX/SX)+1 ENDIF IF(PERY.OR.PERMY)THEN NYMIN=INT(PPYMIN/SY)-1 NYMAX=INT(PPYMAX/SY)+1 ENDIF IF(PERZ.OR.PERMZ)THEN NZMIN=INT(PPZMIN/SZ)-1 NZMAX=INT(PPZMAX/SZ)+1 ENDIF *** Loop over the triangles. DO 10 I=1,NMAP * Skip the drift medium. IF(MATMAP(I).EQ.IDRMAT.OR.MATMAP(I).EQ.-1)GOTO 10 ** Triangular maps. IF(MAPTYP.EQ.1.OR.MAPTYP.EQ.2.OR.MAPTYP.EQ.3)THEN * Loop over the periods, if present. DO 20 NX=NXMIN,NXMAX DO 30 NY=NYMIN,NYMAX * Determine corners of the triangle. IF(PERMX.AND.NX.NE.2*(NX/2))THEN XPL(1)=XMMIN+XMMAX-XMAP(I,1)+NX*SX XPL(2)=XMMIN+XMMAX-XMAP(I,2)+NX*SX XPL(3)=XMMIN+XMMAX-XMAP(I,3)+NX*SX XPL(4)=XMMIN+XMMAX-XMAP(I,1)+NX*SX ELSE XPL(1)=XMAP(I,1)+NX*SX XPL(2)=XMAP(I,2)+NX*SX XPL(3)=XMAP(I,3)+NX*SX XPL(4)=XMAP(I,1)+NX*SX ENDIF IF(PERMY.AND.NY.NE.2*(NY/2))THEN YPL(1)=YMMIN+YMMAX-YMAP(I,1)+NY*SY YPL(2)=YMMIN+YMMAX-YMAP(I,2)+NY*SY YPL(3)=YMMIN+YMMAX-YMAP(I,3)+NY*SY YPL(4)=YMMIN+YMMAX-YMAP(I,1)+NY*SY ELSE YPL(1)=YMAP(I,1)+NY*SY YPL(2)=YMAP(I,2)+NY*SY YPL(3)=YMAP(I,3)+NY*SY YPL(4)=YMAP(I,1)+NY*SY ENDIF * Plot the various media. IF(MATMAP(I).EQ.1)THEN CALL GRATTS('MATERIAL-1','AREA') CALL GRCONV(4,XPL,YPL) ELSEIF(MATMAP(I).EQ.2)THEN CALL GRATTS('MATERIAL-2','AREA') CALL GRCONV(4,XPL,YPL) ELSEIF(MATMAP(I).EQ.3)THEN CALL GRATTS('MATERIAL-3','AREA') CALL GRCONV(4,XPL,YPL) ELSEIF(MATMAP(I).EQ.4)THEN CALL GRATTS('MATERIAL-4','AREA') CALL GRCONV(4,XPL,YPL) ELSE CALL GRATTS('MATERIAL-5','AREA') CALL GRCONV(4,XPL,YPL) ENDIF * Next medium. 30 CONTINUE 20 CONTINUE ** Tetrahedral maps. ELSEIF(MAPTYP.EQ.11.OR.MAPTYP.EQ.12.OR.MAPTYP.EQ.13)THEN * Loop over the x-periods, determine corners of tetrahedrons. DO 120 NX=NXMIN,NXMAX IF(PERMX.AND.NX.NE.2*(NX/2))THEN X1=XMMIN+XMMAX-XMAP(I,1)+NX*SX X2=XMMIN+XMMAX-XMAP(I,2)+NX*SX X3=XMMIN+XMMAX-XMAP(I,3)+NX*SX X4=XMMIN+XMMAX-XMAP(I,4)+NX*SX ELSE X1=XMAP(I,1)+NX*SX X2=XMAP(I,2)+NX*SX X3=XMAP(I,3)+NX*SX X4=XMAP(I,4)+NX*SX ENDIF * Loop over the y-periods, determine corners of tetrahedrons. DO 130 NY=NYMIN,NYMAX IF(PERMY.AND.NY.NE.2*(NY/2))THEN Y1=YMMIN+YMMAX-YMAP(I,1)+NY*SY Y2=YMMIN+YMMAX-YMAP(I,2)+NY*SY Y3=YMMIN+YMMAX-YMAP(I,3)+NY*SY Y4=YMMIN+YMMAX-YMAP(I,4)+NY*SY ELSE Y1=YMAP(I,1)+NY*SY Y2=YMAP(I,2)+NY*SY Y3=YMAP(I,3)+NY*SY Y4=YMAP(I,4)+NY*SY ENDIF * Loop over the z-periods, determine corners of tetrahedrons. DO 140 NZ=NZMIN,NZMAX IF(PERMZ.AND.NZ.NE.2*(NZ/2))THEN Z1=ZMMIN+ZMMAX-ZMAP(I,1)+NZ*SZ Z2=ZMMIN+ZMMAX-ZMAP(I,2)+NZ*SZ Z3=ZMMIN+ZMMAX-ZMAP(I,3)+NZ*SZ Z4=ZMMIN+ZMMAX-ZMAP(I,4)+NZ*SZ ELSE Z1=ZMAP(I,1)+NZ*SZ Z2=ZMAP(I,2)+NZ*SZ Z3=ZMAP(I,3)+NZ*SZ Z4=ZMAP(I,4)+NZ*SZ ENDIF * See whether the edges are in the plane. IN1=.FALSE. IN2=.FALSE. IN3=.FALSE. IN4=.FALSE. IF(ABS(FPROJA*X1+FPROJB*Y1+FPROJC*Z1-FPROJD).LT. - 1.0E-4*MAX(ABS(X1),ABS(Y1),ABS(Z1),ABS(FPROJA), - ABS(FPROJB),ABS(FPROJC),ABS(FPROJD)))IN1=.TRUE. IF(ABS(FPROJA*X2+FPROJB*Y2+FPROJC*Z2-FPROJD).LT. - 1.0E-4*MAX(ABS(X2),ABS(Y2),ABS(Z2),ABS(FPROJA), - ABS(FPROJB),ABS(FPROJC),ABS(FPROJD)))IN2=.TRUE. IF(ABS(FPROJA*X3+FPROJB*Y3+FPROJC*Z3-FPROJD).LT. - 1.0E-4*MAX(ABS(X3),ABS(Y3),ABS(Z3),ABS(FPROJA), - ABS(FPROJB),ABS(FPROJC),ABS(FPROJD)))IN3=.TRUE. IF(ABS(FPROJA*X4+FPROJB*Y4+FPROJC*Z4-FPROJD).LT. - 1.0E-4*MAX(ABS(X4),ABS(Y4),ABS(Z4),ABS(FPROJA), - ABS(FPROJB),ABS(FPROJC),ABS(FPROJD)))IN4=.TRUE. * Add those of the 4 corners that are in the plane. NPL=0 IF(IN1)THEN CALL PLACOO(X1,Y1,Z1,XCUT,YCUT) NPL=NPL+1 XPL(NPL)=XCUT YPL(NPL)=YCUT ENDIF IF(IN2)THEN CALL PLACOO(X2,Y2,Z2,XCUT,YCUT) NPL=NPL+1 XPL(NPL)=XCUT YPL(NPL)=YCUT ENDIF IF(IN3)THEN CALL PLACOO(X3,Y3,Z3,XCUT,YCUT) NPL=NPL+1 XPL(NPL)=XCUT YPL(NPL)=YCUT ENDIF IF(IN4)THEN CALL PLACOO(X4,Y4,Z4,XCUT,YCUT) NPL=NPL+1 XPL(NPL)=XCUT YPL(NPL)=YCUT ENDIF * Cut the 6 edges with the viewing plane. IF(.NOT.(IN1.OR.IN2))THEN CALL PLACUT(X1,Y1,Z1,X2,Y2,Z2,XCUT,YCUT,CUT) IF(CUT)THEN NPL=NPL+1 XPL(NPL)=XCUT YPL(NPL)=YCUT ENDIF ENDIF IF(.NOT.(IN1.OR.IN3))THEN CALL PLACUT(X1,Y1,Z1,X3,Y3,Z3,XCUT,YCUT,CUT) IF(CUT)THEN NPL=NPL+1 XPL(NPL)=XCUT YPL(NPL)=YCUT ENDIF ENDIF IF(.NOT.(IN1.OR.IN4))THEN CALL PLACUT(X1,Y1,Z1,X4,Y4,Z4,XCUT,YCUT,CUT) IF(CUT)THEN NPL=NPL+1 XPL(NPL)=XCUT YPL(NPL)=YCUT ENDIF ENDIF IF(.NOT.(IN2.OR.IN3))THEN CALL PLACUT(X2,Y2,Z2,X3,Y3,Z3,XCUT,YCUT,CUT) IF(CUT)THEN NPL=NPL+1 XPL(NPL)=XCUT YPL(NPL)=YCUT ENDIF ENDIF IF(.NOT.(IN2.OR.IN4))THEN CALL PLACUT(X2,Y2,Z2,X4,Y4,Z4,XCUT,YCUT,CUT) IF(CUT)THEN NPL=NPL+1 XPL(NPL)=XCUT YPL(NPL)=YCUT ENDIF ENDIF IF(.NOT.(IN3.OR.IN4))THEN CALL PLACUT(X3,Y3,Z3,X4,Y4,Z4,XCUT,YCUT,CUT) IF(CUT)THEN NPL=NPL+1 XPL(NPL)=XCUT YPL(NPL)=YCUT ENDIF ENDIF * Plot the various media. IF(NPL.GE.3)THEN NPL=NPL+1 XPL(NPL)=XPL(1) YPL(NPL)=YPL(1) IF(MATMAP(I).EQ.1)THEN CALL GRATTS('MATERIAL-1','AREA') CALL GRCONV(NPL,XPL,YPL) ELSEIF(MATMAP(I).EQ.2)THEN CALL GRATTS('MATERIAL-2','AREA') CALL GRCONV(NPL,XPL,YPL) ELSEIF(MATMAP(I).EQ.3)THEN CALL GRATTS('MATERIAL-3','AREA') CALL GRCONV(NPL,XPL,YPL) ELSEIF(MATMAP(I).EQ.4)THEN CALL GRATTS('MATERIAL-4','AREA') CALL GRCONV(NPL,XPL,YPL) ELSE CALL GRATTS('MATERIAL-5','AREA') CALL GRCONV(NPL,XPL,YPL) ENDIF ENDIF * Next periods. 140 CONTINUE 130 CONTINUE 120 CONTINUE ** Hexahedral maps. ELSEIF(MAPTYP.EQ.14.OR.MAPTYP.EQ.15.OR.MAPTYP.EQ.16)THEN * Loop over the x-periods, determine corners of hexahedrons. DO 150 NX=NXMIN,NXMAX IF(PERMX.AND.NX.NE.2*(NX/2))THEN X1=XMMIN+XMMAX-XMAP(I,1)+NX*SX X2=X1-(XMAP(I,2)-XMAP(I,1)) X4=X1-(XMAP(I,3)-XMAP(I,1)) X3=X2+X4-X1 X5=X1-(XMAP(I,4)-XMAP(I,1)) X6=X2-(XMAP(I,4)-XMAP(I,1)) X7=X3-(XMAP(I,4)-XMAP(I,1)) X8=X4-(XMAP(I,4)-XMAP(I,1)) ELSE X1=XMAP(I,1)+NX*SX X2=X1+(XMAP(I,2)-XMAP(I,1)) X4=X1+(XMAP(I,3)-XMAP(I,1)) X3=X2+X4-X1 X5=X1+(XMAP(I,4)-XMAP(I,1)) X6=X2+(XMAP(I,4)-XMAP(I,1)) X7=X3+(XMAP(I,4)-XMAP(I,1)) X8=X4+(XMAP(I,4)-XMAP(I,1)) ENDIF * Loop over the y-periods, determine corners of tetrahedrons. DO 160 NY=NYMIN,NYMAX IF(PERMY.AND.NY.NE.2*(NY/2))THEN Y1=YMMIN+YMMAX-YMAP(I,1)+NY*SY Y2=Y1-(YMAP(I,2)-YMAP(I,1)) Y4=Y1-(YMAP(I,3)-YMAP(I,1)) Y3=Y2+Y4-Y1 Y5=Y1-(YMAP(I,4)-YMAP(I,1)) Y6=Y2-(YMAP(I,4)-YMAP(I,1)) Y7=Y3-(YMAP(I,4)-YMAP(I,1)) Y8=Y4-(YMAP(I,4)-YMAP(I,1)) ELSE Y1=YMAP(I,1)+NY*SY Y2=Y1+(YMAP(I,2)-YMAP(I,1)) Y4=Y1+(YMAP(I,3)-YMAP(I,1)) Y3=Y2+Y4-Y1 Y5=Y1+(YMAP(I,4)-YMAP(I,1)) Y6=Y2+(YMAP(I,4)-YMAP(I,1)) Y7=Y3+(YMAP(I,4)-YMAP(I,1)) Y8=Y4+(YMAP(I,4)-YMAP(I,1)) ENDIF * Loop over the z-periods, determine corners of tetrahedrons. DO 170 NZ=NZMIN,NZMAX IF(PERMZ.AND.NZ.NE.2*(NZ/2))THEN Z1=ZMMIN+ZMMAX-ZMAP(I,1)+NZ*SZ Z2=Z1-(ZMAP(I,2)-ZMAP(I,1)) Z4=Z1-(ZMAP(I,3)-ZMAP(I,1)) Z3=Z2+Z4-Z1 Z5=Z1-(ZMAP(I,4)-ZMAP(I,1)) Z6=Z2-(ZMAP(I,4)-ZMAP(I,1)) Z7=Z3-(ZMAP(I,4)-ZMAP(I,1)) Z8=Z4-(ZMAP(I,4)-ZMAP(I,1)) ELSE Z1=ZMAP(I,1)+NZ*SZ Z2=Z1+(ZMAP(I,2)-ZMAP(I,1)) Z4=Z1+(ZMAP(I,3)-ZMAP(I,1)) Z3=Z2+Z4-Z1 Z5=Z1+(ZMAP(I,4)-ZMAP(I,1)) Z6=Z2+(ZMAP(I,4)-ZMAP(I,1)) Z7=Z3+(ZMAP(I,4)-ZMAP(I,1)) Z8=Z4+(ZMAP(I,4)-ZMAP(I,1)) ENDIF * See whether the edges are in the plane. IN1=.FALSE. IN2=.FALSE. IN3=.FALSE. IN4=.FALSE. IN5=.FALSE. IN6=.FALSE. IN7=.FALSE. IN8=.FALSE. IF(ABS(FPROJA*X1+FPROJB*Y1+FPROJC*Z1-FPROJD).LT. - 1.0E-4*MAX(ABS(X1),ABS(Y1),ABS(Z1),ABS(FPROJA), - ABS(FPROJB),ABS(FPROJC),ABS(FPROJD)))IN1=.TRUE. IF(ABS(FPROJA*X2+FPROJB*Y2+FPROJC*Z2-FPROJD).LT. - 1.0E-4*MAX(ABS(X2),ABS(Y2),ABS(Z2),ABS(FPROJA), - ABS(FPROJB),ABS(FPROJC),ABS(FPROJD)))IN2=.TRUE. IF(ABS(FPROJA*X3+FPROJB*Y3+FPROJC*Z3-FPROJD).LT. - 1.0E-4*MAX(ABS(X3),ABS(Y3),ABS(Z3),ABS(FPROJA), - ABS(FPROJB),ABS(FPROJC),ABS(FPROJD)))IN3=.TRUE. IF(ABS(FPROJA*X4+FPROJB*Y4+FPROJC*Z4-FPROJD).LT. - 1.0E-4*MAX(ABS(X4),ABS(Y4),ABS(Z4),ABS(FPROJA), - ABS(FPROJB),ABS(FPROJC),ABS(FPROJD)))IN4=.TRUE. IF(ABS(FPROJA*X5+FPROJB*Y5+FPROJC*Z5-FPROJD).LT. - 1.0E-4*MAX(ABS(X5),ABS(Y5),ABS(Z5),ABS(FPROJA), - ABS(FPROJB),ABS(FPROJC),ABS(FPROJD)))IN5=.TRUE. IF(ABS(FPROJA*X6+FPROJB*Y6+FPROJC*Z6-FPROJD).LT. - 1.0E-4*MAX(ABS(X6),ABS(Y6),ABS(Z6),ABS(FPROJA), - ABS(FPROJB),ABS(FPROJC),ABS(FPROJD)))IN6=.TRUE. IF(ABS(FPROJA*X7+FPROJB*Y7+FPROJC*Z7-FPROJD).LT. - 1.0E-4*MAX(ABS(X7),ABS(Y7),ABS(Z7),ABS(FPROJA), - ABS(FPROJB),ABS(FPROJC),ABS(FPROJD)))IN7=.TRUE. IF(ABS(FPROJA*X8+FPROJB*Y8+FPROJC*Z8-FPROJD).LT. - 1.0E-4*MAX(ABS(X8),ABS(Y8),ABS(Z8),ABS(FPROJA), - ABS(FPROJB),ABS(FPROJC),ABS(FPROJD)))IN8=.TRUE. * Add those of the 8 corners that are in the plane. NPL=0 IF(IN1)THEN CALL PLACOO(X1,Y1,Z1,XCUT,YCUT) NPL=NPL+1 XPL(NPL)=XCUT YPL(NPL)=YCUT ENDIF IF(IN2)THEN CALL PLACOO(X2,Y2,Z2,XCUT,YCUT) NPL=NPL+1 XPL(NPL)=XCUT YPL(NPL)=YCUT ENDIF IF(IN3)THEN CALL PLACOO(X3,Y3,Z3,XCUT,YCUT) NPL=NPL+1 XPL(NPL)=XCUT YPL(NPL)=YCUT ENDIF IF(IN4)THEN CALL PLACOO(X4,Y4,Z4,XCUT,YCUT) NPL=NPL+1 XPL(NPL)=XCUT YPL(NPL)=YCUT ENDIF IF(IN5)THEN CALL PLACOO(X5,Y5,Z5,XCUT,YCUT) NPL=NPL+1 XPL(NPL)=XCUT YPL(NPL)=YCUT ENDIF IF(IN6)THEN CALL PLACOO(X6,Y6,Z6,XCUT,YCUT) NPL=NPL+1 XPL(NPL)=XCUT YPL(NPL)=YCUT ENDIF IF(IN7)THEN CALL PLACOO(X7,Y7,Z7,XCUT,YCUT) NPL=NPL+1 XPL(NPL)=XCUT YPL(NPL)=YCUT ENDIF IF(IN8)THEN CALL PLACOO(X8,Y8,Z8,XCUT,YCUT) NPL=NPL+1 XPL(NPL)=XCUT YPL(NPL)=YCUT ENDIF * Cut the 12 edges with the viewing plane. IF(.NOT.(IN1.OR.IN2))THEN CALL PLACUT(X1,Y1,Z1,X2,Y2,Z2,XCUT,YCUT,CUT) IF(CUT)THEN NPL=NPL+1 XPL(NPL)=XCUT YPL(NPL)=YCUT ENDIF ENDIF IF(.NOT.(IN2.OR.IN3))THEN CALL PLACUT(X2,Y2,Z2,X3,Y3,Z3,XCUT,YCUT,CUT) IF(CUT)THEN NPL=NPL+1 XPL(NPL)=XCUT YPL(NPL)=YCUT ENDIF ENDIF IF(.NOT.(IN3.OR.IN4))THEN CALL PLACUT(X3,Y3,Z3,X4,Y4,Z4,XCUT,YCUT,CUT) IF(CUT)THEN NPL=NPL+1 XPL(NPL)=XCUT YPL(NPL)=YCUT ENDIF ENDIF IF(.NOT.(IN4.OR.IN1))THEN CALL PLACUT(X4,Y4,Z4,X1,Y1,Z1,XCUT,YCUT,CUT) IF(CUT)THEN NPL=NPL+1 XPL(NPL)=XCUT YPL(NPL)=YCUT ENDIF ENDIF IF(.NOT.(IN5.OR.IN6))THEN CALL PLACUT(X5,Y5,Z5,X6,Y6,Z6,XCUT,YCUT,CUT) IF(CUT)THEN NPL=NPL+1 XPL(NPL)=XCUT YPL(NPL)=YCUT ENDIF ENDIF IF(.NOT.(IN6.OR.IN7))THEN CALL PLACUT(X6,Y6,Z6,X7,Y7,Z7,XCUT,YCUT,CUT) IF(CUT)THEN NPL=NPL+1 XPL(NPL)=XCUT YPL(NPL)=YCUT ENDIF ENDIF IF(.NOT.(IN7.OR.IN8))THEN CALL PLACUT(X7,Y7,Z7,X8,Y8,Z8,XCUT,YCUT,CUT) IF(CUT)THEN NPL=NPL+1 XPL(NPL)=XCUT YPL(NPL)=YCUT ENDIF ENDIF IF(.NOT.(IN8.OR.IN5))THEN CALL PLACUT(X8,Y8,Z8,X5,Y5,Z5,XCUT,YCUT,CUT) IF(CUT)THEN NPL=NPL+1 XPL(NPL)=XCUT YPL(NPL)=YCUT ENDIF ENDIF IF(.NOT.(IN1.OR.IN5))THEN CALL PLACUT(X1,Y1,Z1,X5,Y5,Z5,XCUT,YCUT,CUT) IF(CUT)THEN NPL=NPL+1 XPL(NPL)=XCUT YPL(NPL)=YCUT ENDIF ENDIF IF(.NOT.(IN2.OR.IN6))THEN CALL PLACUT(X2,Y2,Z2,X6,Y6,Z6,XCUT,YCUT,CUT) IF(CUT)THEN NPL=NPL+1 XPL(NPL)=XCUT YPL(NPL)=YCUT ENDIF ENDIF IF(.NOT.(IN3.OR.IN7))THEN CALL PLACUT(X3,Y3,Z3,X7,Y7,Z7,XCUT,YCUT,CUT) IF(CUT)THEN NPL=NPL+1 XPL(NPL)=XCUT YPL(NPL)=YCUT ENDIF ENDIF IF(.NOT.(IN4.OR.IN8))THEN CALL PLACUT(X4,Y4,Z4,X8,Y8,Z8,XCUT,YCUT,CUT) IF(CUT)THEN NPL=NPL+1 XPL(NPL)=XCUT YPL(NPL)=YCUT ENDIF ENDIF * Plot the various media. IF(NPL.GE.3)THEN NPL=NPL+1 XPL(NPL)=XPL(1) YPL(NPL)=YPL(1) IF(MATMAP(I).EQ.1)THEN CALL GRATTS('MATERIAL-1','AREA') CALL GRCONV(NPL,XPL,YPL) ELSEIF(MATMAP(I).EQ.2)THEN CALL GRATTS('MATERIAL-2','AREA') CALL GRCONV(NPL,XPL,YPL) ELSEIF(MATMAP(I).EQ.3)THEN CALL GRATTS('MATERIAL-3','AREA') CALL GRCONV(NPL,XPL,YPL) ELSEIF(MATMAP(I).EQ.4)THEN CALL GRATTS('MATERIAL-4','AREA') CALL GRCONV(NPL,XPL,YPL) ELSE CALL GRATTS('MATERIAL-5','AREA') CALL GRCONV(NPL,XPL,YPL) ENDIF ENDIF * Next periods. 170 CONTINUE 160 CONTINUE 150 CONTINUE ENDIF * Next element. 10 CONTINUE *** Reset the tolerances. CALL EPSSET('RESET',0.0D0,0.0D0,0.0D0) END +DECK,MAPPRT. SUBROUTINE MAPPRT *----------------------------------------------------------------------- * MAPPRT - Prints a field map overview. * (Last changed on 29/11/99.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,FIELDMAP. +SEQ,CELLDATA. +SEQ,PRINTPLOT. +SEQ,CONSTANTS. INTEGER I *** Make sure there is a field map. IF(NMAP.LE.1)THEN WRITE(LUNOUT,'(/'' There is currently no field'', - '' map.'')/') RETURN ENDIF *** Print the elements that are present. IF(MAPTYP.EQ.1.OR.MAPTYP.EQ.2.OR.MAPTYP.EQ.3)THEN WRITE(LUNOUT,'(/'' The field is taken from a field map'', - '' of '',I5,'' triangles,''/'' at the vertices'', - '' of which the following are known:'')') NMAP ELSEIF(MAPTYP.EQ.11.OR.MAPTYP.EQ.12.OR.MAPTYP.EQ.13)THEN WRITE(LUNOUT,'(/'' The field is taken from a field map'', - '' of '',I5,'' tetrahedrons,''/'' at the vertices'', - '' of which the following are known:'')') NMAP ELSEIF(MAPTYP.EQ.14.OR.MAPTYP.EQ.15.OR.MAPTYP.EQ.16)THEN WRITE(LUNOUT,'(/'' The field is taken from a field map'', - '' of '',I5,'' parallelepipeds,''/ - '' at the vertices of which the following'', - '' are known:'')') NMAP ELSE WRITE(LUNOUT,'(/'' The field is taken from a field map'', - '' of '',I5,'' elements of unknown type,''/ - '' at the vertices of which the following''/ - '' are known:'')') NMAP ENDIF IF(MAPFLG(2))WRITE(LUNOUT,'('' - x-component of the'', - '' electric field'')') IF(MAPFLG(3))WRITE(LUNOUT,'('' - y-component of the'', - '' electric field'')') IF(MAPFLG(4))WRITE(LUNOUT,'('' - z-component of the'', - '' electric field'')') IF(MAPFLG(5))WRITE(LUNOUT,'('' - electrostatic'', - '' potential'')') IF(MAPFLG(6))WRITE(LUNOUT,'('' - x-component of the'', - '' magnetic field'')') IF(MAPFLG(7))WRITE(LUNOUT,'('' - y-component of the'', - '' magnetic field'')') IF(MAPFLG(8))WRITE(LUNOUT,'('' - z-component of the'', - '' magnetic field'')') IF(MAPFLG(9))WRITE(LUNOUT,'('' - dielectric constants'', - '' of the materials'')') DO 10 I=1,NWMAP IF(MAPFLG(10+3*I-2))WRITE(LUNOUT,'('' - x-component of a'', - '' weighting field for solids with label '',A1)') EWSTYP(I) IF(MAPFLG(11+3*I-2))WRITE(LUNOUT,'('' - y-component of a'', - '' weighting field for solids with label '',A1)') EWSTYP(I) IF(MAPFLG(12+3*I-2))WRITE(LUNOUT,'('' - z-component of a'', - '' weighting field for solids with label '',A1)') EWSTYP(I) 10 CONTINUE *** Print the ranges and periodicities. WRITE(LUNOUT,'(/'' The grid covers the area: ''/ - 5X,E15.8,'' < x < '',E15.8/ - 5X,E15.8,'' < y < '',E15.8/ - 5X,E15.8,'' < z < '',E15.8)') - XMMIN,XMMAX,YMMIN,YMMAX,ZMMIN,ZMMAX IF(MAPFLG(5))WRITE(LUNOUT,'('' and has a potential'', - '' range: ''/ - 5X,E15.8,'' < V < '',E15.8)') VMMIN,VMMAX IF(PERX)THEN WRITE(LUNOUT,'(/'' The cell is repeated in x, the'', - '' length of a period is '',F10.3,'' cm.'')') SX ELSEIF(PERMX)THEN WRITE(LUNOUT,'(/'' The cell has mirror periodicity'', - '' in x with a length of '',F10.3,'' cm.'')') SX ELSE WRITE(LUNOUT,'(/'' The cell has no translation'', - '' periodicity in x.'')') ENDIF IF(PERAX)THEN WRITE(LUNOUT,'('' The cell has axial periodicity'', - '' around the x-axis of '',F10.1, - '' degrees.'')') (XAMAX-XAMIN)*180/PI ELSEIF(PERRX)THEN WRITE(LUNOUT,'('' The cell is rotationally'', - '' symmetric around the x-axis.'')') ELSE WRITE(LUNOUT,'('' The cell has no axial periodicity'', - '' around the x-axis.'')') ENDIF * In y. IF(PERY)THEN WRITE(LUNOUT,'('' The cell is repeated in y, the'', - '' length of a period is '',F10.3,'' cm.'')') SY ELSEIF(PERMY)THEN WRITE(LUNOUT,'('' The cell has mirror periodicity'', - '' in y with a length of '',F10.3, - '' cm.'')') SY ELSE WRITE(LUNOUT,'('' The cell has no translation'', - '' periodicity in y.'')') ENDIF IF(PERAY)THEN WRITE(LUNOUT,'('' The cell has axial periodicity'', - '' around the y-axis of '',F10.1, - '' degrees.'')') (YAMAX-YAMIN)*180/PI ELSEIF(PERRY)THEN WRITE(LUNOUT,'('' The cell is rotationally'', - '' symmetric around the y-axis.'')') ELSE WRITE(LUNOUT,'('' The cell has no axial periodicity'', - '' around the y-axis.'')') ENDIF * In z. IF(PERZ)THEN WRITE(LUNOUT,'('' The cell is repeated in z, the'', - '' length of a period is '',F10.3,'' cm.'')') SZ ELSEIF(PERMZ)THEN WRITE(LUNOUT,'('' The cell has mirror periodicity'', - '' in z with a length of '',F10.3,'' cm.'')') SZ ELSE WRITE(LUNOUT,'('' The cell has no translation'', - '' periodicity in z.'')') ENDIF IF(PERAZ)THEN WRITE(LUNOUT,'('' The cell has axial periodicity'', - '' around the z-axis of '',F10.1, - '' degrees.'')') (ZAMAX-ZAMIN)*180/PI ELSEIF(PERRZ)THEN WRITE(LUNOUT,'('' The cell is rotationally'', - '' symmetric around the z-axis.'')') ELSE WRITE(LUNOUT,'('' The cell has no axial periodicity'', - '' around the z-axis.'')') ENDIF *** List the materials. IF(NEPS.GE.1)THEN IF(MAPTYP.GT.10.AND.MATSRC.EQ.'SIGMA')THEN WRITE(LUNOUT,'(/'' There are '',I5,'' materials'', - '' which differ by conducivity: ''/ - '' Index Sigma [S/m] Volume [cm3]'')') - NEPS ELSEIF(MAPTYP.GT.10)THEN WRITE(LUNOUT,'(/'' There are '',I5,'' materials'', - '' which differ by dielectric constant: ''/ - '' Index Epsilon Volume [cm3]'')') - NEPS ELSEIF(MATSRC.EQ.'SIGMA')THEN WRITE(LUNOUT,'(/'' There are '',I5,'' materials'', - '' which differ by conducivity: ''/ - '' Index Sigma [S/m] Surface [cm2]'')') - NEPS ELSE WRITE(LUNOUT,'(/'' There are '',I5,'' materials'', - '' which differ by dielectric constant: ''/ - '' Index Epsilon Surface [cm2]'')') - NEPS ENDIF DO 70 I=1,NEPS IF(MATSRC.EQ.'SIGMA')THEN IF(I.EQ.IDRMAT)THEN WRITE(LUNOUT,'('' '',I5,2X,E12.5,2X,E15.8, - '' (drift medium)'')') - I,EPSMAT(I),EPSSUR(I) ELSE WRITE(LUNOUT,'('' '',I5,2X,E12.5,2X,E15.8)') - I,EPSMAT(I),EPSSUR(I) ENDIF ELSE IF(I.EQ.IDRMAT)THEN WRITE(LUNOUT,'('' '',I5,2X,F12.3,2X,E15.8, - '' (drift medium)'')') - I,EPSMAT(I),EPSSUR(I) ELSE WRITE(LUNOUT,'('' '',I5,2X,F12.3,2X,E15.8)') - I,EPSMAT(I),EPSSUR(I) ENDIF ENDIF 70 CONTINUE ELSE WRITE(LUNOUT,'(/'' No material properties available.'')') ENDIF *** Print the interpolation order. IF(MAPORD.EQ.1)THEN WRITE(LUNOUT,'(/'' The field maps will be interpolated'', - '' linearly.'')') ELSEIF(MAPORD.EQ.2)THEN WRITE(LUNOUT,'(/'' The field maps will be interpolated'', - '' quadratically.'')') ELSE WRITE(LUNOUT,'(/'' The field maps will be interpolated'', - '' to order '',I2,''.'')') MAPORD ENDIF END +PATCH,OPTIMISE. +DECK,OPTADD. SUBROUTINE OPTADD(CHANGE) *----------------------------------------------------------------------- * OPTADD - This routine adds items to the cell. * (Last changed on 29/11/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. +SEQ,CONSTANTS. +SEQ,CELLDATA. CHARACTER*(MXCHAR) STRING CHARACTER WIRCDE INTEGER INPCMP,INPTYP,NWORD,I,J,INEXT,IDIR,ICSET,IXYSET, - IVSET,IFAIL,IFAIL1,IFAIL2,NC REAL S,COOR,VOLT,XWIR,YWIR,DWIR,VWIR,UWIR,WWIR,DENWIR EXTERNAL INPCMP,INPTYP LOGICAL CHANGE *** Assume no change at first. CHANGE=.FALSE. *** Pick up the number of arguments. CALL INPNUM(NWORD) IF(NWORD.LE.1)THEN PRINT *,' !!!!!! OPTADD WARNING : You must specify which'// - ' items you wish to add; cell not changed.' RETURN ENDIF *** Loop over the arguments. INEXT=2 DO 10 I=2,NWORD IF(I.LT.INEXT)GOTO 10 ** Add a periodicity. IF(INPCMP(I,'PE#RIODICITY').NE.0)THEN * Check there are arguments. IF(I+2.LT.NWORD)THEN CALL INPMSG(I,'Should have two arguments. ') GOTO 10 ENDIF * Initialise the direction and length. IDIR=0 S=-1.0 * Check the coordinate system and reject r periodicities. IF(INPCMP(I+1,'X')+INPCMP(I+1,'Y').NE.0.AND.POLAR)THEN CALL INPMSG(I+1,'Only polar elements permitted.') INEXT=I+2 GOTO 10 ELSEIF(INPCMP(I+1,'PHI').NE.0.AND..NOT.POLAR)THEN CALL INPMSG(I+1,'No polar elements permitted. ') INEXT=I+2 GOTO 10 ELSEIF(INPCMP(I+1,'R').NE.0)THEN CALL INPMSG(I+1,'No radial periods permitted. ') INEXT=I+3 GOTO 10 ENDIF * Read the length. IF(INPCMP(I+1,'X')+INPCMP(I+1,'Y')+ - INPCMP(I+1,'PHI').NE.0)THEN CALL INPCHK(I+2,2,IFAIL) IF(IFAIL.NE.0)THEN INEXT=I+3 GOTO 10 ENDIF CALL INPRDR(I+2,S,-1.0) IF(S.LE.0.0)CALL INPMSG(I+2, - 'The length must be > 0. ') ENDIF * Store the period direction. IF(INPCMP(I+1,'X').NE.0)THEN IDIR=1 ELSEIF(INPCMP(I+1,'Y').NE.0)THEN IDIR=2 ELSEIF(INPCMP(I+1,'PHI').NE.0)THEN IDIR=4 ELSEIF(INPCMP(I+1,'PE#RIODICITY')+INPCMP(I+1,'PL#ANE')+ - INPCMP(I+1,'W#IRE').NE.0)THEN CALL INPMSG(I,'Should have two arguments. ') INEXT=I+1 GOTO 10 ELSE CALL INPMSG(I+1,'Not a valid period direction. ') INEXT=I+1 GOTO 10 ENDIF * Check the data and update the cell. IF(IDIR.EQ.0.OR.S.LE.0.0)THEN CALL INPMSG(I,'Not a valid specification. ') ELSEIF(IDIR.EQ.1)THEN IF(PERX)PRINT *,' !!!!!! OPTADD WARNING :'// - ' Previous x periodicity overridden.' CHANGE=.TRUE. PERX=.TRUE. SX=S ELSEIF(IDIR.EQ.2)THEN IF(PERY)PRINT *,' !!!!!! OPTADD WARNING :'// - ' Previous y periodicity overridden.' CHANGE=.TRUE. PERY=.TRUE. SY=S ELSEIF(IDIR.EQ.4)THEN IF(PERY)PRINT *,' !!!!!! OPTADD WARNING :'// - ' Previous phi periodicity overridden.' IF(ABS(360.0-S*ANINT(360.0/S)).GT.1.0E-4)PRINT *, - ' !!!!!! OPTADD WARNING : The phi period is'// - ' rounded so that it divides 360.' CHANGE=.TRUE. PERY=.TRUE. SY=2*PI*ANINT(360.0/S) ENDIF * Skip the words that were read. INEXT=I+3 ** Add a plane. ELSEIF(INPCMP(I,'PL#ANE').NE.0)THEN * Initialise the direction and coordinate. IDIR=0 COOR=0.0 ICSET=0 VOLT=0.0 WIRCDE=' ' * Read the specified direction and length. DO 40 J=I+1,NWORD-1 IF(J.LT.INEXT)GOTO 40 * Trivial errors. IF(INPCMP(J,'R')+INPCMP(J,'PHI').NE.0.AND..NOT.POLAR)THEN CALL INPMSG(J,'No polar planes are permitted.') INEXT=J+1 GOTO 40 ELSEIF(INPCMP(J,'X')+INPCMP(J,'Y').NE.0.AND.POLAR)THEN CALL INPMSG(J,'Only polar planes permitted. ') INEXT=J+1 GOTO 40 ENDIF * Pick up the direction, if it is one. IF(INPCMP(J,'X').NE.0)THEN IDIR=1 ELSEIF(INPCMP(J,'Y').NE.0)THEN IDIR=2 ELSEIF(INPCMP(J,'R').NE.0)THEN IDIR=3 ELSEIF(INPCMP(J,'PHI').NE.0)THEN IDIR=4 ENDIF * Pick up the position or the potential. IF(INPCMP(J,'R')+INPCMP(J,'PHI')+ - INPCMP(J,'X')+INPCMP(J,'Y').NE.0)THEN CALL INPCHK(J+1,2,IFAIL) CALL INPRDR(J+1,COOR,0.0) INEXT=J+2 IF(INPCMP(J,'R').NE.0.AND.COOR.LE.0.0.AND. - IFAIL.EQ.0)THEN CALL INPMSG(J+1,'Radial coordinate must be > 0.') GOTO 10 ENDIF ICSET=1 ELSEIF(INPCMP(J,'V#OLTAGE').NE.0)THEN CALL INPCHK(J+1,2,IFAIL) CALL INPRDR(J+1,VOLT,0.0) INEXT=J+2 * Labels. ELSEIF(INPCMP(J,'LAB#EL').NE.0)THEN CALL INPSTR(J+1,J+1,STRING,NC) WIRCDE=STRING(1:1) IF(INDEX('ABCDEFGHIJKLMNOPQRSTUVWXYZ',WIRCDE).EQ. - 0)THEN CALL INPMSG(J+1,'The label must be a letter.') GOTO 10 ENDIF INEXT=J+2 * Other keywords. ELSEIF(INPCMP(J,'PE#RIODICITY')+INPCMP(J,'PL#ANE')+ - INPCMP(J,'W#IRE').NE.0)THEN GOTO 50 ELSE CALL INPMSG(J,'Neither a V nor a direction. ') INEXT=J+1 ENDIF 40 CONTINUE * Check the data and store the plane. 50 CONTINUE IF(IDIR.EQ.0.OR.ICSET.EQ.0)THEN CALL INPMSG(I,'Not a valid specification. ') ELSEIF(IDIR.EQ.1.OR.IDIR.EQ.3)THEN IF(IDIR.EQ.3)COOR=LOG(COOR) IF(.NOT.YNPLAN(1))THEN YNPLAN(1)=.TRUE. COPLAN(1)=COOR VTPLAN(1)=VOLT PLATYP(1)=WIRCDE INDPLA(1)=0 NPSTR1(1)=0 NPSTR2(1)=0 CHANGE=.TRUE. ELSEIF(.NOT.YNPLAN(2))THEN YNPLAN(2)=.TRUE. COPLAN(2)=COOR VTPLAN(2)=VOLT PLATYP(2)=WIRCDE INDPLA(2)=0 NPSTR1(2)=0 NPSTR2(2)=0 CHANGE=.TRUE. ELSE CALL INPMSG(I,'No room for further planes. ') ENDIF ELSEIF(IDIR.EQ.2.OR.IDIR.EQ.4)THEN IF(IDIR.EQ.3)COOR=PI*COOR/180.0 IF(.NOT.YNPLAN(3))THEN YNPLAN(3)=.TRUE. COPLAN(3)=COOR VTPLAN(3)=VOLT PLATYP(3)=WIRCDE INDPLA(3)=0 NPSTR1(3)=0 NPSTR2(3)=0 CHANGE=.TRUE. ELSEIF(.NOT.YNPLAN(4))THEN YNPLAN(4)=.TRUE. COPLAN(4)=COOR VTPLAN(4)=VOLT PLATYP(4)=WIRCDE INDPLA(4)=0 NPSTR1(4)=0 NPSTR2(4)=0 CHANGE=.TRUE. ELSE CALL INPMSG(I,'No room for further planes. ') ENDIF ENDIF ** Add a wire. ELSEIF(INPCMP(I,'W#IRE').NE.0)THEN * Initialise wire-code, diameter, position and potential. WIRCDE='?' XWIR=0.0 YWIR=0.0 IXYSET=0 VWIR=0.0 IVSET=0 DWIR=0.0100 UWIR=100.0 WWIR=50.0 DENWIR=19.3 * Loop over the keywords. DO 70 J=I+1,NWORD IF(J.LT.INEXT)GOTO 70 * Wire position. IF(INPCMP(J,'AT').NE.0)THEN IF(J+2.GT.NWORD.OR.INPTYP(J+1).LE.0.OR. - INPTYP(J+2).LE.0)THEN CALL INPMSG(I,'Needs two numeric arguments. ') IF(INPTYP(J+1).LE.0)THEN INEXT=J+1 ELSEIF(INPTYP(J+2).LE.0)THEN INEXT=J+2 ELSE INEXT=J+3 ENDIF GOTO 70 ENDIF CALL INPCHK(J+1,2,IFAIL1) CALL INPCHK(J+2,2,IFAIL2) IF(IFAIL1.EQ.0.AND.IFAIL2.EQ.0)THEN CALL INPRDR(J+1,XWIR,0.0) CALL INPRDR(J+2,YWIR,0.0) IF(POLAR.AND.XWIR.LE.0.0)THEN CALL INPMSG(J+1, - 'Invalid polar coordinate. ') ELSE IXYSET=1 ENDIF ENDIF INEXT=J+3 * Wire potential. ELSEIF(INPCMP(J,'V#OLTAGE').NE.0)THEN IF(J+1.GT.NWORD.OR.INPTYP(J+1).LE.0)THEN CALL INPMSG(I,'Needs one numeric argument. ') IF(INPTYP(J+1).LE.0)THEN INEXT=J+1 ELSE INEXT=J+2 ENDIF GOTO 70 ENDIF CALL INPCHK(J+1,2,IFAIL1) IF(IFAIL1.EQ.0)THEN CALL INPRDR(J+1,VWIR,0.0) IVSET=1 ENDIF INEXT=J+2 * Wire label. ELSEIF(INPCMP(J,'TYP#E')+INPCMP(J,'LAB#EL').NE.0)THEN IF(J+1.GT.NWORD)THEN CALL INPMSG(J,'Has one character as argument.') INEXT=J+1 GOTO 70 ENDIF CALL INPSTR(J+1,J+1,STRING,NC) IF(INDEX('ABCDEFGHIJKLMNOPQRSTUVWXYZ', - STRING(1:1)).EQ.0)THEN CALL INPMSG(J+1,'Non-alphabetic first character') ELSE WIRCDE=STRING(1:1) ENDIF INEXT=J+2 * Wire diameter. ELSEIF(INPCMP(J,'D#IAMETER').NE.0)THEN IF(J+1.GT.NWORD.OR.INPTYP(J+1).LE.0)THEN CALL INPMSG(I,'Needs one numeric argument. ') IF(INPTYP(J+1).LE.0)THEN INEXT=J+1 ELSE INEXT=J+2 ENDIF GOTO 70 ENDIF CALL INPCHK(J+1,2,IFAIL1) IF(IFAIL1.EQ.0)THEN CALL INPRDR(J+1,DWIR,0.01) IF(DENWIR.LE.0)CALL INPMSG(J+1, - 'The diameter must be > 0.') ENDIF INEXT=J+2 * Density. ELSEIF(INPCMP(J,'DENS#ITY')+INPCMP(J,'MAT#ERIAL').NE.0)THEN IF(J+1.GT.NWORD)THEN CALL INPMSG(J,'Has an argument.') INEXT=J+1 ELSEIF(INPCMP(J+1,'CU-BE#RYLLIUM')+ - INPCMP(J+1,'C#OPPER-BE#RYLLIUM')+ - INPCMP(J+1,'BE#RYLLIUM-#CU')+ - INPCMP(J+1,'BE#RYLLIUM-#COPPER').NE.0)THEN DENWIR=8.7 INEXT=J+2 ELSEIF(INPTYP(J+1).EQ.4.OR.INPCMP(J+1,'W')+ - INPCMP(J+1,'TUNG#STEN').NE.0)THEN DENWIR=19.3 INEXT=J+2 ELSEIF(INPTYP(J+1).EQ.1.OR.INPTYP(J+1).EQ.2)THEN CALL INPCHK(J+1,2,IFAIL1) CALL INPRDR(J+1,DENWIR,19.3) IF(DENWIR.LE.0)CALL INPMSG(J+1, - 'The density must be > 0.') INEXT=J+2 ELSE CALL INPMSG(J+1,'Not a valid argument.') INEXT=J+2 ENDIF * Length. ELSEIF(INPCMP(J,'L#ENGTH').NE.0)THEN IF(J+1.GT.NWORD.OR.INPTYP(J+1).LE.0)THEN CALL INPMSG(I,'Needs one numeric argument. ') IF(INPTYP(J+1).LE.0)THEN INEXT=J+1 ELSE INEXT=J+2 ENDIF GOTO 70 ENDIF CALL INPCHK(J+1,2,IFAIL1) IF(IFAIL1.EQ.0)THEN CALL INPRDR(J+1,UWIR,100.0) IF(UWIR.LE.0)CALL INPMSG(J+1, - 'The length must be > 0.') ENDIF INEXT=J+2 * Weight. ELSEIF(INPCMP(J,'W#EIGHT')+INPCMP(J,'TENS#ION').NE.0)THEN IF(J+1.GT.NWORD.OR.INPTYP(J+1).LE.0)THEN CALL INPMSG(I,'Needs one numeric argument. ') IF(INPTYP(J+1).LE.0)THEN INEXT=J+1 ELSE INEXT=J+2 ENDIF GOTO 70 ENDIF CALL INPCHK(J+1,2,IFAIL1) IF(IFAIL1.EQ.0)THEN CALL INPRDR(J+1,WWIR,50.0) IF(WWIR.LE.0)CALL INPMSG(J+1, - 'The weight must be > 0.') ENDIF INEXT=J+2 * Back to main category. ELSEIF(INPCMP(J,'PE#RIODICITY')+INPCMP(J,'PL#ANE')+ - INPCMP(J,'W#IRE').NE.0)THEN GOTO 80 * Unrecognised keyword. ELSE CALL INPMSG(J,'Not a valid keyword.') ENDIF 70 CONTINUE * Check whether sufficient data were provided. 80 CONTINUE IF(IXYSET.EQ.0.OR.WIRCDE.EQ.'?')THEN CALL INPMSG(I,'Incompletely specified wire.') ELSEIF(DWIR.LE.0.OR.UWIR.LE.0.OR.WWIR.LE.0.OR. - DENWIR.LE.0)THEN CALL INPMSG(I,'Invalid wire specification.') ELSEIF(NWIRE.GE.MXWIRE)THEN CALL INPMSG(I,'No room for further wires.') ELSE NWIRE=NWIRE+1 X(NWIRE)=XWIR Y(NWIRE)=YWIR V(NWIRE)=VWIR D(NWIRE)=DWIR U(NWIRE)=UWIR W(NWIRE)=WWIR DENS(NWIRE)=DENWIR WIRTYP(NWIRE)=WIRCDE INDSW(NWIRE)=0 IF(POLAR)THEN D(NWIRE)=D(NWIRE)/X(NWIRE) CALL CFMPTR(X(NWIRE),Y(NWIRE),X(NWIRE),Y(NWIRE),1, - IFAIL1) IF(IFAIL1.NE.0)THEN CALL INPMSG(I, - 'Invalid polar position. ') NWIRE=NWIRE-1 ENDIF ENDIF CHANGE=.TRUE. ENDIF ** Unrecognised argument. ELSE CALL INPMSG(I,'Not PERIOD, PLANE or WIRE. ') ENDIF 10 CONTINUE CALL INPERR END +DECK,OPTBGF. SUBROUTINE OPTBGF *----------------------------------------------------------------------- * OPTBGF - Adds a background field. * (Last changed on 5/ 4/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,PRINTPLOT. CHARACTER*(MXCHAR) STRV,STREX,STREY,STREZ CHARACTER*10 VARLIS(MXVAR),USER INTEGER NWORD,I,INEXT,INPCMP,NVAR,NCFV,NCFEX,NCFEY,NCFEZ,NRES, - IFAIL1 LOGICAL USE(MXVAR),OK EXTERNAL INPCMP +SELF,IF=SAVE. SAVE STRV,STREX,STREY,STREZ,NCFV,NCFEX,NCFEY,NCFEZ +SELF. DATA NCFV,NCFEX,NCFEY,NCFEZ /0,0,0,0/ *** Identify the routine. IF(LIDENT)PRINT *,' /// ROUTINE OPTBGF ///' *** Count words. CALL INPNUM(NWORD) *** Display current state if there are no arguments. IF(NWORD.EQ.1)THEN IF(IENBGF.LE.0)THEN WRITE(LUNOUT,'('' Currently no background field.'')') ELSE WRITE(LUNOUT,'('' Currently the background field'', - '' is:''//'' potential: '',A/'' Ex: '', - A/'' Ey: '',A/'' Ez: '',A)') - STRV(1:MAX(1,NCFV)),STREX(1:MAX(1,NCFEX)), - STREY(1:MAX(1,NCFEY)),STREZ(1:MAX(1,NCFEZ)) ENDIF RETURN ENDIF *** Set the list of variables. IF(POLAR)THEN VARLIS(1)='R' VARLIS(2)='PHI' VARLIS(3)='Z' VARLIS(4)='EXMAP' VARLIS(5)='EYMAP' VARLIS(6)='EZMAP' VARLIS(7)='VMAP' ELSE VARLIS(1)='X' VARLIS(2)='Y' VARLIS(3)='Z' VARLIS(4)='EXMAP' VARLIS(5)='EYMAP' VARLIS(6)='EZMAP' VARLIS(7)='VMAP' ENDIF NVAR=7 *** Preset the strings. STRV=' ' NCFV=0 STREX=' ' NCFEX=0 STREY=' ' NCFEY=0 STREZ=' ' NCFEZ=0 *** Delete old entry points if present. IF(IENBGF.NE.0)CALL ALGCLR(IENBGF) IENBGF=0 LBGFMP=.FALSE. *** Loop over the components. OK=.TRUE. INEXT=2 DO 10 I=2,NWORD IF(I.LT.INEXT)GOTO 10 *** Pick up the field components. IF(INPCMP(I,'V#OLTAGE')+INPCMP(I,'POT#ENTIAL').NE.0)THEN CALL INPSTR(I+1,I+1,STRV,NCFV) INEXT=I+2 ELSEIF(INPCMP(I,'EX').NE.0)THEN CALL INPSTR(I+1,I+1,STREX,NCFEX) INEXT=I+2 ELSEIF(INPCMP(I,'EY').NE.0)THEN CALL INPSTR(I+1,I+1,STREY,NCFEY) INEXT=I+2 ELSEIF(INPCMP(I,'EZ').NE.0)THEN CALL INPSTR(I+1,I+1,STREZ,NCFEZ) INEXT=I+2 ELSE CALL INPMSG(I,'Not a known field.') OK=.FALSE. ENDIF 10 CONTINUE *** Dump error messages. CALL INPERR *** Check that all fields are present. IF(NCFV.LE.0)THEN PRINT *,' ------ OPTBGF MESSAGE : Potential of the'// - ' background field is missing; set to 0.' STRV='0' NCFV=1 OK=.FALSE. ENDIF IF(NCFEX.LE.0)THEN PRINT *,' ------ OPTBGF MESSAGE : Ex of the'// - ' background field is missing; set to 0.' STREX='0' NCFEX=1 OK=.FALSE. ENDIF IF(NCFEY.LE.0)THEN PRINT *,' ------ OPTBGF MESSAGE : Ey of the'// - ' background field is missing; set to 0.' STREY='0' NCFEY=1 OK=.FALSE. ENDIF IF(NCFEZ.LE.0)THEN PRINT *,' ------ OPTBGF MESSAGE : Ez of the'// - ' background field is missing; set to 0.' STREZ='0' NCFEZ=1 ENDIF *** See whether we continue. IF(JFAIL.EQ.2.AND..NOT.OK)THEN PRINT *,' ###### OPTBGF ERROR : No background field'// - ' because of the above errors.' IENBGF=0 RETURN ELSEIF(JFAIL.EQ.3.AND..NOT.OK)THEN PRINT *,' ###### OPTBGF ERROR : Program terminated'// - ' because of the above errors.' CALL QUIT RETURN ENDIF *** Reset the error flag. OK=.TRUE. *** Translate the background field. IF(INDEX(STRV(1:NCFV)//','//STREX(1:NCFEX)//','//STREY(1:NCFEY) - //','//STREZ(1:NCFEZ),'@').NE.0)THEN NRES=4 PRINT *,' ------ OPTBGF MESSAGE : Please edit the'// - ' function.' CALL ALGEDT(VARLIS,NVAR,IENBGF,USE,NRES) IFAIL1=0 * Usual function translation if not. ELSE CALL ALGPRE(STRV(1:NCFV)//','//STREX(1:NCFEX)//','// - STREY(1:NCFEY)//','//STREZ(1:NCFEZ), - NCFV+NCFEX+NCFEY+NCFEZ+3,VARLIS,NVAR,NRES,USE, - IENBGF,IFAIL1) ENDIF * Check return code of translation. IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! OPTBGF WARNING : Error translating the'// - ' field functions.' OK=.FALSE. CALL ALGCLR(IENBGF) ENDIF * Check number of results returned by the function. IF(NRES.NE.4)THEN PRINT *,' !!!!!! OPTBGF WARNING : The field functions do'// - ' not return 4 results.' OK=.FALSE. CALL ALGCLR(IENBGF) ENDIF * Check use of field map. IF(USE(4).OR.USE(5).OR.USE(6).OR.USE(7))THEN CALL BOOK('INQUIRE','MAP',USER,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! OPTBGF WARNING : Unable to'// - ' find out who owns the field map; background'// - ' field rejected.' OK=.FALSE. CALL ALGCLR(IENBGF) ELSEIF(USER.EQ.'CELL')THEN PRINT *,' !!!!!! OPTBGF WARNING : Field map is used'// - ' as main field; background field rejected.' OK=.FALSE. CALL ALGCLR(IENBGF) ELSEIF(USER.NE.'OPTIMISE')THEN PRINT *,' !!!!!! OPTBGF WARNING : No background'// - ' field map available ; background field'// - ' rejected.' OK=.FALSE. CALL ALGCLR(IENBGF) ELSEIF(POLAR)THEN PRINT *,' !!!!!! OPTBGF WARNING : Background fields'// - ' no available in polar cells; background field'// - ' rejected.' OK=.FALSE. CALL ALGCLR(IENBGF) ELSE LBGFMP=.TRUE. ENDIF ENDIF *** See whether we continue. IF(JFAIL.EQ.2.AND..NOT.OK)THEN PRINT *,' ###### OPTBGF ERROR : No background field'// - ' because of the above errors.' IENBGF=0 RETURN ELSEIF(JFAIL.EQ.3.AND..NOT.OK)THEN PRINT *,' ###### OPTBGF ERROR : Program terminated'// - ' because of the above errors.' CALL QUIT RETURN ENDIF END +DECK,OPTCHV. SUBROUTINE OPTCHV *----------------------------------------------------------------------- * OPTCHV - Changes voltages. * (Last changed on 20/10/99.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. +SEQ,CELLDATA. INTEGER INPCMP,INPTYP,I,J,NWORD,INEXT,IWIRE,IFAIL,IFAIL1,IFAIL2, - NC,IPLANE,NFOUND REAL VNEW(MXWIRE),VPLNEW(5),VREAD CHARACTER*(MXCHAR) CODE LOGICAL OK EXTERNAL INPCMP,INPTYP *** Original settings for wires, planes and tube. DO 20 I=1,NWIRE VNEW(I)=V(I) 20 CONTINUE DO 30 I=1,4 VPLNEW(I)=VTPLAN(I) 30 CONTINUE VPLNEW(5)=VTTUBE *** Decode the argument string. CALL INPNUM(NWORD) * Check there are at least some words on the line. IF(NWORD.LE.1)THEN PRINT *,' !!!!!! OPTCHV WARNING : This instruction needs'// - ' arguments; nothing done.' RETURN ENDIF ** Keep track of errors. OK=.TRUE. ** Loop over the arguments. INEXT=2 DO 10 I=1,NWORD IF(I.LT.INEXT)GOTO 10 ** Wire selection. IF(INPCMP(I,'W#IRE').NE.0)THEN * Ensure the wire is specified. IF(NWORD.LT.I+1)THEN CALL INPMSG(I,'The wire should be specified.') IWIRE=0 * Read the wire number. ELSEIF(INPTYP(I+1).EQ.1)THEN CALL INPCHK(I+1,1,IFAIL1) IF(IFAIL1.EQ.0)THEN CALL INPRDI(I+1,IWIRE,0) IF(IWIRE.LE.0.OR.IWIRE.GT.NWIRE)THEN CALL INPMSG(I+1,'Wire number out of range.') IWIRE=0 OK=.FALSE. ENDIF ELSE IWIRE=0 ENDIF * Read the wire code. ELSE CALL INPSTR(I+1,I+1,CODE,NC) IF(INDEX('ABCDEFGHIJKLMNOPQRSTUVWXYZ',CODE(1:1)) - .EQ.0)THEN CALL INPMSG(I+1,'Not a valid wire code.') OK=.FALSE. IWIRE=0 ELSE IWIRE=-1 ENDIF IF(NC.GT.1) - CALL INPMSG(I+1,'Only first character used. ') ENDIF ** Read the new voltage. IF(INPCMP(I+2,'V#OLTAGE').EQ.0.OR.NWORD.LT.I+3)THEN CALL INPMSG(I,'The voltage is missing.') OK=.FALSE. INEXT=I+2 GOTO 10 ELSE CALL INPCHK(I+3,2,IFAIL2) CALL INPRDR(I+3,VREAD,0.0) ENDIF * Store the result in the proper location. IF(IWIRE.GT.0.AND.IWIRE.LE.NWIRE)THEN VNEW(IWIRE)=VREAD ELSEIF(IWIRE.EQ.-1)THEN NFOUND=0 DO 40 J=1,NWIRE IF(WIRTYP(J).EQ.CODE(1:1))THEN VNEW(J)=VREAD NFOUND=NFOUND+1 ENDIF 40 CONTINUE IF(NFOUND.EQ.0)THEN CALL INPMSG(I+1,'No such wire.') OK=.FALSE. ENDIF ENDIF * And increment the word. INEXT=I+4 ** Plane selection. ELSEIF(INPCMP(I,'PL#ANE').NE.0)THEN * Ensure the plane is specified. IF(NWORD.LT.I+1)THEN CALL INPMSG(I,'The plane should be specified.') IPLANE=0 * Read the plane number. ELSEIF(INPTYP(I+1).EQ.1)THEN CALL INPCHK(I+1,1,IFAIL1) IF(IFAIL1.EQ.0)THEN CALL INPRDI(I+1,IPLANE,0) IPLANE=ABS(IPLANE) IF(IPLANE.LE.0.OR.IPLANE.GT.5)THEN CALL INPMSG(I+1,'Plane number out of range.') IPLANE=0 OK=.FALSE. ENDIF ELSE IPLANE=0 ENDIF * Plane selection by name. ELSEIF(INPCMP(I+1,'LOW#ER-X')+INPCMP(I+1,'L#EFT').NE.0)THEN IF(.NOT.YNPLAN(1))THEN CALL INPMSG(I+1,'No such plane.') OK=.FALSE. ELSE IPLANE=1 ENDIF ELSEIF(INPCMP(I+1,'UP#PER-X')+INPCMP(I+1,'R#IGHT').NE.0)THEN IF(.NOT.YNPLAN(2))THEN CALL INPMSG(I+1,'No such plane.') OK=.FALSE. ELSE IPLANE=2 ENDIF ELSEIF(INPCMP(I+1,'LOW#ER-Y')+ - INPCMP(I+1,'B#OTTOM').NE.0)THEN IF(.NOT.YNPLAN(3))THEN CALL INPMSG(I+1,'No such plane.') OK=.FALSE. ELSE IPLANE=3 ENDIF ELSEIF(INPCMP(I+1,'UP#PER-X')+INPCMP(I+1,'T#OP').NE.0)THEN IF(.NOT.YNPLAN(4))THEN CALL INPMSG(I+1,'No such plane.') OK=.FALSE. ELSE IPLANE=4 ENDIF ELSEIF(INPCMP(I+1,'TUBE').NE.0)THEN IF(.NOT.TUBE)THEN CALL INPMSG(I+1,'No tube in this cell.') OK=.FALSE. ELSE IPLANE=5 ENDIF * Read the PLANE code. ELSE CALL INPSTR(I+1,I+1,CODE,NC) IF(INDEX('ABCDEFGHIJKLMNOPQRSTUVWXYZ',CODE(1:1)) - .EQ.0)THEN CALL INPMSG(I+1,'Not a valid plane code.') IPLANE=0 OK=.FALSE. ELSE IPLANE=-1 ENDIF IF(NC.GT.1) - CALL INPMSG(I+1,'Only first character used.') ENDIF ** Read the new voltage. IF(INPCMP(I+2,'V#OLTAGE').EQ.0.OR.NWORD.LT.I+3)THEN CALL INPMSG(I,'The voltage is missing.') INEXT=I+2 OK=.FALSE. GOTO 10 ELSE CALL INPCHK(I+3,2,IFAIL2) CALL INPRDR(I+3,VREAD,0.0) ENDIF * Store the result in the proper location. IF(IPLANE.GE.1.AND.IPLANE.LE.5)THEN VPLNEW(IPLANE)=VREAD ELSEIF(IPLANE.EQ.-1)THEN NFOUND=0 DO 50 J=1,5 IF(PLATYP(J).EQ.CODE(1:1))THEN VPLNEW(J)=VREAD NFOUND=NFOUND+1 ENDIF 50 CONTINUE IF(NFOUND.EQ.0)THEN CALL INPMSG(I+1,'No such plane.') OK=.FALSE. ENDIF ENDIF * And increment the word. INEXT=I+4 ** Tube selection. ELSEIF(INPCMP(I,'TUBE').NE.0)THEN ** Read the new voltage. IF(INPCMP(I+1,'V#OLTAGE').EQ.0.OR.NWORD.LT.I+2)THEN CALL INPMSG(I,'The voltage is missing.') INEXT=I+1 OK=.FALSE. GOTO 10 ELSE CALL INPCHK(I+2,2,IFAIL2) CALL INPRDR(I+2,VREAD,0.0) ENDIF * Store the result in the proper location. IF(TUBE)THEN VPLNEW(5)=VREAD ELSE CALL INPMSG(I,'No tube in this cell.') OK=.FALSE. ENDIF * And increment the word. INEXT=I+3 ** Valid keyword out of context. ELSEIF(INPCMP(I,'V#OLTAGE').NE.0)THEN CALL INPMSG(I,'Valid keyword out of context. ') OK=.FALSE. * Invalid keywords. ELSE CALL INPMSG(I,'Not a valid keyword. ') OK=.FALSE. ENDIF 10 CONTINUE *** Dump error messages. CALL INPERR *** Take action depending on the state of OK. IF(.NOT.OK)THEN IF(JFAIL.EQ.1)THEN PRINT *,' !!!!!! OPTCHV WARNING : Errors found in'// - ' the command; performing a partial update.' ELSEIF(JFAIL.EQ.2)THEN PRINT *,' !!!!!! OPTCHV WARNING : Errors found in'// - ' the command; not changing any voltages.' RETURN ELSE PRINT *,' !!!!!! OPTCHV WARNING : Errors found in'// - ' the command; terminating program execution.' CALL QUIT ENDIF ENDIF *** Set new voltages. CALL SETNEW(VNEW,VPLNEW,IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' ###### OPTCHV ERROR : Voltage change failed;'// - ' cell deleted.' CELSET=.FALSE. ENDIF END +DECK,OPTDEL. SUBROUTINE OPTDEL(CHANGE) *----------------------------------------------------------------------- * OPTDEL - This routine removes items from the cell. *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. +SEQ,CELLDATA. INTEGER INPCMP EXTERNAL INPCMP LOGICAL CHANGE *** Doesn't yet do anything. PRINT *,' ###### OPTDEL ERROR : Instruction not yet released.' END +DECK,OPTFRC. SUBROUTINE OPTFRC *----------------------------------------------------------------------- * OPTFRC - Studies the electrostatic forces on a wire. * (Last changed on 21/10/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,CONSTANTS. +SEQ,PRINTPLOT. +SEQ,SHAPEDATA. INTEGER INPCMP,INPTYP,IX,IY,INEXT,IFAIL1,ISIZ(2),IDIM(2),IIW, - IFAIL2,IFAIL3,IFAIL4,I,J,II,JJ,NXR,NYR,NC,NWORD,IFAIL,JW, - NSAG,NSHOTR,NSTEPR,NC1,NC2,NC3,NC4,NC5,NC6,NC7,NC8,NC9,NC10, - NC11,NC12,JSORDR,IWR,ITER,NFITRR,IOS,IMAX,JMAX REAL XPL(MXGRID),YPL(MXGRID),XSAG(0:MXLIST),YSAG(0:MXLIST), - CSAG(0:MXLIST),XNEAR,YNEAR,SHIFTX,SHIFTY,CORR, - FX0,FY0,XSAGMX,YSAGMX,XSAGAV,YSAGAV,XSAGMI,YSAGMI, - BXMIN,BYMIN,BXMAX,BYMAX,SXMIN,SYMIN,SXMAX,SYMAX,EX,EY, - FXMIN,FXMAX,FYMIN,FYMAX,FSXMIN,FSYMIN,FSXMAX,FSYMAX, - SXMINR,SXMAXR,SYMINR,SYMAXR,SFACT,SFACTR,XOFFR,YOFFR,TOLER, - TOLERR,CORMAX DOUBLE PRECISION WLENG,SS CHARACTER*20 AUXSTR,AUX1,AUX2,AUX3,AUX4,AUX5,AUX6,AUX7,AUX8,AUX9, - AUX10,AUX11,AUX12 LOGICAL LFAST,LSAGPR,LSAGPL,LSAGKP,LFRCPR,LFRCPL,LFRCKP,INAREA, - OK,SFORCE,SLARGE,CONVIT,LSTAB EXTERNAL INPCMP,INPTYP +SELF,IF=SAVE. SAVE LFAST,LSAGPR,LSAGPL,LSAGKP,LFRCPR,LFRCPL,LFRCKP,LSTAB +SELF. DATA LFAST /.FALSE./, LSTAB /.FALSE./, - LSAGPR /.TRUE./ , LSAGPL /.FALSE./, LSAGKP /.FALSE./, - LFRCPR /.FALSE./, LFRCPL /.FALSE./, LFRCKP /.FALSE./ *** Routine identification. IF(LIDENT)PRINT *,' /// ROUTINE OPTFRC ///' *** Check for polar cells. IF(POLAR)THEN PRINT *,' !!!!!! OPTFRC WARNING : This instruction is not'// - ' able to handle polar cells.' RETURN ENDIF *** General purpose parameters. SFORCE=.FALSE. SLARGE=.FALSE. SFACT=2.0 *** Number of shots and number of intermediate steps. NSHOT=2 NSTEP=20 *** Differentiation parameter, iterations, convergence criteria. EPS=1.0E-4 NITMAX=100 EPSX=1E-4 EPSF=1E-4 JSORD=2 NSCANX=MIN(11,MXGRID) NSCANY=MIN(11,MXGRID) *** Terms to be included. LFELEC=.TRUE. LFGRAV=.TRUE. *** Permit extrapolation or not. LFEXTR=.FALSE. *** Print flag for debugging purposes. LZROPR=.FALSE. *** Iterate over all wires or not, update for such iterations. LFITER=NSW.GT.1 NFITER=5 TOLER=0.0010 *** Store nominal wire position and preset wire offset. DO 5 I=1,NWIRE XORIG(I)=X(I) YORIG(I)=Y(I) XOFF(I)=0 YOFF(I)=0 5 CONTINUE *** Decode the argument list. CALL INPNUM(NWORD) INEXT=2 DO 10 I=2,NWORD IF(I.LT.INEXT)GOTO 10 * Printing. IF(INPCMP(I,'PR#INT-S#AG').NE.0)THEN LSAGPR=.TRUE. ELSEIF(INPCMP(I,'NOPR#INT-S#AG').NE.0)THEN LSAGPR=.FALSE. ELSEIF(INPCMP(I,'PR#INT-F#ORCES').NE.0)THEN LFRCPR=.TRUE. ELSEIF(INPCMP(I,'NOPR#INT-F#ORCES').NE.0)THEN LFRCPR=.FALSE. ELSEIF(INPCMP(I,'PR#INT-Z#ERO-#SEARCH').NE.0)THEN LZROPR=.TRUE. ELSEIF(INPCMP(I,'NOPR#INT-Z#ERO-#SEARCH').NE.0)THEN LZROPR=.FALSE. * Plotting. ELSEIF(INPCMP(I,'PL#OT-S#AG').NE.0)THEN LSAGPL=.TRUE. ELSEIF(INPCMP(I,'NOPL#OT-S#AG').NE.0)THEN LSAGPL=.FALSE. ELSEIF(INPCMP(I,'PL#OT-F#ORCES').NE.0)THEN LFRCPL=.TRUE. ELSEIF(INPCMP(I,'NOPL#OT-F#ORCES').NE.0)THEN LFRCPL=.FALSE. * Option to keep the results. ELSEIF(INPCMP(I,'KEEP-S#AG').NE.0)THEN LSAGKP=.TRUE. ELSEIF(INPCMP(I,'NOKEEP-S#AG').NE.0)THEN LSAGKP=.FALSE. ELSEIF(INPCMP(I,'KEEP-F#ORCES').NE.0)THEN LFRCKP=.TRUE. ELSEIF(INPCMP(I,'NOKEEP-F#ORCES').NE.0)THEN LFRCKP=.FALSE. ELSEIF(INPCMP(I,'KEEP-R#ESULTS').NE.0)THEN LSAGKP=.TRUE. LFRCKP=.TRUE. ELSEIF(INPCMP(I,'NOKEEP-R#ESULTS').NE.0)THEN LSAGKP=.FALSE. LFRCKP=.FALSE. * Inclusion or not of gravity and electrostatics. ELSEIF(INPCMP(I,'GRAV#ITY').NE.0)THEN LFGRAV=.TRUE. ELSEIF(INPCMP(I,'NOGRAV#ITY').NE.0)THEN LFGRAV=.FALSE. ELSEIF(INPCMP(I,'ELEC#TROSTATICS').NE.0)THEN LFELEC=.TRUE. ELSEIF(INPCMP(I,'NOELEC#TROSTATICS').NE.0)THEN LFELEC=.FALSE. * Detailed or fast calculation. ELSEIF(INPCMP(I,'DET#AILED').NE.0)THEN LFAST=.FALSE. ELSEIF(INPCMP(I,'FAST').NE.0)THEN LFAST=.TRUE. * Check for wire stability or not. ELSEIF(INPCMP(I,'CH#ECK-STAB#ILITY')+ - INPCMP(I,'STAB#ILITY-#CHECK').NE.0)THEN LSTAB=.TRUE. ELSEIF(INPCMP(I,'NOCH#ECK-STAB#ILITY')+ - INPCMP(I,'NOSTAB#ILITY-#CHECK').NE.0)THEN LSTAB=.FALSE. * Iterate or not. ELSEIF(INPCMP(I,'ITER#ATE').NE.0)THEN LFITER=.TRUE. IF(INPTYP(I+1).EQ.1)THEN CALL INPCHK(I+1,1,IFAIL1) CALL INPRDI(I+1,NFITRR,5) IF(NFITRR.GE.1)THEN NFITER=NFITRR ELSE CALL INPMSG(I+1,'Should be > 0.') ENDIF INEXT=I+2 ENDIF ELSEIF(INPCMP(I,'NOITER#ATE').NE.0)THEN LFITER=.FALSE. NFITER=0 * Extrapolate or not beyond scanning area. ELSEIF(INPCMP(I,'EXTR#APOLATE').NE.0)THEN LFEXTR=.TRUE. ELSEIF(INPCMP(I,'NOEXTR#APOLATE').NE.0)THEN LFEXTR=.FALSE. * Scanning size. ELSEIF(INPCMP(I,'SCAN#NING-GR#ID').NE.0)THEN IF(INPTYP(I+1).EQ.4)THEN INEXT=I+2 IFAIL1=0 ELSEIF(INPTYP(I+1).EQ.1)THEN CALL INPCHK(I+1,1,IFAIL1) CALL INPRDI(I+1,NXR,NSCANX) IF(IFAIL1.EQ.0.AND.NXR.GT.1.AND.NXR.LE.MXGRID)THEN NSCANX=NXR IF(INPTYP(I+2).NE.1.AND. - INPTYP(I+2).NE.4)NSCANY=NXR ELSE IFAIL1=1 CALL INPMSG(I+1,'Should be 1 < n <= MXGRID') ENDIF INEXT=I+2 ELSE IFAIL1=1 ENDIF IF(IFAIL1.EQ.0.AND.INPTYP(I+2).EQ.4)THEN INEXT=I+3 ELSEIF(IFAIL1.EQ.0.AND.INPTYP(I+2).EQ.1)THEN CALL INPCHK(I+2,1,IFAIL1) CALL INPRDI(I+2,NYR,NSCANY) IF(IFAIL1.EQ.0.AND.NYR.GT.1.AND.NYR.LE.MXGRID)THEN NSCANY=NYR ELSE CALL INPMSG(I+2,'Should be 1 < n <= MXGRID') ENDIF INEXT=I+3 ENDIF * Scanning area. ELSEIF(INPCMP(I,'SCAN#NING-A#REA').NE.0)THEN IF(INPCMP(I+1,'MAX#IMAL')+INPCMP(I+1,'MAX#IMUM')+ - INPCMP(I+1,'LARG#EST').NE.0)THEN SLARGE=.TRUE. SFORCE=.FALSE. INEXT=I+2 ELSEIF(INPCMP(I+1,'F#IRST-ORD#ER-#ENLARGED-#BY')+ - INPCMP(I+1,'ENL#ARGED-#BY').NE.0)THEN IF(NWORD.GE.I+2.AND. - (INPTYP(I+2).EQ.1.OR.INPTYP(I+2).EQ.2))THEN CALL INPCHK(I+2,2,IFAIL1) CALL INPRDR(I+2,SFACTR,2.0) IF(SFACTR.LE.0)THEN CALL INPMSG(I+1,'Should be > 0.') ELSE SFACT=SFACTR ENDIF INEXT=I+3 ELSEIF(NWORD.GE.I+2.AND.INPTYP(I+2).EQ.4)THEN SFACT=2.0 INEXT=I+3 ELSE SFACT=2.0 INEXT=I+2 ENDIF SFORCE=.FALSE. SLARGE=.FALSE. ELSEIF((INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2).OR. - (INPTYP(I+2).NE.1.AND.INPTYP(I+2).NE.2).OR. - (INPTYP(I+3).NE.1.AND.INPTYP(I+3).NE.2).OR. - (INPTYP(I+4).NE.1.AND.INPTYP(I+4).NE.2))THEN CALL INPMSG(I,'Incorrect set of arguments.') ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPCHK(I+2,2,IFAIL2) CALL INPCHK(I+3,2,IFAIL3) CALL INPCHK(I+4,2,IFAIL4) CALL INPRDR(I+1,SXMINR,0.0) CALL INPRDR(I+2,SYMINR,0.0) CALL INPRDR(I+3,SXMAXR,0.0) CALL INPRDR(I+4,SYMAXR,0.0) SFORCE=.TRUE. IF(IFAIL1.EQ.0.AND.IFAIL2.EQ.0.AND. - SXMINR.EQ.SXMAXR)THEN CALL INPMSG(I+1,'Zero range not permitted.') CALL INPMSG(I+2,'See previous message.') SFORCE=.FALSE. ELSE FSXMIN=MIN(SXMINR,SXMAXR) FSXMAX=MAX(SXMINR,SXMAXR) ENDIF IF(IFAIL3.EQ.0.AND.IFAIL4.EQ.0.AND. - SYMINR.EQ.SYMAXR)THEN CALL INPMSG(I+3,'Zero range not permitted.') CALL INPMSG(I+4,'See previous message.') SFORCE=.FALSE. ELSE FSYMIN=MIN(SYMINR,SYMAXR) FSYMAX=MAX(SYMINR,SYMAXR) ENDIF SLARGE=.FALSE. INEXT=I+5 ENDIF * Initial wire offsets. ELSEIF(INPCMP(I,'OFF#SET').NE.0)THEN IF(INPTYP(I+1).NE.1.OR. - (INPTYP(I+2).NE.1.AND.INPTYP(I+2).NE.2).OR. - (INPTYP(I+3).NE.1.AND.INPTYP(I+3).NE.2))THEN CALL INPMSG(I,'Incorrect set of arguments.') ELSE CALL INPCHK(I+1,1,IFAIL1) CALL INPCHK(I+2,2,IFAIL2) CALL INPCHK(I+3,2,IFAIL3) CALL INPRDI(I+1,IWR,0) CALL INPRDR(I+2,XOFFR,0.0) CALL INPRDR(I+3,YOFFR,0.0) IF(IFAIL1.EQ.0.AND.IFAIL2.EQ.0.AND.IFAIL3.EQ.0.AND. - (IWR.LE.0.OR.IWR.GT.NWIRE))THEN CALL INPMSG(I+1,'Wire number out of range.') ELSEIF(IFAIL1.EQ.0.AND.IFAIL2.EQ.0.AND.IFAIL3.EQ.0)THEN XOFF(IWR)=XOFFR YOFF(IWR)=YOFFR ENDIF INEXT=I+4 ENDIF * Shots and steps per shot. ELSEIF(INPCMP(I,'SHOT#S').NE.0)THEN IF(NWORD.LT.I+1.OR.INPTYP(I+1).NE.1)THEN CALL INPMSG(I,'The argument is missing') ELSE CALL INPCHK(I+1,1,IFAIL1) CALL INPRDI(I+1,NSHOTR,NSHOT) IF(NSHOTR.GE.0)THEN NSHOT=NSHOTR ELSE CALL INPMSG(I+1,'Must be at least 0.') ENDIF INEXT=I+2 ENDIF ELSEIF(INPCMP(I,'STEP#S-#PER-#SHOT').NE.0)THEN IF(NWORD.LT.I+1.OR.INPTYP(I+1).NE.1)THEN CALL INPMSG(I,'The argument is missing') ELSE CALL INPCHK(I+1,1,IFAIL1) CALL INPRDI(I+1,NSTEPR,NSTEP) IF(NSTEPR.GE.1)THEN NSTEP=NSTEPR ELSE CALL INPMSG(I+1,'Must be at least 1.') ENDIF INEXT=I+2 ENDIF * Interpolation order. ELSEIF(INPCMP(I,'INT#ERPOLATION-ORD#ER').NE.0)THEN IF(NWORD.LT.I+1.OR.INPTYP(I+1).NE.1)THEN CALL INPMSG(I,'The argument is missing') ELSE CALL INPCHK(I+1,1,IFAIL1) CALL INPRDI(I+1,JSORDR,JSORD) IF(JSORDR.GE.1.AND.JSORDR.LE.10)THEN JSORD=JSORDR ELSE CALL INPMSG(I+1,'Must be at in the range [1,10]') ENDIF INEXT=I+2 ENDIF * Wire shift tolerance. ELSEIF(INPCMP(I,'TOL#ERANCE').NE.0)THEN IF(NWORD.LT.I+1.OR.( - INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2))THEN CALL INPMSG(I,'The argument is missing') ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,TOLERR,0.0010) IF(TOLERR.GT.0)THEN TOLER=TOLERR ELSE CALL INPMSG(I+1,'Must be > 0') ENDIF INEXT=I+2 ENDIF * Unrecognised keywords. ELSE CALL INPMSG(I,'Not a known keyword.') ENDIF * Next keyword. 10 CONTINUE *** Dump the error messages. CALL INPERR *** Check interpolation order compared with grid size. IF(JSORD.GT.NSCANX-1.OR.JSORD.GT.NSCANY-1.OR.JSORD.LT.1)THEN JSORD=MIN(NSCANX-1,NSCANY-1,JSORD) IF(JSORD.LT.1)JSORD=1 PRINT *,' !!!!!! OPTFRC WARNING : Interpolation order'// - ' larger than scanning grid size; reduced to ',JSORD ENDIF *** Debugging output. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ OPTFRC DEBUG : Settings'', - '' of options:''// - 26X,''0th Order only: '',L1/ - 26X,''Plot forces: '',L1/ - 26X,''Print force table: '',L1/ - 26X,''Store forces: '',L1/ - 26X,''Plot wire sag: '',L1/ - 26X,''Print wire sag: '',L1/ - 26X,''Store wire sag: '',L1)') - LFAST,LFRCPL,LFRCPR,LFRCKP,LSAGPL,LSAGPR,LSAGKP IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ OPTFRC DEBUG : Settings'', - '' of parameters:''// - 26X,''Number of shots: '',I5/ - 26X,''Steps per shot: '',I5/ - 26X,''Epsilon differentials: '',E10.3/ - 26X,''Position convergence: '',E10.3/ - 26X,''Function convergence: '',E10.3/ - 26X,''Zero search iterations: '',I5/ - 26X,''Zero search printing: '',L5/ - 26X,''Permit extrapolation: '',L5/ - 26X,''Do all-wire iterations: '',L5/ - 26X,''# all-wire iterations: '',I5/ - 26X,''Maximum scanning area: '',L5/ - 26X,''Scanning area enlarging: '',E10.3/ - 26X,''Forced scanning area: '',L5/ - 26X,''User scanning area: '',4E10.3/ - 26X,''Scanning grid density: '',2I5)') - NSHOT,NSTEP,EPS,EPSX,EPSF,NITMAX,LZROPR,LFEXTR,LFITER, - NFITER,SLARGE,SFACT,SFORCE,FSXMIN,FSYMIN,FSXMAX,FSYMAX, - NSCANX,NSCANY *** Return here for a further loop. CALL LOGSAV(.TRUE.,'OK',IFAIL1) ITER=0 CONVIT=.NOT.LFITER 1000 CONTINUE * Increment iteration counter. ITER=ITER+1 * Reset larges wire shift. CORMAX=0 *** Establish the initial configuration. DO 15 J=1,NWIRE X(J)=XORIG(J)+XOFF(J) Y(J)=YORIG(J)+YOFF(J) 15 CONTINUE *** Loop over wires. DO 20 IIW=1,NWIRE * Reject all that were not SELECT'ed. IF(INDSW(IIW).EQ.0)GOTO 20 * Place the current wire at its nominal position. X(IIW)=XORIG(IIW) Y(IIW)=YORIG(IIW) *** First order approximation, also used if detail is required. CALL SETUP(IFAIL) * Print a warning if this failed. IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! OPTFRC WARNING : Charge'// - ' calculation failed at central position.' CALL LOGSAV(.FALSE.,'OK',IFAIL1) FX0=0.0 FY0=0.0 * Otherwise compute the forces. ELSE CALL FFIELD(IIW,EX,EY) FX0=0 FY0=0 IF(LFELEC)THEN FX0=FX0-EX*E(IIW)*2*PI*EPS0*100 FY0=FY0-EY*E(IIW)*2*PI*EPS0*100 ENDIF IF(LFGRAV)THEN FX0=FX0-DOWN(1)*GRAV*DENS(IIW)*PI*D(IIW)**2/4000 FY0=FY0-DOWN(2)*GRAV*DENS(IIW)*PI*D(IIW)**2/4000 ENDIF ENDIF * And compute the shift from this. SHIFTX=-125*FX0*U(IIW)**2/(GRAV*W(IIW)) SHIFTY=-125*FY0*U(IIW)**2/(GRAV*W(IIW)) * Get the elongation from this. SS=4*SQRT(DBLE(SHIFTX)**2+DBLE(SHIFTY)**2)/U(IIW) IF(SS.LE.0)THEN WLENG=U(IIW) ELSE WLENG=(SQRT(1+SS**2)+LOG(SS+SQRT(1+SS**2))/SS)*U(IIW)/2 ENDIF *** If requested, print results. IF(LSAGPR.AND.CONVIT)THEN CALL OUTFMT(REAL(IIW),2,AUX1,NC1,'LEFT') CALL OUTFMT(XORIG(IIW),2,AUX2,NC2,'LEFT') CALL OUTFMT(YORIG(IIW),2,AUX3,NC3,'LEFT') CALL OUTFMT(V(IIW),2,AUX4,NC4,'LEFT') CALL OUTFMT(U(IIW),2,AUX5,NC5,'LEFT') CALL OUTFMT(W(IIW),2,AUX6,NC6,'LEFT') CALL OUTFMT(FX0,2,AUX7,NC7,'LEFT') CALL OUTFMT(FY0,2,AUX8,NC8,'LEFT') CALL OUTFMT(SHIFTX,2,AUX9,NC9,'LEFT') CALL OUTFMT(SHIFTY,2,AUX10,NC10,'LEFT') CALL OUTFMT(REAL(WLENG-U(IIW))/U(IIW),2,AUX11,NC11,'LEFT') WRITE(LUNOUT,'('' FORCES AND DISPLACEMENT IN 0th ORDER''// - '' Wire information: number = '',A/ - '' type = '',A1/ - '' location = ('',A,'', '',A,'') cm''/ - '' voltage = '',A,'' V''/ - '' length = '',A,'' cm''/ - '' tension = '',A,'' g''// - '' In this position: Fx = '',A,'' N/cm''/ - '' Fy = '',A,'' N/cm''/ - '' x-shift = '',A,'' cm''/ - '' y-shift = '',A,'' cm''/ - '' stretch = '',A,'' fraction'')') - AUX1(1:NC1),WIRTYP(IIW),AUX2(1:NC2),AUX3(1:NC3),AUX4(1:NC4), - AUX5(1:NC5),AUX6(1:NC6),AUX7(1:NC7),AUX8(1:NC8),AUX9(1:NC9), - AUX10(1:NC10),AUX11(1:NC11) ENDIF *** Save the forces if requested and if the rest is skipped. IF(LFAST.AND.LFRCKP.AND.CONVIT)THEN * Format the wire number. CALL OUTFMT(REAL(IIW),2,AUXSTR,NC,'LEFT') * Assign the results to globals. CALL NUMSAV(FX0,'FORCE_X_'//AUXSTR(1:NC),IFAIL1) CALL NUMSAV(FY0,'FORCE_Y_'//AUXSTR(1:NC),IFAIL2) * Check the error condition. IF(IFAIL1.EQ.0.AND.IFAIL2.EQ.0)THEN PRINT *,' ------ OUTFRC MESSAGE : The forces'// - ' acting on wire '//AUXSTR(1:NC)//' are' PRINT *,' saved as FORCE_X_'// - AUXSTR(1:NC)//' and FORCE_Y_'//AUXSTR(1:NC)//'.' ELSE PRINT *,' !!!!!! OPTFRC WARNING : Saving the forces'// - ' failed.' CALL LOGSAV(.FALSE.,'OK',IFAIL1) ENDIF ENDIF *** Save the sag if requested and if the rest is skipped. IF(LFAST.AND.LSAGKP.AND.CONVIT)THEN * Format the wire number. CALL OUTFMT(REAL(IIW),2,AUXSTR,NC,'LEFT') * Assign the results to globals. CALL NUMSAV(SHIFTX,'SHIFT_X_'//AUXSTR(1:NC),IFAIL1) CALL NUMSAV(SHIFTY,'SHIFT_Y_'//AUXSTR(1:NC),IFAIL2) CALL NUMSAV(REAL((WLENG-U(IIW))/U(IIW)), - 'STRETCH_'//AUXSTR(1:NC),IFAIL3) * Check the error condition. IF(IFAIL1.EQ.0.AND.IFAIL2.EQ.0.AND.IFAIL3.EQ.0)THEN PRINT *,' ------ OUTFRC MESSAGE : Shift and'// - ' elongation of wire '//AUXSTR(1:NC) PRINT *,' saved as SHIFT_X_'// - AUXSTR(1:NC)//', SHIFT_Y_'//AUXSTR(1:NC)// - ' and STRETCH_'//AUXSTR(1:NC)//'.' ELSE PRINT *,' !!!!!! OPTFRC WARNING : Saving the sag'// - ' failed.' CALL LOGSAV(.FALSE.,'OK',IFAIL1) ENDIF ENDIF *** And skip the rest if fast calculation was requested. IF(LFAST)THEN CORMAX=MAX(CORMAX,ABS(2.0*SHIFTX/3.0-XOFF(IIW)), - ABS(2.0*SHIFTY/3.0-YOFF(IIW))) X(IIW)=XORIG(IIW)+XOFF(IIW) Y(IIW)=YORIG(IIW)+YOFF(IIW) XOFF(IIW)=2.0*SHIFTX/3.0 YOFF(IIW)=2.0*SHIFTY/3.0 GOTO 20 ENDIF *** Detailed calculation: compute a 'safe box' around the wire. IF(PERX)THEN BXMIN=X(IIW)-SX/2 BXMAX=X(IIW)+SX/2 ELSE BXMIN=2*XMIN-XMAX BXMAX=2*XMAX-XMIN ENDIF IF(PERY)THEN BYMIN=Y(IIW)-SY/2 BYMAX=Y(IIW)+SY/2 ELSE BYMIN=2*YMIN-YMAX BYMAX=2*YMAX-YMIN ENDIF * If the initial area is almost zero in 1 direction, make it square. IF(ABS(BXMAX-BXMIN).LT.0.1*ABS(BYMAX-BYMIN))THEN BXMIN=X(IIW)-ABS(BYMAX-BYMIN)/2 BXMAX=X(IIW)+ABS(BYMAX-BYMIN)/2 ELSEIF(ABS(BYMAX-BYMIN).LT.0.1*ABS(BXMAX-BXMIN))THEN BYMIN=Y(IIW)-ABS(BXMAX-BXMIN)/2 BYMAX=Y(IIW)+ABS(BXMAX-BXMIN)/2 ENDIF * Scan the other wires. DO 100 JW=1,NWIRE IF(JW.EQ.IIW)GOTO 100 IF(PERX)THEN XNEAR=X(JW)-ANINT((X(JW)-X(IIW))/SX)*SX ELSE XNEAR=X(JW) ENDIF IF(PERY)THEN YNEAR=Y(JW)-ANINT((Y(JW)-Y(IIW))/SY)*SY ELSE YNEAR=Y(JW) ENDIF IF(ABS(XNEAR-X(IIW)).GT.ABS(YNEAR-Y(IIW)))THEN IF(XNEAR.LT.X(IIW))THEN BXMIN=MAX(BXMIN,XNEAR+D(JW)+D(IIW)) IF(PERX)BXMAX=MIN(BXMAX,XNEAR+SX-D(JW)-D(IIW)) ELSE BXMAX=MIN(BXMAX,XNEAR-D(JW)-D(IIW)) IF(PERX)BXMIN=MAX(BXMIN,XNEAR-SX+D(JW)+D(IIW)) ENDIF ELSE IF(YNEAR.LT.Y(IIW))THEN BYMIN=MAX(BYMIN,YNEAR-D(JW)-D(IIW),YNEAR+D(JW)+D(IIW)) IF(PERY)BYMAX=MIN(BYMAX,YNEAR+SY-D(JW)-D(IIW)) ELSE BYMAX=MIN(BYMAX,YNEAR-D(JW)-D(IIW),YNEAR+D(JW)+D(IIW)) IF(PERY)BYMIN=MAX(BYMIN,YNEAR-SY+D(JW)+D(IIW)) ENDIF ENDIF 100 CONTINUE * Scan the planes. IF(YNPLAN(1))BXMIN=MAX(BXMIN,COPLAN(1)+D(IIW)) IF(YNPLAN(2))BXMAX=MIN(BXMAX,COPLAN(2)-D(IIW)) IF(YNPLAN(3))BYMIN=MAX(BYMIN,COPLAN(3)+D(IIW)) IF(YNPLAN(4))BYMAX=MIN(BYMAX,COPLAN(4)-D(IIW)) * If there is a tube, check all corners. IF(TUBE.AND.COTUBE**2-D(IIW)**2.GT.0)THEN CORR=SQRT((BXMIN**2+BYMIN**2)/(COTUBE**2-D(IIW)**2)) IF(CORR.GT.1)THEN BXMIN=BXMIN/CORR BYMIN=BYMIN/CORR ENDIF CORR=SQRT((BXMIN**2+BYMIN**2)/(COTUBE**2-D(IIW)**2)) IF(CORR.GT.1)THEN BXMIN=BXMIN/CORR BYMAX=BYMAX/CORR ENDIF CORR=SQRT((BXMIN**2+BYMIN**2)/(COTUBE**2-D(IIW)**2)) IF(CORR.GT.1)THEN BXMAX=BXMAX/CORR BYMIN=BYMIN/CORR ENDIF CORR=SQRT((BXMIN**2+BYMIN**2)/(COTUBE**2-D(IIW)**2)) IF(CORR.GT.1)THEN BXMAX=BXMAX/CORR BYMAX=BYMAX/CORR ENDIF ELSEIF(TUBE)THEN PRINT *,' !!!!!! OPTFRC WARNING : Wire diameter too'// - ' large compared to tube; wire ',IIW,' skipped.' CALL LOGSAV(.FALSE.,'OK',IFAIL1) GOTO 20 ENDIF * Make sure we found a reasonable 'safe area'. IF((BXMIN-X(IIW))*(X(IIW)-BXMAX).LE.0.OR. - (BYMIN-Y(IIW))*(Y(IIW)-BYMAX).LE.0)THEN PRINT *,' !!!!!! OPTFRC WARNING : Unable to find'// - ' an area free of elements around wire ',IIW CALL LOGSAV(.FALSE.,'OK',IFAIL1) GOTO 20 ENDIF *** Now set a reasonable scanning range: if user specified range: IF(SFORCE)THEN SXMIN=X(IIW)+FSXMIN SYMIN=Y(IIW)+FSYMIN SXMAX=X(IIW)+FSXMAX SYMAX=Y(IIW)+FSYMAX * if maximum area: ELSEIF(SLARGE)THEN SXMIN=BXMIN SXMAX=BXMAX SYMIN=BYMIN SYMAX=BYMAX * if 0th order estimate of shift is not small: ELSEIF(ABS(SHIFTX).GT.D(IIW)/20.OR.ABS(SHIFTY).GT.D(IIW)/20)THEN SXMIN=MAX(BXMIN,MIN(X(IIW)+SFACT*SHIFTX, - X(IIW)-SHIFTX/SFACT)) SYMIN=MAX(BYMIN,MIN(Y(IIW)+SFACT*SHIFTY, - Y(IIW)-SHIFTY/SFACT)) SXMAX=MIN(BXMAX,MAX(X(IIW)+SFACT*SHIFTX, - X(IIW)-SHIFTX/SFACT)) SYMAX=MIN(BYMAX,MAX(Y(IIW)+SFACT*SHIFTY, - Y(IIW)-SHIFTY/SFACT)) * If one is very small, make the area square within bounds. IF(ABS(SXMAX-SXMIN).LT.0.1*ABS(SYMAX-SYMIN))THEN SXMIN=MAX(BXMIN,X(IIW)-0.5*ABS(SYMAX-SYMIN)) SXMAX=MIN(BXMAX,X(IIW)+0.5*ABS(SYMAX-SYMIN)) ELSEIF(ABS(SYMAX-SYMIN).LT.0.1*ABS(SXMAX-SXMIN))THEN SYMIN=MAX(BYMIN,Y(IIW)-0.5*ABS(SXMAX-SXMIN)) SYMAX=MIN(BYMAX,Y(IIW)+0.5*ABS(SXMAX-SXMIN)) ENDIF * Otherwise, take full acceptable range. ELSE SXMIN=BXMIN SYMIN=BYMIN SXMAX=BXMAX SYMAX=BYMAX ENDIF *** Debugging output. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ OPTFRC DEBUG : '', - ''Free area '',E12.5,'' < x < '',E12.5/26X, - '' '',E12.5,'' < y < '',E12.5/26X, - ''Scan area '',E12.5,'' < x < '',E12.5/26X, - '' '',E12.5,'' < y < '',E12.5)') - BXMIN,BXMAX,BYMIN,BYMAX,SXMIN,SXMAX,SYMIN,SYMAX *** Prepare an interpolation table. OK=.TRUE. DO 30 IX=1,NSCANX XSCAN(IX)=SXMIN+REAL(IX-1)*(SXMAX-SXMIN)/REAL(NSCANX-1) DO 40 IY=1,NSCANY YSCAN(IY)=SYMIN+REAL(IY-1)*(SYMAX-SYMIN)/REAL(NSCANY-1) * Get the wire position for this shift. X(IIW)=REAL(XSCAN(IX)) Y(IIW)=REAL(YSCAN(IY)) * Verify the current situation. CALL CELWCH(IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! OPTFRC WARNING : Scan involves a'// - ' disallowed wire position; wire ',IIW,' skipped.' CALL LOGSAV(.FALSE.,'OK',IFAIL1) FX(IX,IY)=0.0 FY(IX,IY)=0.0 OK=.FALSE. GOTO 40 ENDIF * Recompute the charges for this configuration. CALL SETUP(IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! OPTFRC WARNING : Failed to compute'// - ' charges at a scan point; wire ',IIW,' skipped.' CALL LOGSAV(.FALSE.,'OK',IFAIL1) FX(IX,IY)=0.0 FY(IX,IY)=0.0 OK=.FALSE. GOTO 40 ENDIF * Compute the forces. CALL FFIELD(IIW,EX,EY) FX(IX,IY)=-EX*E(IIW)*2*PI*EPS0*100 FY(IX,IY)=-EY*E(IIW)*2*PI*EPS0*100 * And keep track of the range of the forces. IF(IX.EQ.1.AND.IY.EQ.1)THEN FXMIN=REAL(FX(IX,IY)) FXMAX=REAL(FX(IX,IY)) FYMIN=REAL(FY(IX,IY)) FYMAX=REAL(FY(IX,IY)) ELSE FXMIN=MIN(FXMIN,REAL(FX(IX,IY))) FXMAX=MAX(FXMAX,REAL(FX(IX,IY))) FYMIN=MIN(FYMIN,REAL(FY(IX,IY))) FYMAX=MAX(FYMAX,REAL(FY(IX,IY))) ENDIF * Next point. 40 CONTINUE 30 CONTINUE *** Place the wire back in its shifted position. X(IIW)=XORIG(IIW)+XOFF(IIW) Y(IIW)=YORIG(IIW)+YOFF(IIW) *** Skip the rest in case of failure. IF(.NOT.OK)GOTO 20 *** Plot the force field if requested. IF(LFRCPL.AND.CONVIT)THEN * Open a frame for the x-grid lines. CALL GRCART(SXMIN,MIN(FXMIN,FYMIN)-0.1* - (MAX(FXMAX,FYMAX)-MIN(FXMIN,FYMIN)), - SXMAX,MAX(FXMAX,FYMAX)+0.1* - (MAX(FXMAX,FYMAX)-MIN(FXMIN,FYMIN)), - 'Wire x position [cm]','Force [N/cm]', - 'Forces as function of wire shift') * Add comments. IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) CALL OUTFMT(REAL(IIW),2,AUXSTR,NC,'LEFT') CALL GRCOMM(2,'Wire: '//AUXSTR(1:NC)//' ('// - WIRTYP(IIW)//')') * Plot the forces. DO 140 IY=1,NSCANY CALL GRATTS('FUNCTION-1','POLYLINE') DO 150 IX=1,NSCANX XPL(IX)=REAL(XSCAN(IX)) YPL(IX)=REAL(FX(IX,IY)) 150 CONTINUE CALL GRLINE(NSCANX,XPL,YPL) CALL GRATTS('FUNCTION-2','POLYLINE') DO 160 IX=1,NSCANX XPL(IX)=REAL(XSCAN(IX)) YPL(IX)=REAL(FY(IX,IY)) 160 CONTINUE CALL GRLINE(NSCANX,XPL,YPL) 140 CONTINUE * Register the plot and close this frame. CALL GRALOG('Forces on wire '//AUXSTR(1:NC)) CALL GRNEXT * Open a frame for the y-grid lines. CALL GRCART(SYMIN,MIN(FXMIN,FYMIN)-0.1* - (MAX(FXMAX,FYMAX)-MIN(FXMIN,FYMIN)), - SYMAX,MAX(FXMAX,FYMAX)+0.1* - (MAX(FXMAX,FYMAX)-MIN(FXMIN,FYMIN)), - 'Wire y position [cm]','Force [N/cm]', - 'Forces as function of wire shift') * Add comments. IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) CALL GRCOMM(2,'Wire: '//AUXSTR(1:NC)//' ('// - WIRTYP(IIW)//')') * Plot the forces. DO 110 IX=1,NSCANX CALL GRATTS('FUNCTION-1','POLYLINE') DO 120 IY=1,NSCANY XPL(IY)=REAL(YSCAN(IY)) YPL(IY)=REAL(FX(IX,IY)) 120 CONTINUE CALL GRLINE(NSCANY,XPL,YPL) CALL GRATTS('FUNCTION-2','POLYLINE') DO 130 IY=1,NSCANY XPL(IY)=REAL(YSCAN(IY)) YPL(IY)=REAL(FY(IX,IY)) 130 CONTINUE CALL GRLINE(NSCANY,XPL,YPL) 110 CONTINUE * Register the plot and close this frame. CALL GRALOG('Forces on wire '//AUXSTR(1:NC)) CALL GRNEXT ENDIF *** Print the table of the forces. IF(LFRCPR.AND.CONVIT)THEN * Print a header. WRITE(LUNOUT,'('' FORCES ACTING ON WIRE '',I4// - '' Fx [N/cm]''/'' Fy [N/cm]''/'' |F| [N/cm]'')') - IIW * Print them block by block. DO 170 JJ=0,10*INT((NSCANY-1)/10.0),10 JMAX=MIN(NSCANY-JJ,10) DO 180 II=0,10*INT((NSCANX-1)/10.0),10 IMAX=MIN(NSCANX-II,10) WRITE(LUNOUT,'(''1 Force-print'',109X, - ''Part '',I1,''.'',I1)', - ERR=2010,IOSTAT=IOS) 1+II/10,1+JJ/10 WRITE(LUNOUT,'('' ==========='',109X,''========''/)', - IOSTAT=IOS,ERR=2010) WRITE(LUNOUT,'('' y x:'',10(E11.4,1X:)/)', - IOSTAT=IOS,ERR=2010) (XSCAN(II+I),I=1,IMAX) DO 190 J=1,JMAX WRITE(LUNOUT,'(1X,E10.3)',IOSTAT=IOS,ERR=2010) - YSCAN(JJ+J) WRITE(LUNOUT,'(12X,10(E11.4,1X:))',IOSTAT=IOS,ERR=2010) - (FX(II+I,JJ+J),I=1,IMAX) WRITE(LUNOUT,'(12X,10(E11.4,1X:))',IOSTAT=IOS,ERR=2010) - (FY(II+I,JJ+J),I=1,IMAX) WRITE(LUNOUT,'(12X,10(E11.4,1X:))',IOSTAT=IOS,ERR=2010) - (SQRT(FX(II+I,JJ+J)**2+FY(II+I,JJ+J)**2),I=1,IMAX) 190 CONTINUE 180 CONTINUE 170 CONTINUE ENDIF *** Save the force table if requested. IF(LFRCKP.AND.CONVIT)THEN * Format the wire number. CALL OUTFMT(REAL(IIW),2,AUXSTR,NC,'LEFT') * Assign the results to globals. ISIZ(1)=NSCANX ISIZ(2)=NSCANY IDIM(1)=MXGRID IDIM(2)=MXGRID CALL MT2SAV(FX,2,IDIM,ISIZ,'FX_'//AUXSTR(1:NC),IFAIL1) CALL MT2SAV(FY,2,IDIM,ISIZ,'FY_'//AUXSTR(1:NC),IFAIL2) ISIZ(1)=NSCANX IDIM(1)=MXGRID CALL MT2SAV(XSCAN,1,IDIM,ISIZ, - 'X_F_'//AUXSTR(1:NC),IFAIL3) ISIZ(1)=NSCANY IDIM(1)=MXGRID CALL MT2SAV(YSCAN,1,IDIM,ISIZ, - 'Y_F_'//AUXSTR(1:NC),IFAIL4) * Check the error condition. IF(IFAIL1.EQ.0.AND.IFAIL2.EQ.0.AND. - IFAIL3.EQ.0.AND.IFAIL4.EQ.0)THEN PRINT *,' ------ OUTFRC MESSAGE : Force table'// - ' of wire '//AUXSTR(1:NC)//' saved as' PRINT *,' FX_'//AUXSTR(1:NC)// - ', FY_'//AUXSTR(1:NC)//', X_F_'//AUXSTR(1:NC)// - ' and Y_F_'//AUXSTR(1:NC)//'.' ELSE PRINT *,' !!!!!! OPTFRC WARNING : Saving the force'// - ' table failed.' CALL LOGSAV(.FALSE.,'OK',IFAIL1) ENDIF ENDIF *** Compute the detailed wire shift. NSAG=MXLIST CALL OPTSAG(IIW,'PARABOLIC',CSAG,XSAG,YSAG,NSAG,IFAIL1) C CALL OPTSAG(IIW,'RANDOM',CSAG,XSAG,YSAG,NSAG,IFAIL1) * Check error status. IF(IFAIL1.NE.0.OR.NSAG.LE.0)THEN PRINT *,' !!!!!! OPTFRC WARNING : Computation of the'// - ' wire sag failed; wire ',IIW,' skipped.' CALL LOGSAV(.FALSE.,'OK',IFAIL1) GOTO 20 ENDIF * And compute mean and maximum sag, verify that the wire is in range. XSAGMI=XSAG(0) YSAGMI=YSAG(0) XSAGMX=XSAG(0) YSAGMX=YSAG(0) XSAGAV=0 YSAGAV=0 INAREA=.TRUE. DO 210 I=0,NSAG IF(I.EQ.0)THEN WLENG=0 ELSE WLENG=WLENG+SQRT((XSAG(I)-XSAG(I-1))**2+ - (YSAG(I)-YSAG(I-1))**2+(CSAG(I)-CSAG(I-1))**2) ENDIF IF(XORIG(IIW)+XSAG(I).LT.SXMIN.OR. - XORIG(IIW)+XSAG(I).GT.SXMAX.OR. - YORIG(IIW)+YSAG(I).LT.SYMIN.OR. - YORIG(IIW)+YSAG(I).GT.SYMAX)INAREA=.FALSE. XSAGMI=MIN(XSAGMI,XSAG(I)) YSAGMI=MIN(YSAGMI,YSAG(I)) XSAGMX=MAX(XSAGMX,XSAG(I)) YSAGMX=MAX(YSAGMX,YSAG(I)) XSAGAV=XSAGAV+XSAG(I) YSAGAV=YSAGAV+YSAG(I) 210 CONTINUE XSAGAV=XSAGAV/REAL(NSAG+1) YSAGAV=YSAGAV/REAL(NSAG+1) * Update the wire offset vector. CORMAX=MAX(CORMAX,ABS(XSAGAV-XOFF(IIW)),ABS(YSAGAV-YOFF(IIW))) XOFF(IIW)=XSAGAV YOFF(IIW)=YSAGAV * Warn if a point outside the scanning area was found. IF(.NOT.INAREA)THEN PRINT *,' !!!!!! OPTFRC WARNING : The wire profile is'// - ' located partially outside the scanning area.' ENDIF *** If required, print the wire sag. IF(LSAGPR.AND.CONVIT)THEN CALL OUTFMT(REAL(IIW),2,AUX1,NC1,'LEFT') CALL OUTFMT(V(IIW),2,AUX2,NC2,'LEFT') CALL OUTFMT(U(IIW),2,AUX3,NC3,'LEFT') CALL OUTFMT(W(IIW),2,AUX4,NC4,'LEFT') CALL OUTFMT(DENS(IIW),2,AUX5,NC5,'LEFT') CALL OUTFMT(XORIG(IIW),2,AUX6,NC6,'LEFT') CALL OUTFMT(YORIG(IIW),2,AUX7,NC7,'LEFT') CALL OUTFMT(XSAGAV,2,AUX8,NC8,'LEFT') CALL OUTFMT(YSAGAV,2,AUX9,NC9,'LEFT') CALL OUTFMT(MAX(ABS(XSAGMX),ABS(XSAGMI)),2, - AUX10,NC10,'LEFT') CALL OUTFMT(MAX(ABS(YSAGMX),ABS(YSAGMI)),2, - AUX11,NC11,'LEFT') CALL OUTFMT(100*REAL(WLENG-U(IIW))/U(IIW),2, - AUX12,NC12,'LEFT') WRITE(LUNOUT,'('' SAG PROFILE FOR WIRE '',A,'' (TYPE '',A1, - '')''// - '' Wire voltage: '',A,'' V''/ - '' Wire length: '',A,'' cm''/ - '' Wire stretching weight: '',A,'' g''/ - '' Wire density: '',A,'' g/cm3''/ - '' Nominal wire position: ('',A,'','',A,'') cm''// - '' Average sag in x and y: '',A,'' and '',A,'' cm''/ - '' Maximum sag in x and y: '',A,'' and '',A,'' cm''/ - '' Elongation: '',A,'' %''// - '' Point z [cm] x-sag [cm]'', - '' y-sag [cm]''/)') - AUX1(1:NC1),WIRTYP(IIW),AUX2(1:NC2),AUX3(1:NC3), - AUX4(1:NC4),AUX5(1:NC5),AUX6(1:NC6),AUX7(1:NC7), - AUX8(1:NC8),AUX9(1:NC9),AUX10(1:NC10),AUX11(1:NC11), - AUX12(1:NC12) DO 200 I=0,NSAG WRITE(LUNOUT,'(I7,3(2X,E12.5))') I,CSAG(I),XSAG(I),YSAG(I) 200 CONTINUE ENDIF *** Plot the wire profile, if requested. IF(LSAGPL.AND.CONVIT)THEN * Open a frame. CALL GRCART(CSAG(0),MIN(XSAGMI,YSAGMI)- - 0.1*(MAX(XSAGMX,YSAGMX)-MIN(XSAGMI,YSAGMI)), - CSAG(NSAG),MAX(XSAGMX,YSAGMX)+ - 0.1*(MAX(XSAGMX,YSAGMX)-MIN(XSAGMI,YSAGMI)), - 'z [cm]','Sag [cm]','Wire profile') * Add some comments to the plot. CALL OUTFMT(REAL(IIW),2,AUXSTR,NC,'LEFT') IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) CALL GRCOMM(2,'Wire: '//AUXSTR(1:NC)//' ('// - WIRTYP(IIW)//')') * Plot the curves. CALL GRATTS('FUNCTION-1','POLYLINE') CALL GRLINE(NSAG+1,CSAG(0),XSAG(0)) CALL GRATTS('FUNCTION-2','POLYLINE') CALL GRLINE(NSAG+1,CSAG(0),YSAG(0)) * Register the plot. CALL GRALOG('Sag profile of wire '//AUXSTR(1:NC)//':') * Close the frame. CALL GRNEXT ENDIF *** Save the results if requested. IF(LSAGKP.AND.CONVIT)THEN * Format the wire number. CALL OUTFMT(REAL(IIW),2,AUXSTR,NC,'LEFT') * Assign the results to globals. ISIZ(1)=NSAG+1 IDIM(1)=MXLIST+1 CALL MATSAV(CSAG(0),1,IDIM,ISIZ, - 'Z_'//AUXSTR(1:NC),IFAIL1) CALL MATSAV(XSAG(0),1,IDIM,ISIZ, - 'SAG_X_'//AUXSTR(1:NC),IFAIL2) CALL MATSAV(YSAG(0),1,IDIM,ISIZ, - 'SAG_Y_'//AUXSTR(1:NC),IFAIL3) CALL NUMSAV(REAL((WLENG-U(IIW))/U(IIW)), - 'STRETCH_'//AUXSTR(1:NC),IFAIL4) * Check the error condition. IF(IFAIL1.EQ.0.AND.IFAIL2.EQ.0.AND. - IFAIL3.EQ.0.AND.IFAIL4.EQ.0)THEN PRINT *,' ------ OUTFRC MESSAGE : Sag profile'// - ' of wire '//AUXSTR(1:NC)//' saved as' PRINT *,' Z_'//AUXSTR(1:NC)// - ', SAG_X_'//AUXSTR(1:NC)//', SAG_Y_'// - AUXSTR(1:NC)//' and STRETCH_'//AUXSTR(1:NC)//'.' ELSE PRINT *,' !!!!!! OPTFRC WARNING : Saving the results'// - ' failed.' ENDIF ENDIF *** Check for wire stability. IF(LSTAB)THEN CALL OPTENM ENDIF *** Next wire. 20 CONTINUE *** If iteration over all wires was requested ... IF(LFITER.AND..NOT.CONVIT)THEN * Print current status. WRITE(LUNOUT,'('' Iteration '',I3/)') ITER DO 1050 I=1,NWIRE IF(INDSW(I).EQ.0)GOTO 1050 WRITE(LUNOUT,'('' Wire '',I3,'' moves on average by ('', - E12.5,'','',E12.5,'') cm'')') I,XOFF(I),YOFF(I) 1050 CONTINUE WRITE(LUNOUT,'(/'' Largest average shift: '',E12.5, - '' cm.'')') CORMAX * Check convergence, send for a last round if needed. IF(CORMAX.LE.TOLER)THEN WRITE(LUNOUT,'('' Convergence achieved.'')') CONVIT=.TRUE. GOTO 1000 ELSEIF(ITER.LT.NFITER)THEN GOTO 1000 ELSE WRITE(LUNOUT,'('' Maximum number if iterations'', - '' reached - iteration stopped.'')') CALL LOGSAV(.FALSE.,'OK',IFAIL1) ENDIF ENDIF *** Restore the initial situation. DO 1100 I=1,NWIRE X(I)=XORIG(I) Y(I)=YORIG(I) 1100 CONTINUE CALL SETUP(IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' ###### OPTFRC ERROR : Unable to'// - ' restore the initial configuration.' PRINT *,' Setting the'// - ' number of wires to 0.' CALL LOGSAV(.FALSE.,'OK',IFAIL1) NWIRE=0 ENDIF *** Register the amount of CPU time used with TIMLOG. CALL TIMLOG('Computing forces on the wires: ') *** Normal end of the routine. RETURN *** Handle I/O errors. 2010 CONTINUE PRINT *,' ###### OPTFRC ERROR : Error writing the force'// - ' table on unit ',LUNOUT,' ; output terminated.' CALL LOGSAV(.FALSE.,'OK',IFAIL1) CALL INPIOS(IOS) END +DECK,OPTSAG. SUBROUTINE OPTSAG(IWIRE,START,CSAG,XSAG,YSAG,NSAG,IFAIL) *----------------------------------------------------------------------- * OPTSAG - Computes the wire sag due to eletrostatic and gravitational * forces, using a Runge-Kutta-Nystrom multiple shoot method, * where the intermediate conditions are imposed through a * Broyden rank-1 zero search. * (Last changed on 13/ 4/99.) *----------------------------------------------------------------------- IMPLICIT DOUBLE PRECISION (A-H,O-Z) +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. +SEQ,SHAPEDATA. +SEQ,CELLDATA. +SEQ,CONSTANTS. INTEGER IFAIL,IFAIL1,NSAG,I CHARACTER*(*) START REAL CSAG(0:*),XSAG(0:*),YSAG(0:*),RNDM DOUBLE PRECISION COOR,XST(2),DXST(2),WORK(12),XX(4*MXSHOT+2), - FXMEAN,FYMEAN,SAGX0,SAGY0,FORCE(2) EXTERNAL OPTSHT,OPTSTP,RNDM *** Assume the routine will fail. IFAIL=1 *** Check the values of the parameters. IF(IWIRE.LE.0.OR.IWIRE.GT.NWIRE)THEN PRINT *,' !!!!!! OPTSAG WARNING : Wire number out of'// - ' range; sag not computed.' RETURN ELSEIF(NSAG.LT.NSTEP*(NSHOT+1))THEN PRINT *,' !!!!!! OPTSAG WARNING : Output arrays are'// - ' too small; sag not computed.' RETURN ENDIF *** Copy the wire number to the common block. IW=IWIRE *** Temporarily set the number of output values to 0. NSAG=0 *** Compute the step width based on the number of steps. STEP=DBLE(U(IW))/DBLE(NSTEP*(NSHOT+1)) *** Compute expected maximum sag, constant-force approximation. XST(1)=0 XST(2)=0 DXST(1)=0 DXST(2)=0 FXMEAN=0 FYMEAN=0 * Check whether there is extrapolation. LFWARN=.FALSE. * Loop over the whole wire. DO 40 I=0,NSTEP*(NSHOT+1) COOR=I*STEP CALL OPTSTP(COOR,XST,DXST,FORCE) FXMEAN=FXMEAN+FORCE(1) FYMEAN=FYMEAN+FORCE(2) 40 CONTINUE * Check the extrapolation warning flag. IF(LFWARN)THEN PRINT *,' !!!!!! OPTSAG WARNING : Wire at nominal'// - ' position outside scanning area; no sag calculated.' RETURN ENDIF * Compute expected sag. SAGX0=-FXMEAN*DBLE(U(IW))**2/DBLE(8*(1+NSTEP*(NSHOT+1))) SAGY0=-FYMEAN*DBLE(U(IW))**2/DBLE(8*(1+NSTEP*(NSHOT+1))) IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ OPTSAG DEBUG :'', - '' Parabolic sag dx='',E12.5,'', dy='',E12.5,'' [cm]'')') - SAGX0,SAGY0 *** Starting position: parabolic sag. IF(START.EQ.'PARABOLIC')THEN * Derivative first point. XX(1)=4*SAGX0/U(IW) XX(2)=4*SAGY0/U(IW) * Intermediate points, both position and derivative. DO 10 I=1,NSHOT * Position. COOR=I*NSTEP*STEP-U(IW)/2 * Deflection. XX(4*I-1)=SAGX0*(1-4*COOR**2/U(IW)**2) XX(4*I)=SAGY0*(1-4*COOR**2/U(IW)**2) * Derivative. XX(4*I+1)=-8*SAGX0*COOR/U(IW)**2 XX(4*I+2)=-8*SAGY0*COOR/U(IW)**2 10 CONTINUE *** Starting position: random position. ELSEIF(START.EQ.'RANDOM')THEN DO 15 I=1,4*NSHOT+2 * Derivatives. IF(I-1.EQ.4*((I-1)/4).OR.I-2.EQ.4*((I-2)/4))THEN XX(I)=RNDM(I)-0.5 * Positions. ELSE XX(I)=0.1*(RNDM(I)-0.5)*U(IW) ENDIF 15 CONTINUE *** Unknown starting position. ELSE PRINT *,' !!!!!! OPTSAG WARNING : Unknown starting'// - ' choice received ; no sag calculated.' RETURN ENDIF *** Search for solution. CALL OPTZRO(OPTSHT,XX,4*NSHOT+2,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! OPTSAG WARNING : Failed to solve'// - ' the differential equation for the sag; no'// - ' sag returned.' RETURN ENDIF *** And return the detailed solution, first the starting point. CSAG(0)=-U(IW)/2 XSAG(0)=0 YSAG(0)=0 COOR=-U(IW)/2 DO 30 I=0,NSHOT * Set the starting value and starting derivative. IF(I.EQ.0)THEN XST(1)=0 XST(2)=0 DXST(1)=XX(1) DXST(2)=XX(2) ELSE XST(1)=XX(4*I-1) XST(2)=XX(4*I) DXST(1)=XX(4*I+1) DXST(2)=XX(4*I+2) ENDIF * Store the intermediate values. DO 20 J=1,NSTEP CALL DRKNYS(2,STEP,COOR,XST,DXST,OPTSTP,WORK) CSAG(I*NSTEP+J)=COOR XSAG(I*NSTEP+J)=XST(1) YSAG(I*NSTEP+J)=XST(2) 20 CONTINUE 30 CONTINUE *** Seems to have worked. NSAG=NSTEP*(NSHOT+1) IFAIL=0 END +DECK,OPTSHT. SUBROUTINE OPTSHT(XX,F,N) *----------------------------------------------------------------------- * OPTSHT - Auxiliary routine for the wire sag routines which computes * for a given set of positions and derivatives the next set * which is used by OPTZRO to match the sections. Uses a * 2nd order Runge-Kutta-Nystrom integration routine (D203). * (Last changed on 1/ 5/96.) *----------------------------------------------------------------------- IMPLICIT DOUBLE PRECISION (A-H,O-Z) +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. +SEQ,SHAPEDATA. +SEQ,CELLDATA. DOUBLE PRECISION XX(4*MXSHOT+2),F(*),COOR,XST(2),DXST(2),WORK(12) INTEGER N,I,J EXTERNAL OPTSTP *** For the starting set in XX, compute the next round. COOR=-U(IW)/2 DO 10 I=0,NSHOT * Set the starting value and starting derivative. IF(I.EQ.0)THEN XST(1)=0 XST(2)=0 DXST(1)=XX(1) DXST(2)=XX(2) ELSE XST(1)=XX(4*I-1) XST(2)=XX(4*I) DXST(1)=XX(4*I+1) DXST(2)=XX(4*I+2) ENDIF * Compute the end value and end derivative. DO 20 J=1,NSTEP CALL DRKNYS(2,STEP,COOR,XST,DXST,OPTSTP,WORK) 20 CONTINUE * Store the differences as function value. IF(I.LT.NSHOT)THEN F(4*I+1)=XST(1)-XX(4*I+3) F(4*I+2)=XST(2)-XX(4*I+4) F(4*I+3)=DXST(1)-XX(4*I+5) F(4*I+4)=DXST(2)-XX(4*I+6) ELSE F(4*NSHOT+1)=XST(1) F(4*NSHOT+2)=XST(2) ENDIF * Next shot. 10 CONTINUE END +DECK,OPTSTP. SUBROUTINE OPTSTP(COOR,BEND,DBEND,F) *----------------------------------------------------------------------- * OPTSTP - Returns the electrostatic and gravitational force divided * by the stretching force acting on a wire at position COOR, * with deflection BEND and bending derivative DBEND. * (Last changed on 25/ 5/96.) *----------------------------------------------------------------------- IMPLICIT DOUBLE PRECISION (A-H,O-Z) +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. +SEQ,CELLDATA. +SEQ,SHAPEDATA. +SEQ,CONSTANTS. DOUBLE PRECISION COOR,BEND(2),DBEND(2),F(2),DIVDF2,XAUX(MXGRID), - YAUX(MXGRID) EXTERNAL DIVDF2 *** Initialise the forces. F(1)=0 F(2)=0 *** In case extrapolation is not permitted, check range. IF((.NOT.LFEXTR).AND. - (XSCAN(1)-BEND(1)-XORIG(IW))* - (BEND(1)+XORIG(IW)-XSCAN(NSCANX)).LT.0.OR. - (YSCAN(1)-BEND(2)-YORIG(IW))* - (BEND(2)+YORIG(IW)-YSCAN(NSCANY)).LT.0)THEN LFWARN=.TRUE. RETURN ENDIF *** Electrostatic force: interpolate the table, first along the x-lines IF(LFELEC)THEN DO 10 I=1,NSCANY XAUX(I)=DIVDF2(FX(1,I),XSCAN,NSCANX, - BEND(1)+DBLE(XORIG(IW)),JSORD) YAUX(I)=DIVDF2(FY(1,I),XSCAN,NSCANX, - BEND(1)+DBLE(XORIG(IW)),JSORD) 10 CONTINUE * Then along the y-lines. F(1)=F(1)+DIVDF2(XAUX,YSCAN,NSCANY, - BEND(2)+DBLE(YORIG(IW)),JSORD) F(2)=F(2)+DIVDF2(YAUX,YSCAN,NSCANY, - BEND(2)+DBLE(YORIG(IW)),JSORD) ENDIF *** Add the gravity term. IF(LFGRAV)THEN F(1)=F(1)-DOWN(1)*GRAV*DENS(IW)*PI*D(IW)**2/4000 F(2)=F(2)-DOWN(2)*GRAV*DENS(IW)*PI*D(IW)**2/4000 ENDIF *** Divide by the stretching force. F(1)=1000*F(1)/(GRAV*W(IW)) F(2)=1000*F(2)/(GRAV*W(IW)) END +DECK,OPTZRO. SUBROUTINE OPTZRO(F,X,N,IFAIL) *----------------------------------------------------------------------- * OPTZRO - Tries to find zeroes of a set of functions F. Uses the * Broyden rank-1 update variant of an n-dimensional Newton- * Raphson zero search in most steps, except every 5th step * and whenever the step length update becomes less than 0.5, * when a new derivative is computed. * (Last changed on 29/ 4/96.) *----------------------------------------------------------------------- IMPLICIT DOUBLE PRECISION (A-H,O-Z) +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. +SEQ,SHAPEDATA. INTEGER N,IFAIL,IFAIL1,IWORK(MXZPAR),NBSMAX,NIT,NFC DOUBLE PRECISION X(*),B(MXZPAR,MXZPAR),BB(MXZPAR,MXZPAR),EPSDIF, - AUX1(MXZPAR),AUX2(MXZPAR),AUX3(MXZPAR),FOLD(MXZPAR), - SCALE,XNORM,DXNORM,FNORM,FNORML,DFNORM EXTERNAL F PARAMETER(NBSMAX=10) *** Identification and debugging output. IF(LIDENT)PRINT *,' /// ROUTINE OPTZRO ///' *** Assume this will fail. IFAIL=1 *** Extrapolation warning. LFWARN=.FALSE. *** Check the value of N. IF(N.LT.1.OR.N.GT.MXZPAR)THEN PRINT *,' !!!!!! OPTZRO WARNING : Number of points not'// - ' in the range [1,MXZPAR]; no zero search.' RETURN ENDIF *** Initial deviation. FNORML=0 CALL F(X,FOLD,N) IF(LFWARN.AND..NOT.LFEXTR)THEN PRINT *,' !!!!!! OPTZRO WARNING : Zero search stopped:'// - ' initial position outside scanning area.' RETURN ENDIF DO 70 I=1,N FNORML=FNORML+FOLD(I)**2 70 CONTINUE *** Debugging output for initial situation. IF(LDEBUG)THEN WRITE(LUNOUT,'('' ++++++ OPTZRO DEBUG : Start of'', - '' zero search.''// - 26X,''Number of parameters: '',I4/ - 26X,''Maximum bisections: '',I4/ - 26X,''Maximum iterations: '',I4/ - 26X,''Epsilon differentation: '',E12.5/ - 26X,''Required location change: '',E12.5/ - 26X,''Required function norm: '',E12.5// - 26X,''Initial function norm: '',E12.5// - 26X,''Parameter Value Function'')') - N,NBSMAX,NITMAX,EPS,EPSX,EPSF,SQRT(FNORML) DO 300 I=1,N WRITE(LUNOUT,'(26X,I9,1X,E12.5,1X,E12.5)') - I,X(I),FOLD(I) 300 CONTINUE ENDIF *** Set number of iterations. NIT=0 *** Set number of function calls. NFC=0 *** Compute derivative matrix. 200 CONTINUE DO 10 I=1,N EPSDIF=EPS*(1+ABS(X(I))) X(I)=X(I)+EPSDIF/2 CALL F(X,AUX1,N) X(I)=X(I)-EPSDIF CALL F(X,AUX2,N) X(I)=X(I)+EPSDIF/2 IF(LFWARN.AND..NOT.LFEXTR)THEN PRINT *,' !!!!!! OPTZRO WARNING : Zero search stopped:'// - ' differential matrix requires a point outside'// - ' scanning area.' RETURN ENDIF DO 20 J=1,N B(J,I)=(AUX1(J)-AUX2(J))/EPSDIF 20 CONTINUE 10 CONTINUE 210 CONTINUE NFC=NFC+2*N *** Next iteration. NIT=NIT+1 IF(LDEBUG)WRITE(LUNOUT,'(/26X,''Start of iteration '',I5)') NIT IF(LZROPR)THEN WRITE(LUNOUT,'('' Start of iteration '',I5)') NIT WRITE(LUNOUT,'('' x ='',5E12.5:(/5X,5E12.5))') - (X(3+4*I),I=0,NSHOT-1) WRITE(LUNOUT,'('' y ='',5E12.5:(/5X,5E12.5))') - (X(4+4*I),I=0,NSHOT-1) ENDIF *** Find the correction vector to 0th order, AUX1: f. DO 30 I=1,N AUX1(I)=FOLD(I) DO 35 J=1,N BB(I,J)=B(I,J) 35 CONTINUE 30 CONTINUE CALL DEQN(N,BB,MXZPAR,IWORK,IFAIL1,1,AUX1) * Check error condition, AUX1: correction vector. IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! OPTZRO WARNING : Solving the update'// - ' equation failed; zero search stopped.' GOTO 1000 ENDIF IF(LZROPR)THEN WRITE(LUNOUT,'('' dx='',5E12.5:(/5X,5E12.5))') - (AUX1(3+4*I),I=0,NSHOT-1) WRITE(LUNOUT,'('' dy='',5E12.5:(/5X,5E12.5))') - (AUX1(4+4*I),I=0,NSHOT-1) ENDIF *** Scale the correction vector to improve FNORM, AUX3: f. SCALE=1 DO 60 ITER=1,NBSMAX DO 40 I=1,N AUX2(I)=X(I)-SCALE*AUX1(I) 40 CONTINUE CALL F(AUX2,AUX3,N) IF(LFWARN.AND..NOT.LFEXTR)THEN PRINT *,' !!!!!! OPTZRO WARNING : Zero search stopped:'// - ' step update leads to a point outside the'// - ' scanning area.' RETURN ENDIF NFC=NFC+1 FNORM=0 DO 50 I=1,N FNORM=FNORM+AUX3(I)**2 50 CONTINUE IF(FNORM.LE.FNORML)THEN IF(LDEBUG)WRITE(LUNOUT,'(26X,''Scaling factor: '',E12.5)') - SCALE GOTO 80 ENDIF SCALE=SCALE/2 60 CONTINUE PRINT *,' !!!!!! OPTZRO WARNING : Bisection search for scaling'// - ' factor did not converge ; zero search stopped.' GOTO 1000 *** Update the estimate, AUX1: dx, AUX2: df, AUX3: f_new. 80 CONTINUE * Initial values of norms. XNORM=0 DXNORM=0 DFNORM=0 * Loop over the vectors. DO 90 I=1,N AUX1(I)=AUX2(I)-X(I) DXNORM=DXNORM+AUX1(I)**2 X(I)=AUX2(I) XNORM=XNORM+X(I)**2 AUX2(I)=AUX3(I)-FOLD(I) DFNORM=DFNORM+AUX2(I)**2 FOLD(I)=AUX3(I) 90 CONTINUE * Debugging output to show current status. IF(LDEBUG)WRITE(LUNOUT,'(26X,''After this iteration, ''/ - 26X,''Norm and change of position: '',2E12.5/ - 26X,''Norm and change of function: '',2E12.5)') - SQRT(XNORM),SQRT(DXNORM),SQRT(FNORM),SQRT(DFNORM) *** See whether convergence has been achieved. IF(SQRT(DXNORM).LT.EPSX*SQRT(XNORM))THEN IF(LDEBUG)WRITE(LUNOUT,'(/26X,''Positional convergence'', - '' criterion is satisfied.'')') IFAIL=0 GOTO 1000 ELSEIF(SQRT(FNORM).LT.EPSF)THEN IF(LDEBUG)WRITE(LUNOUT,'(/26X,''Function value'', - '' convergence criterion is satisfied.'')') IFAIL=0 GOTO 1000 ENDIF *** Update the difference. FNORML=FNORM *** If the scaling factor is small, then update (rank-1 Broyden). IF(SCALE.GT.0.4.AND.NIT.NE.5*(NIT/5))THEN IF(LDEBUG)WRITE(LUNOUT,'(26X,''Performing a Broyden'', - '' rank-1 update.'')') * Compute the "df - B dx" term, "dx" is still in AUX1 DO 100 I=1,N AUX3(I)=AUX2(I) DO 110 J=1,N AUX3(I)=AUX3(I)-B(I,J)*AUX1(J) 110 CONTINUE 100 CONTINUE * Update the matrix. DO 120 I=1,N DO 130 J=1,N B(I,J)=B(I,J)+AUX3(I)*AUX1(J)/DXNORM 130 CONTINUE 120 CONTINUE * And restart the iteration from the matrix solution. IF(NIT.LE.NITMAX)GOTO 210 *** Otherwise, recompute the differential. ELSE IF(LDEBUG)WRITE(LUNOUT,'(26X,''Recomputing the covariance'', - '' matrix.'')') IF(NIT.LE.NITMAX)GOTO 200 ENDIF *** Ending here means that the process didn't converge. PRINT *,' !!!!!! OPTZRO WARNING : Zero search did not'// - ' convergence in maximum number of loops.' *** Final debugging output. 1000 CONTINUE IF(LDEBUG)THEN CALL F(X,AUX1,N) NFC=NFC+1 WRITE(LUNOUT,'(26X,''Final values: ''// - 26X,''Parameter Value Function'')') DO 1010 I=1,N WRITE(LUNOUT,'(26X,I9,1X,E12.5,1X,E12.5)') - I,X(I),AUX1(I) 1010 CONTINUE WRITE(LUNOUT,'(26X,''Total number of function calls: '',I5/ - 26X,''End of debugging output.'')') NFC ENDIF END +DECK,OPTSTB. SUBROUTINE OPTSTB(CSAG,XSAG,YSAG,NSAG,DIST,PHI) *----------------------------------------------------------------------- * OPTSTB - Checks whether a wire location is stable or labile. *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,SHAPEDATA. +SEQ,CONSTANTS. INTEGER I,NSAG REAL CSAG(0:NSAG+1),XSAG(0:NSAG+1),YSAG(0:NSAG+1),DIST,PHI, - WI,WMIN,WMAX DOUBLE PRECISION COOR,BEND(2),DBEND(2),F0(2),F1(2) *** Loop over the shape. DO 10 I=1,NSAG * Compute the force at the nominal position. COOR=CSAG(I) BEND(1)=XSAG(I) BEND(2)=YSAG(I) DBEND(1)=0 DBEND(2)=0 CALL OPTSTP(COOR,BEND,DBEND,F0) * Compute the force at the offset location. COOR=CSAG(I) BEND(1)=XSAG(I)+COS(PHI)*DIST*(1-(CSAG(I)/CSAG(0))**2) BEND(2)=YSAG(I)+SIN(PHI)*DIST*(1-(CSAG(I)/CSAG(0))**2) DBEND(1)=0 DBEND(2)=0 CALL OPTSTP(COOR,BEND,DBEND,F1) * Minimum tension to keep in place. WI=W(IW)*U(IW)**2* - (COS(PHI)*(F1(1)-F0(1))+SIN(PHI)*(F1(2)-F0(2)))/(8*DIST) print *,' Point ',I,' required weight: ',WI * Update limits. IF(I.EQ.1)THEN WMIN=WI WMAX=WI ELSE WMIN=MIN(WMIN,WI) WMAX=MAX(WMAX,WI) ENDIF 10 CONTINUE PRINT *,' Checking for direction ',PHI*180/PI, - ' and distance ',DIST,' for wire ',IW PRINT *,' Weight needed to keep the wire stable: ', - WMIN,WMAX PRINT *,' Currently applied weight: ',W(IW) END +DECK,OPTENM. SUBROUTINE OPTENM *----------------------------------------------------------------------- * OPTENM - Computes the energy of a parabolic wire deflection by a * distance (DX,DY). * (Last changed on 3/12/99.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,SHAPEDATA. +SEQ,CONSTANTS. INTEGER NCONT,I,IFAIL,ISIZ(1),IDIM(1) REAL CMIN,CMAX,XPL(MXLIST),YPL(MXLIST),EPL(MXLIST) EXTERNAL OPTENE *** Number of contours. NCONT=10 *** Contour range. CMIN=0 CMAX=0 *** Plot a cut of the energy. if(.true.)then DO 10 I=1,200 XPL(I)=XORIG(IW) YPL(I)=YSCAN(1)+(I-1)*(YSCAN(NSCANY)-YSCAN(1))/REAL(200-1) CALL OPTENE(XPL(I)-XORIG(IW),YPL(I)-YORIG(IW),EPL(I),IFAIL) 10 CONTINUE CALL GRGRPH(YPL,EPL,200,'y [cm]','Energy','Vertical shifts') CALL GRNEXT * Save the energy. ISIZ(1)=200 IDIM(1)=MXLIST CALL MATSAV(YPL,1,IDIM,ISIZ,'OFFSET',IFAIL) CALL MATSAV(EPL,1,IDIM,ISIZ,'ENERGY',IFAIL) endif *** Plot frame. if(.false.)then CALL GRCART( - REAL(XSCAN(1) -XORIG(IW)),REAL(YSCAN(1) -YORIG(IW)), - REAL(XSCAN(NSCANX)-XORIG(IW)),REAL(YSCAN(NSCANY)-YORIG(IW)), - 'x-Offset [cm]','y-Offset [cm]','Contours of the energy') CALL CELLAY( - REAL(XSCAN(1) -XORIG(IW)),REAL(YSCAN(1) -YORIG(IW)), - REAL(XSCAN(NSCANX)-XORIG(IW)),REAL(YSCAN(NSCANY)-YORIG(IW))) *** Plot the energy. CALL GRCONT(OPTENE,CMIN,CMAX, - REAL(XSCAN(1) -XORIG(IW)),REAL(YSCAN(1) -YORIG(IW)), - REAL(XSCAN(NSCANX)-XORIG(IW)),REAL(YSCAN(NSCANY)-YORIG(IW)), - NCONT,.TRUE.,.FALSE.,.TRUE.) *** Next plot. CALL GRNEXT endif END +DECK,OPTENE. SUBROUTINE OPTENE(DX,DY,ETOT,IFAIL) *----------------------------------------------------------------------- * OPTENE - Computes the energy of a parabolic wire deflection by a * distance (DX,DY). The energy is scaled by a common factor * of g * w/1000 of the 2 force components. * (Last changed on 14/ 8/99.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,SHAPEDATA. +SEQ,CONSTANTS. DOUBLE PRECISION XAUX(6),DGMLT2,DDX,DDY REAL EW,EF,ETOT,DX,DY INTEGER IFAIL EXTERNAL DGMLT2,FOPTE2 COMMON /FEODAT/ DDX,DDY *** Assign the shift to the common for use by the integration routines. DDX=DBLE(DX) DDY=DBLE(DY) *** Compute the deflection energy, integrate over the wire. EF=REAL(DGMLT2(FOPTE2,DBLE(-U(IW)/2),DBLE(U(IW)/2),3,6,XAUX)) *** Compute the wire energy. EW=REAL(8*(DDX**2+DDY**2)/(3*U(IW))) *** Return the total. ETOT=EW+EF *** Has worked. IFAIL=0 END +DECK,FOPTE2. SUBROUTINE FOPTE2(M,U2,F2,XAUX) *----------------------------------------------------------------------- * FOPTE2 - Integrates the energy over the wire. * (Last changed on 12/ 8/99.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,SHAPEDATA. DOUBLE PRECISION U2(*),F2(*),XAUX(*),DGMLT1,DDX,DDY INTEGER L,M EXTERNAL FOPTE1,DGMLT1 COMMON /FEODAT/ DDX,DDY *** Loop over the positions. DO 10 L=1,M XAUX(2)=U2(L) F2(L)=DGMLT1(FOPTE1,0.0D0, - (1-(2*XAUX(2)/U(IW))**2)*SQRT(DDX**2+DDY**2),3,6,X) 10 CONTINUE END +DECK,FOPTE1. SUBROUTINE FOPTE1(M,U1,F1,XAUX) *----------------------------------------------------------------------- * FOPTE1 - Integrates the energy over the deflection path. * (Last changed on 12/ 8/99.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,SHAPEDATA. DOUBLE PRECISION U1(*),F1(*),XAUX(*),COOR,BEND(2),DBEND(2),F0(2), - DDX,DDY INTEGER L,M COMMON /FEODAT/ DDX,DDY *** Loop over the wire delections. DO 10 L=1,M * Obtain the deflection. XAUX(1)=U1(L) * Set the sag parameters. COOR=XAUX(2) BEND(1)=DDX*XAUX(1)/SQRT(DDX**2+DDY**2) BEND(2)=DDY*XAUX(1)/SQRT(DDX**2+DDY**2) DBEND(1)=0 DBEND(2)=0 * Compute the force. CALL OPTSTP(COOR,BEND,DBEND,F0) * Take the component in the direction of the bend. F1(L)=(F0(1)*DDX+F0(2)*DDY)/SQRT(DDX**2+DDY**2) 10 CONTINUE END +DECK,OPTINP. SUBROUTINE OPTINP *----------------------------------------------------------------------- * OPTINP - Routine reading cell optimisation instructions. * VARIABLES : * (Last changed on 25/ 3/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. +SEQ,PARAMETERS. +SEQ,CELLDATA. +SEQ,BFIELD. +SEQ,CONSTANTS. +SEQ,OPTDATA. +SEQ,DRIFTLINE. CHARACTER*(MXCHAR) STRING CHARACTER*10 USER REAL XPOS,YPOS INTEGER IDUMMY,NWORD,NC,IFAIL,IFAIL1,IFAIL2,IFAIL3,IFAIL4, - I,IW,ISW,NPOINR,NGRDXR,NGRDYR,NGRIDR,INPCMP,IREFNO LOGICAL STDSTR,CHANGE EXTERNAL STDSTR,INPCMP +SELF,IF=AST. EXTERNAL ASTCCH +SELF. *** Define some formats. 1060 FORMAT(/' The plot area is at present ',F10.3,' < r < ',F10.3/ - ' and ',F10.3,' < phi < ',F10.3/) 1070 FORMAT(/' The track is delimited by (',2F10.3,') and (', - 2F10.3,')'/) 1080 FORMAT(/' The plot area is at present ',F10.3,' < x < ',F10.3/ - ' and ',F10.3,' < y < ',F10.3/) 1090 FORMAT(/' The number of grid points is ',I5,' by ',I5,'.'/) *** Identify the routine. IF(LIDENT)PRINT *,' /// ROUTINE OPTINP ///' *** Print a header for this page. WRITE(*,'(''1'')') PRINT *,' ================================================' PRINT *,' ========== Start optimisation section ==========' PRINT *,' ================================================' PRINT *,' ' *** Open a dataset and save the initial setting. IDUMMY=0 CALL OPTDSN('OPEN',IDUMMY) CALL OPTDSN('SAVE',IREFNO) *** Start an input loop. CALL INPPRM('Optimise','NEW-PRINT') 10 CONTINUE CALL INPWRD(NWORD) +SELF,IF=AST. *** Set up ASTCCH as the condition handler. CALL LIB$ESTABLISH(ASTCCH) +SELF. CALL INPSTR(1,1,STRING,NC) *** Skip the line if blank. IF(NWORD.EQ.0)GOTO 10 *** Return to main program if '&' is the first character. IF(STRING(1:1).EQ.'&')THEN * Close the auxilliary file. CALL OPTDSN('CLOSE',IDUMMY) RETURN *** Look for the ADD instruction. ELSEIF(INPCMP(1,'ADD').NE.0)THEN CALL OPTADD(CHANGE) IF(CHANGE)CALL CELRES(IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! OPTINP WARNING : The new cell'// - ' is not acceptable ; leaving &OPTIMISE.' RETURN ENDIF *** Look for the AREA instruction. ELSEIF(INPCMP(1,'AR#EA').NE.0)THEN CALL CELVIE(PXMIN,PYMIN,PZMIN,PXMAX,PYMAX,PZMAX) CALL INPERR *** Background field. ELSEIF(INPCMP(1,'BACKGR#OUND-#FIELD').NE.0)THEN CALL OPTBGF ELSEIF(INPCMP(1,'DEL#ETE-BACKGR#OUND-#FIELD').NE.0)THEN IF(IENBGF.NE.0)CALL ALGCLR(IENBGF) IENBGF=0 *** Look for 3-dimensional charges. ELSEIF(INPCMP(1,'CHARGE#S').NE.0)THEN * Print a prompt for interactive mode reading of charges. IF(STDSTR('INPUT'))PRINT *,' ====== OPTINP INPUT :'// - ' Please enter the charges, terminate with a'// - ' blank line.' CALL INPPRM('Charges','ADD-NOPRINT') * Initialise number of charges. N3D=0 20 CONTINUE * Input a line and check the basics. CALL INPWRD(NWORD) IF(N3D.GE.MX3D)THEN PRINT *,' !!!!!! OPTINP WARNING : Unable to store'// - ' further charges ; increase MX3D.' ELSEIF(NWORD.EQ.3.OR.NWORD.EQ.4)THEN N3D=N3D+1 CALL INPCHK(1,2,IFAIL1) CALL INPCHK(2,2,IFAIL2) CALL INPCHK(3,2,IFAIL3) CALL INPRDR(1,X3D(N3D),0.0) CALL INPRDR(2,Y3D(N3D),0.0) CALL INPRDR(3,Z3D(N3D),0.0) IF(NWORD.EQ.4)THEN CALL INPCHK(4,2,IFAIL4) CALL INPRDR(4,E3D(N3D),1.0) ELSE IFAIL4=0 E3D(N3D)=1.0 ENDIF CALL INPERR ELSEIF(NWORD.GT.0)THEN PRINT *,' !!!!!! OPTINP WARNING : Incorrect number'// - ' of keywords ; ignoring this charge.' ENDIF IF(NWORD.NE.0)GOTO 20 CALL INPPRM(' ','BACK-PRINT') *** Look for the DELETE-CHARGES instruction. ELSEIF(INPCMP(1,'DEL#ETE-CHA#RGES').NE.0)THEN N3D=0 *** Look for the LIST-CHARGES instruction. ELSEIF(INPCMP(1,'L#IST-CHA#RGES').NE.0)THEN IF(N3D.EQ.0)THEN WRITE(LUNOUT,'('' No three dimensional charges'', - '' are present at the moment.'')') ELSE WRITE(LUNOUT,'('' LIST OF 3-DIMENSIONAL CHARGES''// - '' x-charge [cm] y-charge [cm]'', - '' z-charge [cm] Q [4 pi eps0]''//)') DO 40 I=1,N3D WRITE(LUNOUT,'(1X,4(1X,E15.8))') - X3D(I),Y3D(I),Z3D(I),E3D(I) 40 CONTINUE ENDIF *** Look for the DRIFT-AREA instruction. ELSEIF(INPCMP(1,'DR#IFT-AREA').NE.0)THEN CALL CELVIE(DXMIN,DYMIN,DZMIN,DXMAX,DYMAX,DZMAX) CALL INPERR *** Look for the CHANGE-VOLTAGES instruction. ELSEIF(INPCMP(1,'CHAN#GE-#VOLTAGES').NE.0)THEN CALL OPTCHV *** Look for the DELETE instruction. ELSEIF(INPCMP(1,'DE#LETE').NE.0)THEN CALL OPTDEL(CHANGE) IF(CHANGE)CALL CELRES(IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! OPTINP WARNING : The new cell'// - ' is not acceptable ; leaving &OPTIMISE.' RETURN ENDIF *** Display the potential settings. ELSEIF(INPCMP(1,'DI#SPLAY').NE.0)THEN WRITE(LUNOUT,'('' CURRENT POTENTIAL SETTINGS:'',//, - '' You have selected '',I3,'' groups of wires to be'', - '' varied collectively:'')') NSW DO 110 ISW=1,NSW WRITE(LUNOUT,'(/'' Group '',I3)') ISW DO 100 IW=1,NWIRE IF(INDSW(IW).NE.ISW)GOTO 100 XPOS=X(IW) YPOS=Y(IW) IF(POLAR)CALL CFMRTP(XPOS,YPOS,XPOS,YPOS,1) WRITE(LUNOUT,'(5X,''Wire '',I3,'', code '',A1,'', V='', - E15.8,'', at: ('',E15.8,'','',E15.8,'').'')') - IW,WIRTYP(IW),V(IW),XPOS,YPOS 100 CONTINUE 110 CONTINUE WRITE(LUNOUT,'('' '')') *** Search for the FACTOR instruction. ELSEIF(INPCMP(1,'FA#CTOR').NE.0)THEN CALL OPTFAC *** Read a field map. ELSEIF(INPCMP(1,'FIELD-MAP')+ - INPCMP(1,'READ-FIELD-MAP').NE.0)THEN * Obtain the field map for background field use. CALL BOOK('INQUIRE','MAP',USER,IFAIL) IF(USER.EQ.'CELL')THEN PRINT *,' !!!!!! OPTINP WARNING : Field map is'// - ' currently used for the main field; field'// - ' map not read as background field.' IFAIL=1 ELSEIF(USER.EQ.' ')THEN CALL BOOK('BOOK','MAP','OPTIMISE',IFAIL) IF(IFAIL.NE.0)PRINT *,' !!!!!! OPTINP WARNING :'// - ' Unable to obtain control of the field map'// - ' for use as background field.' ELSEIF(USER.EQ.'OPTIMISE')THEN IFAIL=0 ELSE PRINT *,' !!!!!! OPTINP WARNING : Field map is in'// - ' use by '//USER//' not reallocated.' IFAIL=1 ENDIF * Read the field map. IF(IFAIL.EQ.0)THEN IF(INPCMP(1,'FIELD-MAP').NE.0)THEN CALL MAPREA(IFAIL) ELSE CALL MAPFMF(IFAIL) ENDIF ENDIF * Check the error flag from mapo reading. IF(IFAIL.NE.0)PRINT *,' !!!!!! OPTINP WARNING : Reading'// - ' a field map failed.' *** Delete a field map. ELSEIF(INPCMP(1,'DEL#ETE-F#IELD-MAP')+ - INPCMP(1,'DEL#ETE-MAP').NE.0)THEN * Delete the field map itself. CALL MAPINT CALL BOOK('RELEASE','MAP','OPTIMISE',IFAIL) * Check whether the background field is to be kept. IF(LBGFMP)THEN PRINT *,' ------ OPTINP MESSAGE : Background field'// - ' deleted because of dependence on the field map.' IF(IENBGF.NE.0)CALL ALGCLR(IENBGF) IENBGF=0 ENDIF *** Plot of the forces acting on a wire. ELSEIF(INPCMP(1,'FO#RCES').NE.0)THEN CALL OPTFRC *** Look for the keyword GRID. ELSEIF(INPCMP(1,'G#RID').NE.0)THEN IF(NWORD.EQ.1)THEN PRINT 1090,NGRIDX,NGRIDY ELSEIF(NWORD.EQ.2)THEN CALL INPCHK(2,1,IFAIL1) CALL INPRDI(2,NGRIDR,25) IF(NGRIDR.LE.1.OR.NGRIDR.GT.MXGRID) - CALL INPMSG(2,'GRID out of range 2 -> MXGRID.') CALL INPERR IF(IFAIL1.NE.0.OR.NGRIDR.LE.1.OR.NGRIDR.GT.MXGRID)THEN PRINT *,' !!!!!! OPTINP WARNING : GRID statement', - ' ignored because of syntax or value errors.' ELSE NGRIDX=NGRIDR NGRIDY=NGRIDR ENDIF ELSEIF(NWORD.EQ.3)THEN CALL INPCHK(2,1,IFAIL1) CALL INPCHK(3,1,IFAIL2) CALL INPRDI(2,NGRDXR,25) CALL INPRDI(3,NGRDYR,25) IF(NGRDXR.LE.1.OR.NGRDXR.GT.MXGRID) - CALL INPMSG(2,'out of the range 2 -> MXGRID. ') IF(NGRDYR.LE.1.OR.NGRDYR.GT.MXGRID) - CALL INPMSG(2,'out of the range 2 -> MXGRID. ') CALL INPERR IF(IFAIL1.NE.0.OR.NGRDXR.LE.1.OR.NGRDXR.GT.MXGRID.OR. - NGRDYR.LE.1.OR.NGRDYR.GT.MXGRID)THEN PRINT *,' !!!!!! OPTINP WARNING : GRID statement', - ' ignored because of syntax or value errors.' ELSE NGRIDX=NGRDXR NGRIDY=NGRDYR ENDIF ELSE PRINT *,' !!!!!! OPTINP WARNING : GRID requires 1'// - ' or 2 arguments ; the instruction is ignored.' ENDIF *** Look for the keyword OPTION, ELSEIF(INPCMP(1,'O#PTIONS').NE.0)THEN * No valid options here. DO 30 I=2,NWORD CALL INPMSG(I,'The option is not known. ') 30 CONTINUE CALL INPERR *** Look for the instruction POINT. ELSEIF(INPCMP(1,'P#OINTS').NE.0)THEN IF(NWORD.EQ.1)THEN WRITE(LUNOUT,'('' Current number of points on'', - '' the track: '',I3,''.'')') NPOINT ELSEIF(NWORD.NE.2)THEN PRINT *,' !!!!!! OPTINP WARNING : POINTS requires 1'// - ' argument ; the instruction is ignored.' ELSE CALL INPCHK(2,1,IFAIL1) CALL INPRDI(2,NPOINR,20) IF(NPOINR.LE.1) - CALL INPMSG(2,'POINT should be larger than 1.') CALL INPERR IF(IFAIL1.NE.0.OR.NPOINR.LE.1)THEN PRINT *,' !!!!!! OPTINP WARNING : POINTS is'// - ' ignored because of syntax or value errors.' ELSE NPOINT=NPOINR ENDIF ENDIF *** Print the cell. ELSEIF(INPCMP(1,'PR#INT-#CELL')+INPCMP(1,'C#ELL-PR#INT') - .NE.0)THEN CALL CELPRT *** Retrieve a record. ELSEIF(INPCMP(1,'R#ESTORE').NE.0)THEN IREFNO=1 IFAIL=0 IF(NWORD.GE.2)THEN CALL INPCHK(2,1,IFAIL) CALL INPRDI(2,IREFNO,1) ENDIF IF(NWORD.GT.2)PRINT *,' !!!!!! OPTINP WARNING : RETRIEVE'// - ' takes a single arguments ; the rest is ignored.' IF(IFAIL.EQ.0)THEN CALL OPTDSN('RESTORE',IREFNO) ELSE PRINT *,' !!!!!! OPTINP WARNING : RETRIEVE is'// - ' ignored because of errors.' ENDIF *** Save a record. ELSEIF(INPCMP(1,'SA#VE').NE.0)THEN CALL OPTDSN('SAVE',IREFNO) IF(NWORD.GT.1)PRINT *,' !!!!!! OPTINP WARNING : SAVE'// - ' takes no arguments ; they are ignored.' IF(IREFNO.EQ.0)THEN PRINT *,' !!!!!! OPTINP WARNING : The voltages have'// - ' not been saved.' ELSE WRITE(LUNOUT,'('' ------ OPTINP MESSAGE : Reference'', - '' number for this set of potentials: '',I3)') - IREFNO ENDIF *** Write the field map in binary format. ELSEIF(INPCMP(1,'SAVE-F#IELD-#MAP').NE.0)THEN CALL MAPFMS *** Search for the SELECT instruction. ELSEIF(INPCMP(1,'SEL#ECT').NE.0)THEN CALL CELSEL *** Look for the SET instruction. ELSEIF(INPCMP(1,'SET').NE.0)THEN CALL OPTSET *** Look for the instruction TRACK. ELSEIF(INPCMP(1,'TR#ACK').NE.0)THEN CALL TRAREA *** It is not possible to get here if the keyword is valid. ELSE CALL INPSTR(1,1,STRING,NC) PRINT *,' !!!!!! OPTINP WARNING : '//STRING(1:NC)//' is'// - ' not a valid instruction ; ignored.' ENDIF *** Go on with the next input line. GOTO 10 END +DECK,OPTFAC. SUBROUTINE OPTFAC *----------------------------------------------------------------------- * OPTFAC - Routine which prints the dependence of the field on the * potential of the wires. * Variables : FAC(.,I) : Coefficient of V in V(1), Ex(2), Ey(3) * NDATA : Number of data points used in the average * CVTARS etc : Backup copies of some cell data. * FACTYP : average over (1) grid (2) track (3) wires * EXBACK etc : Background term of the field * CHKEX etc : Debug check on the correctness of the FAC * VCOMP : If .FALSE. grouping is useful. *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,CAPACMATRIX. +SEQ,PRINTPLOT. +SEQ,PARAMETERS. +SEQ,CONSTANTS. DOUBLE PRECISION FAC(3,0:MXWIRE),AIJXJ,AIJYJ,EXBACK,EYBACK, - VTBACK,SUMVT,SUMEX,SUMEY,CHKVT,CHKEX,CHKEY REAL ERES(MXWIRE) INTEGER FACTYP LOGICAL LGROUP,VCOMP,VSET +SELF,IF=SAVE. SAVE LGROUP,FACTYP +SELF. *** Preset the grouping and averaging options. DATA LGROUP /.FALSE./ DATA FACTYP /1/ *** Define the output formats. 1010 FORMAT(' a total of ',I4,' points is effectively used in the', - ' averages.'//' With the present voltage settings, the', - ' field averages are:'/10X,'V = ',E12.5,' Volt,'/10X, - 'Ex = ',E12.5,' V/cm,'/10X,'Ey = ',E12.5,' V/cm.'// - ' These averages are composed of two parts:'/' (1) the', - ' field due to a voltage shift or to non-grounded planes:'/ - 10X,'V = ',E12.5,' Volt,'/10X,'Ex = ',E12.5,' V/cm,'/10X, - 'Ey = ',E12.5,' V/cm.'//' (2) the field exactly linear', - ' in the wire potentials.'/8X,'The factors for each wire', - ' are printed in the table below.'/) *** Identify the subroutine. IF(LIDENT)PRINT *,' /// ROUTINE OPTFAC ///' PRINT *,' !!!!!! ROUTINE BEING WORKED ON !!!!!!' *** First decode the argument list. CALL INPNUM(NWORD) DO 10 I=2,NWORD IF(INPCMP(I,'GR#ID').NE.0)THEN FACTYP=1 ELSEIF(INPCMP(I,'TR#ACK').NE.0)THEN IF(.NOT.TRFLAG(1))THEN CALL INPMSG(I,'The track has not been set. ') ELSE FACTYP=2 ENDIF ELSEIF(INPCMP(I,'WIR#ES').NE.0)THEN FACTYP=3 ELSEIF(INPCMP(I,'GR#OUP').NE.0)THEN LGROUP=.TRUE. ELSEIF(INPCMP(I,'NOGR#OUP').NE.0)THEN LGROUP=.FALSE. ELSE CALL INPMSG(I,'Not a known option. ') ENDIF 10 CONTINUE CALL INPERR *** Print some debugging output. IF(LDEBUG)THEN PRINT *,' ++++++ OPTFAC DEBUG : FACTYP=',FACTYP, - ' LGROUP= ',LGROUP,' NGRIDX=',NGRIDX,' NGRIDY=',NGRIDY PRINT *,' TYPE=',TYPE,', MODE=',MODE ENDIF *** Quit if FACTYP=2 (track) is still on and no track has been set. IF(FACTYP.EQ.2.AND..NOT.TRFLAG(1))THEN PRINT *,' !!!!!! OPTFAC WARNING : The track has not been'// - ' set ; the calculations are not carried out.' RETURN ENDIF *** Recalculate the capacitance matrix (absent if cell is from dataset). CALL SETUP(IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' ###### OPTFAC ERROR : Setting up the'// - ' capacitance matrix failed ; no valid cell' PRINT *,' is available from'// - ' now on, the number of wires is set to 0.' NWIRE=0 RETURN ENDIF *** Loop over the wires, I=0 is used to calculate the current V, EX, EY. DO 110 I=0,NWIRE * First save the charges at the first wire loop. IF(I.EQ.1)THEN CVTARS=CORVTA CVTBRS=CORVTB CVTCRS=CORVTC V0RES =V0 C1RES =C1 CORVTA=0.0 CORVTB=0.0 CORVTC=0.0 V0 =0.0 C1 =0.0 DO 100 J=1,NWIRE ERES(J)=E(J) 100 CONTINUE ENDIF * Next swap the charges and the capacitance matrix elements. IF(I.GT.0)THEN DO 120 J=1,NWIRE E(J)=A(I,J) 120 CONTINUE NDATRF=0 ELSE NDATA=0 VTBACK=0.0 EXBACK=0.0 EYBACK=0.0 ENDIF * Initialise the output array. FAC(1,I)=0.0 FAC(2,I)=0.0 FAC(3,I)=0.0 * Set the linear correction terms for doubly periodic cells. IF(TYPE(1:1).EQ.'C'.AND.I.GT.0)THEN AIJXJ=0.0 AIJYJ=0.0 DO 180 J=1,NWIRE IF(TYPE.EQ.'C1 '.AND.MODE.EQ.0)THEN AIJXJ=AIJXJ+A(I,J)*X(J) ELSEIF(TYPE.EQ.'C1 '.AND.MODE.EQ.1)THEN AIJYJ=AIJYJ+A(I,J)*Y(J) ELSEIF(TYPE.EQ.'C2X'.AND.MODE.EQ.0)THEN AIJXJ=AIJXJ+A(I,J)*(X(J)-COPLAX) ELSEIF(TYPE.EQ.'C2Y'.AND.MODE.EQ.1)THEN AIJYJ=AIJYJ+A(I,J)*(Y(J)-COPLAY) ENDIF 180 CONTINUE AIJXJ=-AIJXJ*2.0*PI/(SX*SY) AIJYJ=-AIJYJ*2.0*PI/(SX*SY) ENDIF * Next do the field calculations, with the modified charges if I > 0. IF(FACTYP.EQ.1)THEN DO 130 IX=1,NGRIDX DO 140 IY=1,NGRIDY CALL EFIELD(PXMIN+REAL(IX-1)*(PXMAX-PXMIN)/REAL(NGRIDX-1), - PYMIN+REAL(IY-1)*(PYMAX-PYMIN)/REAL(NGRIDY-1),0.0, - EX,EY,EZ,ETOT,VOLT,1,ILOC) IF(ILOC.NE.0)GOTO 140 FAC(1,I)=FAC(1,I)+VOLT FAC(2,I)=FAC(2,I)+EX FAC(3,I)=FAC(3,I)+EY IF(I.EQ.0)THEN NDATA=NDATA+1 VTBACK=VTBACK+V0+ - CORVTA*(PXMIN+REAL(IX-1)*(PXMAX-PXMIN)/ - REAL(NGRIDX-1))+ - CORVTB*(PYMIN+REAL(IY-1)*(PYMAX-PYMIN)/ - REAL(NGRIDY-1))+ - CORVTC EXBACK=EXBACK-CORVTA EYBACK=EYBACK-CORVTB ELSE NDATRF=NDATRF+1 IF(TYPE.EQ.'C1 '.AND.MODE.EQ.0)THEN FAC(1,I)=FAC(1,I)+AIJXJ*(PXMIN+REAL(IX-1)* - (PXMAX-PXMIN)/REAL(NGRIDX-1)) FAC(2,I)=FAC(2,I)-AIJXJ ELSEIF(TYPE.EQ.'C1 '.AND.MODE.EQ.1)THEN FAC(1,I)=FAC(1,I)+AIJYJ*(PYMIN+REAL(IY-1)* - (PYMAX-PYMIN)/REAL(NGRIDY-1)) FAC(3,I)=FAC(3,I)-AIJYJ ELSEIF(TYPE.EQ.'C2X'.AND.MODE.EQ.0)THEN FAC(1,I)=FAC(1,I)+AIJXJ*(PXMIN+REAL(IX-1)* - (PXMAX-PXMIN)/REAL(NGRIDX-1)-COPLAX) FAC(2,I)=FAC(2,I)-AIJXJ ELSEIF(TYPE.EQ.'C2Y'.AND.MODE.EQ.1)THEN FAC(1,I)=FAC(1,I)+AIJYJ*(PYMIN+REAL(IY-1)* - (PYMAX-PYMIN)/REAL(NGRIDY-1)-COPLAY) FAC(3,I)=FAC(3,I)-AIJYJ ENDIF ENDIF 140 CONTINUE 130 CONTINUE * Average over the track if FACTYP = 2. ELSEIF(FACTYP.EQ.2)THEN DO 150 IT=1,MXLIST CALL EFIELD(XT0+REAL(IT-1)*(XT1-XT0)/REAL(MXLIST-1), - YT0+REAL(IT-1)*(YT1-YT0)/REAL(MXLIST-1), - ZT0+REAL(IT-1)*(ZT1-ZT0)/REAL(MXLIST-1), - EX,EY,EZ,ETOT,VOLT,1,ILOC) IF(ILOC.NE.0)GOTO 150 FAC(1,I)=FAC(1,I)+VOLT FAC(2,I)=FAC(2,I)+EX FAC(3,I)=FAC(3,I)+EY IF(I.EQ.0)THEN NDATA=NDATA+1 VTBACK=VTBACK+V0+ - CORVTA*(XT0+REAL(IT-1)*(XT1-XT0)/ - REAL(MXLIST-1))+ - CORVTB*(YT0+REAL(IT-1)*(YT1-YT0)/ - REAL(MXLIST-1))+ - CORVTC EXBACK=EXBACK-CORVTA EYBACK=EYBACK-CORVTB ELSE NDATRF=NDATRF+1 IF(TYPE.EQ.'C1 '.AND.MODE.EQ.0)THEN FAC(1,I)=FAC(1,I)+AIJXJ* - (XT0+REAL(IT-1)*(XT1-XT0)/REAL(MXLIST-1)) FAC(2,I)=FAC(2,I)-AIJXJ ELSEIF(TYPE.EQ.'C1 '.AND.MODE.EQ.1)THEN FAC(1,I)=FAC(1,I)+AIJYJ* - (YT0+REAL(IT-1)*(YT1-YT0)/REAL(MXLIST-1)) FAC(3,I)=FAC(3,I)-AIJYJ ELSEIF(TYPE.EQ.'C2X'.AND.MODE.EQ.0)THEN FAC(1,I)=FAC(1,I)+AIJXJ*(XT0+REAL(IT-1)* - (XT1-XT0)/REAL(MXLIST-1)-COPLAX) FAC(2,I)=FAC(2,I)-AIJXJ ELSEIF(TYPE.EQ.'C2Y'.AND.MODE.EQ.1)THEN FAC(1,I)=FAC(1,I)+AIJYJ*(YT0+REAL(IT-1)* - (YT1-YT0)/REAL(MXLIST-1)-COPLAY) FAC(3,I)=FAC(3,I)-AIJYJ ENDIF ENDIF 150 CONTINUE * Loop over the surface of the sense wires if FACTYP = 3. ELSE DO 160 IW=1,NWIRE IF(INDSW(IW).EQ.0)GOTO 160 DO 170 ANG=0.0,1.9*PI,0.2*PI CALL EFIELD(X(IW)+0.51*D(IW)*COS(ANG), - Y(IW)+0.51*D(IW)*SIN(ANG),0.0, - EX,EY,EZ,ETOT,VOLT,1,ILOC) IF(ILOC.NE.0)GOTO 170 FAC(1,I)=FAC(1,I)+VOLT FAC(2,I)=FAC(2,I)+EX FAC(3,I)=FAC(3,I)+EY IF(I.EQ.0)THEN NDATA=NDATA+1 VTBACK=VTBACK+V0+CORVTA*(X(IW)+0.51*D(IW)*COS(ANG))+ - CORVTB*(Y(IW)+0.51*D(IW)*SIN(ANG))+CORVTC EXBACK=EXBACK-CORVTA EYBACK=EYBACK-CORVTB ELSE NDATRF=NDATRF+1 IF(TYPE.EQ.'C1 '.AND.MODE.EQ.0)THEN FAC(1,I)=FAC(1,I)+AIJXJ* - (X(IW)+0.51*D(IW)*COS(ANG)) FAC(2,I)=FAC(2,I)-AIJXJ ELSEIF(TYPE.EQ.'C1 '.AND.MODE.EQ.1)THEN FAC(1,I)=FAC(1,I)+AIJYJ* - (Y(IW)+0.51*D(IW)*SIN(ANG)) FAC(3,I)=FAC(3,I)-AIJYJ ELSEIF(TYPE.EQ.'C2X'.AND.MODE.EQ.0)THEN FAC(1,I)=FAC(1,I)+AIJXJ* - (X(IW)+0.51*D(IW)*COS(ANG)-COPLAX) FAC(2,I)=FAC(2,I)-AIJXJ ELSEIF(TYPE.EQ.'C2Y'.AND.MODE.EQ.1)THEN FAC(1,I)=FAC(1,I)+AIJYJ* - (Y(IW)+0.51*D(IW)*SIN(ANG)-COPLAY) FAC(3,I)=FAC(3,I)-AIJYJ ENDIF ENDIF 170 CONTINUE 160 CONTINUE ENDIF * Stop this routine if NDATA is 0. IF(I.EQ.0.AND.NDATA.LE.0)THEN PRINT *,' !!!!!! OPTFAC WARNING : No output can be printed', - ' because the field is zero at all sampling points.' RETURN ENDIF * Average the EX, EY and V factors over the sampling points. FAC(1,I)=FAC(1,I)/NDATA FAC(2,I)=FAC(2,I)/NDATA FAC(3,I)=FAC(3,I)/NDATA * Add the wire term to the VTBACK sum or average if not yet done. IF(I.GT.0)THEN VTBACK=VTBACK- - (V0RES+CVTARS*X(I)+CVTBRS*Y(I)+CVTCRS)*FAC(1,I) EXBACK=EXBACK- - (V0RES+CVTARS*X(I)+CVTBRS*Y(I)+CVTCRS)*FAC(2,I) EYBACK=EYBACK- - (V0RES+CVTARS*X(I)+CVTBRS*Y(I)+CVTCRS)*FAC(3,I) IF(NDATA.NE.NDATRF)PRINT *,' !!!!!! OPTFAC WARNING : ', - ' Number of sampling points has changed; data for', - ' wire ',I,' are not reliable.' ELSE VTBACK=VTBACK/NDATA EXBACK=EXBACK/NDATA EYBACK=EYBACK/NDATA ENDIF * Continue with the next wire. 110 CONTINUE *** Swap the charges back into place. DO 200 I=1,NWIRE E(I)=ERES(I) 200 CONTINUE CORVTA=CVTARS CORVTB=CVTBRS CORVTC=CVTCRS V0=V0RES C1=C1RES *** Print the results obtained. WRITE(LUNOUT,'(''1 How the field comes about''/ - '' =========================''/)') IF(FACTYP.EQ.1)THEN WRITE(LUNOUT,'('' The data below apply to the average'', - '' field over a grid of '',I3,'' x '',I3,'' points''/ - '' in the area ('',E12.5,'','',E12.5,'') to ('', - E12.5,'','',E12.5,''),'')') - NGRIDX,NGRIDY,PXMIN,PYMIN,PXMAX,PYMAX ELSEIF(FACTYP.EQ.2)THEN WRITE(LUNOUT,'('' The data below apply to the average'', - '' field over a track of '',I3,'' points''/ - '' from ('',E12.5,'','',E12.5,'') to ('', - E12.5,'','',E12.5,''),'')') - MXLIST,XT0,XT1,YT0,YT1 ELSEIF(FACTYP.EQ.3)THEN WRITE(LUNOUT,'('' The data below apply to the average'', - '' field on the surface of the sense wires,'')') ENDIF *** Print the rest of the introductory heading. WRITE(LUNOUT,1010) NDATA,(FAC(I,0),I=1,3),VTBACK,EXBACK,EYBACK ** Printing in case wires should be grouped. IF(LGROUP)THEN WRITE(LUNOUT,'('' Wire V-factor Ex-factor'', - '' Ey-factor Group Tot V-factor Tot Ex-factor'', - '' Tot Ey-factor'')') WRITE(LUNOUT,'('' [numeric] [cm**-1]'', - '' [cm**-1] [numeric] [cm**-1]'', - '' [cm**-1]'')') DO 300 I=0,NSW * Preset summing variables. SUMVT=0.0 SUMEX=0.0 SUMEY=0.0 NSUM=0 * Preset the logicals used to check whether grouping is useful. VCOMP=.FALSE. VSET=.FALSE. VREF=0.0 * Pick out the wires belonging to the group. WRITE(LUNOUT,'('' '')') DO 310 J=1,NWIRE IF(INDSW(J).NE.I)GOTO 310 IF(VSET.AND.V(J).NE.VREF)VCOMP=.TRUE. IF(.NOT.VSET)THEN VREF=V(J) VSET=.TRUE. ENDIF * Add to the totals. NSUM=NSUM+1 SUMVT=SUMVT+FAC(1,J) SUMEX=SUMEX+FAC(2,J) SUMEY=SUMEY+FAC(3,J) WRITE(LUNOUT,'(2X,I5,3(1X,E12.5))') - J,FAC(1,J),FAC(2,J),FAC(3,J) 310 CONTINUE * Print the information collected for this group. IF(I.EQ.0.AND.NSUM.NE.0)WRITE(LUNOUT,'(49X,''Wires not'', - '' belonging to any group.'')') IF(NSUM.EQ.0.OR.I.EQ.0)GOTO 300 IF(.NOT.VCOMP)THEN WRITE(LUNOUT,'(49X,I5,3(1X,E12.5))') - I,SUMVT,SUMEX,SUMEY ELSE WRITE(LUNOUT,'(49X,I5, - '' Meaningless: differing wire voltages.'')') I ENDIF 300 CONTINUE ** Printing in case grouping should not be performed. ELSE WRITE(LUNOUT,'('' Wire V-factor'', - '' Ex-factor Ey-factor'')') WRITE(LUNOUT,'('' [numeric]'', - '' [cm**-1] [cm**-1]''/)') DO 320 I=1,NWIRE WRITE(LUNOUT,'(2X,I5,3(5X,E12.5))') - I,FAC(1,I),FAC(2,I),FAC(3,I) 320 CONTINUE ENDIF ** In case the debug option was specified, verify the sums. IF(LDEBUG)THEN CHKVT=VTBACK CHKEX=EXBACK CHKEY=EYBACK DO 400 I=1,NWIRE CHKVT=CHKVT+FAC(1,I)*V(I) CHKEX=CHKEX+FAC(2,I)*V(I) CHKEY=CHKEY+FAC(3,I)*V(I) 400 CONTINUE PRINT *,' ++++++ OPTFAC DEBUG : Summing the wire', - ' contributions and the background yields:' WRITE(*,'(10X,''V = '',E12.5,'' Volt,''/10X,''Ex = '', - E12.5,'' V/cm,''/10X,''Ey = '',E12.5,'' V/cm.'')') - CHKVT,CHKEX,CHKEY ENDIF ** Make sure that the next output line starts on a fresh page. WRITE(LUNOUT,'(''1'')') *** Register the amount of CPU time used with TIMLOG. CALL TIMLOG('Printing V, Ex and Ey factors: ') END +DECK,OPTSET. SUBROUTINE OPTSET *----------------------------------------------------------------------- * OPTSET - Routine attempting to find proper voltage settings. * (Last changed on 20/10/99.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. +SEQ,CELLDATA. +SEQ,GASDATA. +SEQ,OPTDATA. +SEQ,PARAMETERS. CHARACTER*10 VARLIS(MXVAR) LOGICAL FLAG(MXWORD+1),USE(MXVAR),LFITPR,OK INTEGER NITMAX,NWORD,I,INEXT,NRES,IFAIL,NPNT,NPAR,INPCMP DOUBLE PRECISION XFIT(MXFPNT),YFIT(MXFPNT),WEIGHT(MXFPNT), - AFIT(MXFPAR),EAFIT(MXFPAR),CHI2,DIST,EPS REAL VFIT(MXWIRE),VPLFIT(5),DISTR,EPSR,AVER EXTERNAL OPTFUN,INPCMP +SELF,IF=SAVE. SAVE DIST,EPS,NITMAX,LFITPR +SELF. DATA DIST,EPS /1.0D0,1.0D-4/ DATA NITMAX /10/ DATA LFITPR /.TRUE./ *** Decode the argument string, first get the number of arguments. CALL INPNUM(NWORD) ** Preset the flagging logicals. DO 10 I=1,MXWORD+1 FLAG(I)=.FALSE. IF(INPCMP(I,'A#VERAGE')+INPCMP(I,'D#ISTANCE')+ - INPCMP(I,'EPS#ILON')+ - INPCMP(I,'I#TERATE-#LIMIT')+INPCMP(I,'G#RID')+ - INPCMP(I,'NOPR#INT')+INPCMP(I,'ON')+INPCMP(I,'PR#INT')+ - INPCMP(I,'TO')+INPCMP(I,'TR#ACK')+INPCMP(I,'W#IRE').NE.0.OR. - I.GT.NWORD)FLAG(I)=.TRUE. 10 CONTINUE * The first arguments is normally the function. IF(NWORD.GT.1.AND..NOT.FLAG(2))THEN INEXT=3 CALL INPSTR(2,2,FUNFLD,NFLD) ELSE INEXT=2 ENDIF * Keep track of errors in the input. OK=.TRUE. * Loop over the arguments. DO 20 I=2,NWORD IF(I.LT.INEXT)GOTO 20 * Set the maximum-norm. IF(INPCMP(I,'D#ISTANCE').NE.0)THEN IF(FLAG(I+1))THEN CALL INPMSG(I,'No value of the norm present. ') OK=.FALSE. ELSE CALL INPCHK(I+1,2,IFAIL) CALL INPRDR(I+1,DISTR,1.0) DIST=DISTR INEXT=I+2 ENDIF * Set the differentiation and change parameter. ELSEIF(INPCMP(I,'EPS#ILON').NE.0)THEN IF(FLAG(I+1))THEN CALL INPMSG(I,'No value of EPSILON present. ') OK=.FALSE. ELSE CALL INPCHK(I+1,2,IFAIL) CALL INPRDR(I+1,EPSR,1.0E-4) EPS=EPSR INEXT=I+2 ENDIF * Set the iteration limit. ELSEIF(INPCMP(I,'I#TERATE-#LIMIT').NE.0)THEN IF(FLAG(I+1))THEN CALL INPMSG(I,'No iteration bound present. ') OK=.FALSE. ELSE CALL INPCHK(I+1,1,IFAIL) CALL INPRDI(I+1,NITMAX,10) INEXT=I+2 ENDIF * Select the NOPRINT option. ELSEIF(INPCMP(I,'NOPR#INT').NE.0)THEN LFITPR=.FALSE. * Find the domain. ELSEIF(INPCMP(I,'ON').NE.0)THEN IF(INPCMP(I+1,'TR#ACK').NE.0)THEN IF(TRFLAG(1))THEN PNTTYP='TRACK' INEXT=I+2 ELSE CALL INPMSG(I+1,'No track has been defined. ') OK=.FALSE. ENDIF ELSEIF(INPCMP(I+1,'G#RID').NE.0)THEN PNTTYP='GRID' INEXT=I+2 ELSEIF(INPCMP(I+1,'W#IRE').NE.0)THEN PNTTYP='WIRE' INEXT=I+2 ENDIF * Select the PRINT option. ELSEIF(INPCMP(I,'PR#INT').NE.0)THEN LFITPR=.TRUE. * Find the target function. ELSEIF(INPCMP(I,'TO').NE.0)THEN IF(INPCMP(I+1,'A#VERAGE').NE.0)THEN VALTYP='AVERAGE' INEXT=I+2 ELSEIF(.NOT.FLAG(I+1))THEN CALL INPSTR(I+1,I+1,FUNPOS,NPOS) VALTYP='FUNCTION' INEXT=I+2 ENDIF * Valid keyword out of context. ELSEIF(INPCMP(I,'TR#ACK')+INPCMP(I,'G#RID')+ - INPCMP(I,'A#VERAGE').NE.0)THEN CALL INPMSG(I,'Valid keyword out of context. ') OK=.FALSE. * Weighting function. ELSEIF(INPCMP(I,'W#EIGHT').NE.0)THEN IF(FLAG(I+1))THEN CALL INPMSG(I,'No weighting function found. ') OK=.FALSE. ELSE CALL INPSTR(I+1,I+1,FUNWGT,NWGT) INEXT=I+2 ENDIF * Keyword unknown. ELSE CALL INPMSG(I,'Not a known keyword. ') OK=.FALSE. ENDIF 20 CONTINUE ** Dump error messages, if any. CALL INPERR *** Take action depending on the state of OK. IF(.NOT.OK)THEN IF(JFAIL.EQ.1)THEN PRINT *,' !!!!!! OPTSET WARNING : Errors found in'// - ' the command; trying with defaults.' ELSEIF(JFAIL.EQ.2)THEN PRINT *,' !!!!!! OPTSET WARNING : Errors found in'// - ' the command; no attempt to achieve settings.' RETURN ELSE PRINT *,' !!!!!! OPTSET WARNING : Errors found in'// - ' the command; terminating program execution.' CALL QUIT ENDIF ENDIF *** Generate some debugging output. IF(LDEBUG)THEN WRITE(LUNOUT,'('' ++++++ OPTSET DEBUG : The function '', - A,'' has to approximate'')') FUNFLD(1:NFLD) IF(VALTYP.EQ.'AVERAGE')WRITE(LUNOUT,'(26X,''the current'', - '' average of the function,'')') IF(VALTYP.EQ.'FUNCTION')WRITE(LUNOUT,'(26X,''the value of'', - '' the function '',A,'','')') FUNPOS(1:NPOS) WRITE(LUNOUT,'(26X,''using '',A, - '' as weighting function.'')') FUNWGT(1:NWGT) WRITE(LUNOUT,'(26X,''Averaging takes place over the '',A)') - PNTTYP WRITE(LUNOUT,'(26X,''Maximum distance='',E10.3,'', eps='', - E10.3,'', NITMAX='',I3,''.'')') DIST,EPS,NITMAX ENDIF *** Get the number of 'S' wires if the WIRE option has been selected. IF(PNTTYP.EQ.'WIRE')THEN NSWIRE=0 DO 30 I=1,NWIRE IF(WIRTYP(I).EQ.'S')NSWIRE=NSWIRE+1 30 CONTINUE ENDIF *** Convert the field function, first set variable names. IF(POLAR)THEN VARLIS(1)='R ' VARLIS(2)='PHI ' VARLIS(3)='ER ' VARLIS(4)='EPHI ' ELSE VARLIS(1)='X ' VARLIS(2)='Y ' VARLIS(3)='EX ' VARLIS(4)='EY ' ENDIF VARLIS(5)='E ' VARLIS(6)='V ' * Drift related information. VARLIS(7)='TIME ' VARLIS(8)='DIFFUSION ' VARLIS(9)='AVALANCHE ' C VARLIS(10)='LORENTZ ' * Conversion of the field-function (dependence check + average). CALL ALGPRE(FUNFLD(1:NFLD),NFLD,VARLIS, 9,NRES,USE,IENFLD,IFAIL) * Check the output. IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! OPTSET WARNING : SET not executed'// - ' because of an error in the field function.' CALL ALGCLR(IENFLD) RETURN ELSEIF(NRES.NE.1)THEN PRINT *,' !!!!!! OPTSET WARNING : SET not executed'// - ' because the field function does not return a', - ' single value.' CALL ALGCLR(IENFLD) RETURN ELSEIF(.NOT.(USE(3).OR.USE(4).OR.USE(5).OR.USE(6).OR. - USE(7).OR.USE(8).OR.USE(9)))THEN PRINT *,' !!!!!! OPTSET WARNING : SET not executed'// - ' because the field function is field independent.' CALL ALGCLR(IENFLD) RETURN ENDIF * Check whether we have to evaluate V. IF(USE(6))THEN IOPT=1 ELSE IOPT=0 ENDIF * Drift velocity data. IF(USE(7).AND..NOT.GASOK(1))THEN PRINT *,' !!!!!! OPTSET WARNING : The field function uses'// - ' the drift time but drift' PRINT *,' velocity data has not'// - ' been entered; not executed.' CALL ALGCLR(IENFLD) RETURN ELSEIF(USE(7) )THEN EVALT=.TRUE. ELSE EVALT=.FALSE. ENDIF * Diffusion data. IF(USE(8).AND..NOT.GASOK(3))THEN PRINT *,' !!!!!! OPTSET WARNING : The field function uses'// - ' the diffusion but diffusion' PRINT *,' coefficients have not'// - ' been entered; not executed.' CALL ALGCLR(IENFLD) RETURN ELSEIF(USE(8))THEN EVALD=.TRUE. ELSE EVALD=.FALSE. ENDIF * Avalanche data. IF(USE(9).AND..NOT.GASOK(4))THEN PRINT *,' !!!!!! OPTSET WARNING : The field function uses'// - ' the avalanche but Townsend' PRINT *,' coefficients have not'// - ' been entered; not executed.' CALL ALGCLR(IENFLD) RETURN ELSEIF(USE(9))THEN EVALA=.TRUE. ELSE EVALA=.FALSE. ENDIF * Any of the above for other than TRACK or GRID. IF((USE(7).OR.USE(8).OR.USE(9)).AND.PNTTYP.EQ.'WIRE')THEN PRINT *,' !!!!!! OPTSET WARNING : Drift time, diffusion'// - ' and multiplication not allowed with ON WIRE.' CALL ALGCLR(IENFLD) RETURN ENDIF *** Get the average of the field function, if needed. IF(VALTYP.EQ.'AVERAGE')THEN CALL OPTAVE(AVER,IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! OPTSET WARNING : Unable to evaluate'// - ' the current function average.' CALL ALGCLR(IENFLD) RETURN ENDIF IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ OPTSET DEBUG : The'', - '' current field-function average is '',E15.8)') AVER WRITE(FUNPOS,'(E15.8,65X)') AVER NPOS=15 ENDIF *** Convert the target and weight functions, set variable names. IF(POLAR)THEN VARLIS(1)='R ' VARLIS(2)='PHI ' ELSE VARLIS(1)='X ' VARLIS(2)='Y ' ENDIF * The conversion itself. CALL ALGPRE(FUNPOS(1:NPOS),NPOS,VARLIS,2,NRES,USE,IENPOS,IFAIL) * Check the output. IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! OPTSET WARNING : SET not executed'// - ' because of an error in the position function.' CALL ALGCLR(IENFLD) CALL ALGCLR(IENPOS) RETURN ELSEIF(NRES.NE.1)THEN PRINT *,' !!!!!! OPTSET WARNING : SET not executed'// - ' because the position function does not return'// - ' a single value.' CALL ALGCLR(IENFLD) CALL ALGCLR(IENPOS) RETURN ENDIF ** Conversion of the weight-function. CALL ALGPRE(FUNWGT(1:NWGT),NWGT,VARLIS,2,NRES,USE,IENWGT,IFAIL) * Check the output. IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! OPTSET WARNING : SET not executed'// - ' because of an error in the weight function.' CALL ALGCLR(IENFLD) CALL ALGCLR(IENWGT) CALL ALGCLR(IENPOS) RETURN ELSEIF(NRES.NE.1)THEN PRINT *,' !!!!!! OPTSET WARNING : SET not executed'// - ' because the weight function does not return a', - ' single value.' CALL ALGCLR(IENFLD) CALL ALGCLR(IENWGT) CALL ALGCLR(IENPOS) RETURN ENDIF *** Set the fitting input parameters. CALL OPTXYA(XFIT,YFIT,AFIT,WEIGHT,IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! OPTSET WARNING : SET not executed'// - ' because setting fitting parameters failed.' CALL ALGCLR(IENFLD) CALL ALGCLR(IENWGT) CALL ALGCLR(IENPOS) RETURN ENDIF *** Carry out the fitting itself. IF(PNTTYP.EQ.'GRID')THEN NPNT=NGRIDX*NGRIDY ELSEIF(PNTTYP.EQ.'TRACK')THEN NPNT=NPOINT ELSEIF(PNTTYP.EQ.'WIRE')THEN NPNT=NSWIRE ENDIF NPAR=NSW CALL LSQFIT(OPTFUN,AFIT,EAFIT,NPAR,XFIT,YFIT,WEIGHT,NPNT, - NITMAX,DIST,CHI2,EPS,LFITPR,IFAIL) IF(IFAIL.NE.0)PRINT *,' !!!!!! OPTSET WARNING : The new'// - ' potentials do not fulfill your requirements.' *** And calculate the charges for the final result. DO 100 I=1,NWIRE IF(INDSW(I).NE.0)THEN VFIT(I)=VST(I)+AFIT(INDSW(I)) ELSE VFIT(I)=VST(I) ENDIF 100 CONTINUE DO 110 I=1,4 IF(YNPLAN(I).AND.INDPLA(I).NE.0)THEN VPLFIT(I)=VPLST(I)+AFIT(INDPLA(I)) ELSE VPLFIT(I)=VPLST(I) ENDIF 110 CONTINUE IF(TUBE.AND.INDPLA(5).NE.0)THEN VPLFIT(5)=VPLST(5)+AFIT(INDPLA(5)) ELSE VPLFIT(5)=VPLST(5) ENDIF CALL SETNEW(VFIT,VPLFIT,IFAIL) IF(IFAIL.NE.0)PRINT *,' !!!!!! OPTSET WARNING : Failure to'// - ' compute the wire charges for the final settings.' *** Release the field and position function instruction list. CALL ALGCLR(IENFLD) CALL ALGCLR(IENWGT) CALL ALGCLR(IENPOS) *** Register the amount of CPU time spent on these calculations. CALL TIMLOG('Playing with the voltage settings: ') END +DECK,OPTFUN. SUBROUTINE OPTFUN(PNT,AFIT,VALUE) *----------------------------------------------------------------------- * OPTFUN - Function returning the value of the field function at the * position corresponding to PNT (integer code). * (Last changed on 20/10/99.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,CAPACMATRIX. +SEQ,OPTDATA. +SEQ,PARAMETERS. +SEQ,CONSTANTS. +SEQ,DRIFTLINE. DOUBLE PRECISION PNT,AFIT(MXFPAR),VALUE REAL RES(1),VAR(MXVAR),VFIT(MXWIRE),EX,EY,EZ,ETOT,VOLT,DRES,QPLT, - ANG,VPLFIT(5) INTEGER MODVAR(MXVAR),MODRES(1),I,ITYPE,ILOC,ISWIRE,IFAIL,IPOS, - JPOS *** Drift line parameters. QPLT=-1.0 ITYPE=1 *** First set the potentials. DO 10 I=1,NWIRE IF(INDSW(I).NE.0)THEN VFIT(I)=VST(I)+AFIT(INDSW(I)) ELSE VFIT(I)=VST(I) ENDIF 10 CONTINUE DO 20 I=1,4 IF(YNPLAN(I).AND.INDPLA(I).NE.0)THEN VPLFIT(I)=VPLST(I)+AFIT(INDPLA(I)) ELSE VPLFIT(I)=VPLST(I) ENDIF 20 CONTINUE IF(TUBE.AND.INDPLA(5).NE.0)THEN VPLFIT(5)=VPLST(5)+AFIT(INDPLA(5)) ELSE VPLFIT(5)=VPLST(5) ENDIF *** Next reconstruct the charges. CALL SETNEW(VFIT,VPLFIT,IFAIL) IF(IFAIL.NE.0)THEN VALUE=0.0 RETURN ENDIF *** Find out to which coordinate PNT belongs. C if(abs(pnt-anint(pnt)).gt.1.0e-5)print *,' Rounding error !!!' IF(PNTTYP.EQ.'TRACK')THEN VAR(1)=XT0+(PNT-1.0)*(XT1-XT0)/REAL(NPOINT-1) VAR(2)=YT0+(PNT-1.0)*(YT1-YT0)/REAL(NPOINT-1) IF(POLAR)CALL CFMCTR(VAR(1),VAR(2),VAR(1),VAR(2),1) CALL EFIELD(VAR(1),VAR(2),0.0, - VAR(3),VAR(4),EZ,VAR(5),VAR(6), - IOPT,ILOC) IF(EVALT.OR.EVALD.OR.EVALA)THEN CALL DLCALC(VAR(1),VAR(2),0.0,QPLT,ITYPE) VAR(7)=TU(NU) IF(EVALD)CALL DLCDIF(VAR(8)) IF(EVALA)CALL DLCTWN(VAR(9)) ENDIF ELSEIF(PNTTYP.EQ.'GRID')THEN JPOS=1+NINT(PNT-1.0)/NGRIDX IPOS=NINT(PNT)-NGRIDX*(JPOS-1) IF(.NOT.POLAR)THEN VAR(1)=PXMIN+REAL(IPOS-1)*(PXMAX-PXMIN)/REAL(NGRIDX-1) ELSE VAR(1)=LOG(EXP(PXMIN)+REAL(IPOS-1)* - (EXP(PXMAX)-EXP(PXMIN))/REAL(NGRIDX-1)) ENDIF VAR(2)=PYMIN+REAL(JPOS-1)*(PYMAX-PYMIN)/REAL(NGRIDY-1) CALL EFIELD(VAR(1),VAR(2),0.0, - VAR(3),VAR(4),EZ,VAR(5),VAR(6), - IOPT,ILOC) IF(EVALT.OR.EVALD.OR.EVALA)THEN CALL DLCALC(VAR(1),VAR(2),0.0,QPLT,ITYPE) VAR(7)=TU(NU) IF(EVALD)CALL DLCDIF(VAR(8)) IF(EVALA)CALL DLCTWN(VAR(9)) ENDIF ELSEIF(PNTTYP.EQ.'WIRE')THEN ISWIRE=0 DO 50 I=1,NWIRE IF(WIRTYP(I).EQ.'S')ISWIRE=ISWIRE+1 IF(ISWIRE.EQ.NINT(PNT))THEN DRES=D(I) D(I)=0.0 VAR(1)=X(I) VAR(2)=Y(I) VAR(3)=0.0 VAR(4)=0.0 VAR(5)=0.0 VAR(6)=0.0 DO 60 ANG=0.0,(2.0-1.0/REAL(NPOINT))*PI, - 2.0*PI/REAL(NPOINT) CALL EFIELD(X(I)+COS(ANG)*DRES/2, - Y(I)+SIN(ANG)*DRES/2,0.0, - EX,EY,EZ,ETOT,VOLT,IOPT,ILOC) VAR(5)=VAR(5)+ETOT VAR(6)=VAR(6)+VOLT 60 CONTINUE VAR(5)=VAR(5)/REAL(NPOINT) VAR(6)=VAR(6)/REAL(NPOINT) D(I)=DRES GOTO 70 ENDIF 50 CONTINUE 70 CONTINUE VAR(7)=0.0 VAR(8)=0.0 VAR(9)=0.0 ENDIF *** Transform to polar if needed. IF(POLAR)THEN CALL CFMRTP(VAR(1),VAR(2),VAR(1),VAR(2),1) VAR(3)=VAR(3)/VAR(1) VAR(4)=VAR(4)/VAR(1) VAR(5)=VAR(5)/VAR(1) ENDIF *** Fill in the mode of the variables. DO 80 I=1,9 MODVAR(I)=2 80 CONTINUE *** Calculate the field function with this field. CALL ALGEXE(IENFLD,VAR,MODVAR,9,RES,MODRES,1,IFAIL) *** And return the answer to LSQFIT. VALUE=RES(1) END +DECK,OPTXYA. SUBROUTINE OPTXYA(XFIT,YFIT,AFIT,WEIGHT,IFAIL) *----------------------------------------------------------------------- * OPTXYA - Routine fixing the X, Y and A vectors for the fit. * (Last changed on 20/10/99.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,OPTDATA. +SEQ,CELLDATA. +SEQ,PARAMETERS. REAL RES(1),VAR(MXVAR),VSUM DOUBLE PRECISION XFIT(MXFPNT),YFIT(MXFPNT),WEIGHT(MXFPNT), - AFIT(MXFPAR) INTEGER MODVAR(MXVAR),MODRES(1),IFAIL,I,J,ISWIRE,ISW,IW,IP,NSUM *** Check the size of the problem. IF((PNTTYP.EQ.'TRACK'.AND.NPOINT.GT.MXFPNT).OR. - (PNTTYP.EQ.'WIRE'.AND.NSWIRE.GT.MXFPNT).OR. - (PNTTYP.EQ.'GRID'.AND.NGRIDX*NGRIDY.GT.MXFPNT))THEN PRINT *,' !!!!!! OPTXYA WARNING : The number of points'// - ' in the fit is too large ; decrease GRID or POINTS'// - ' as appropriate.' IFAIL=1 RETURN ENDIF IF((PNTTYP.EQ.'TRACK'.AND.NPOINT.LT.1).OR. - (PNTTYP.EQ.'WIRE'.AND.NSWIRE.LT.1).OR. - (PNTTYP.EQ.'GRID'.AND.NGRIDX*NGRIDY.LT.1))THEN PRINT *,' !!!!!! OPTXYA WARNING : The number of points'// - ' in the fit is too small ; increase GRID or POINTS'// - ' as appropriate.' IFAIL=1 RETURN ENDIF *** Loop over the track or ... IF(PNTTYP.EQ.'TRACK')THEN DO 10 I=1,NPOINT * Internal coordinate. XFIT(I)=I * Position variables. VAR(1)=XT0+REAL(I-1)*(XT1-XT0)/REAL(NPOINT-1) VAR(2)=YT0+REAL(I-1)*(YT1-YT0)/REAL(NPOINT-1) IF(POLAR)CALL CFMCTP(VAR(1),VAR(2),VAR(1),VAR(2),1) MODVAR(1)=2 MODVAR(2)=2 * Position dependent target function. CALL ALGEXE(IENPOS,VAR,MODVAR,2,RES,MODRES,1,IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! OPTXYA WARNING : Arithmetic error'// - ' evaluating the position function.' RETURN ENDIF YFIT(I)=RES(1) * Position dependent weighting function. CALL ALGEXE(IENWGT,VAR,MODVAR,2,RES,MODRES,1,IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! OPTXYA WARNING : Arithmetic error'// - ' evaluating the weighting function.' RETURN ELSEIF(RES(1).LE.0.0)THEN PRINT *,' !!!!!! OPTXYA WARNING : The weighting'// - ' function is not >0 at (',VAR(1),',',VAR(2),').' RETURN ENDIF WEIGHT(I)=RES(1) 10 CONTINUE *** over the grid or ... ELSEIF(PNTTYP.EQ.'GRID')THEN DO 30 I=1,NGRIDX DO 20 J=1,NGRIDY * Internal coordinate. XFIT(I+NGRIDX*(J-1))=I+NGRIDX*(J-1) * Grid position. IF(.NOT.POLAR)THEN VAR(1)=PXMIN+REAL(I-1)*(PXMAX-PXMIN)/REAL(NGRIDX-1) ELSE VAR(1)=LOG(EXP(PXMIN)+REAL(I-1)* - (EXP(PXMAX)-EXP(PXMIN))/REAL(NGRIDX-1)) ENDIF VAR(2)=PYMIN+REAL(J-1)*(PYMAX-PYMIN)/REAL(NGRIDY-1) IF(POLAR)CALL CFMRTP(VAR(1),VAR(2),VAR(1),VAR(2),1) MODVAR(1)=2 MODVAR(2)=2 * Position dependent target function. CALL ALGEXE(IENPOS,VAR,MODVAR,2,RES,MODRES,1,IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! OPTXYA WARNING : Arithmetic error'// - ' evaluating the position function.' RETURN ENDIF YFIT(I+NGRIDX*(J-1))=RES(1) * Position dependent weighting function. CALL ALGEXE(IENWGT,VAR,MODVAR,2,RES,MODRES,1,IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! OPTXYA WARNING : Arithmetic error'// - ' evaluating the weighting function.' RETURN ELSEIF(RES(1).EQ.0.0)THEN PRINT *,' !!!!!! OPTXYA WARNING : The weighting'// - ' function is zero at (',VAR(1),',',VAR(2),').' RETURN ENDIF WEIGHT(I+NGRIDX*(J-1))=RES(1) 20 CONTINUE 30 CONTINUE *** over the wire surface or ... ELSEIF(PNTTYP.EQ.'WIRE')THEN ISWIRE=0 DO 50 I=1,NWIRE * Wire selection. IF(WIRTYP(I).NE.'S')GOTO 50 ISWIRE=ISWIRE+1 * Internal coordinate. XFIT(ISWIRE)=ISWIRE * Position. VAR(1)=X(I) VAR(2)=Y(I) IF(POLAR)CALL CFMRTP(VAR(1),VAR(2),VAR(1),VAR(2),1) MODVAR(1)=2 MODVAR(2)=2 * Position dependent target function. CALL ALGEXE(IENPOS,VAR,MODVAR,2,RES,MODRES,1,IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! OPTXYA WARNING : Arithmetic error'// - ' evaluating the position function.' RETURN ENDIF YFIT(ISWIRE)=RES(1) * Position dependent weighting function. CALL ALGEXE(IENWGT,VAR,MODVAR,2,RES,MODRES,1,IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! OPTXYA WARNING : Arithmetic error'// - ' evaluating the weighting function.' RETURN ELSEIF(RES(1).EQ.0.0)THEN PRINT *,' !!!!!! OPTXYA WARNING : The weighting'// - ' function is zero for wire ',I,'.' RETURN ENDIF WEIGHT(ISWIRE)=RES(1) 50 CONTINUE *** over something unknown. ELSE PRINT *,' ###### OPTXYA ERROR : Unknown averaging type ', - PNTTYP,' received; program bug - please report.' IFAIL=1 RETURN ENDIF *** Next set the parameters to be fitted, check size first. IF(NSW.GT.MXFPAR)THEN PRINT *,' !!!!!! OPTXYA WARNING : The number of'// - ' electrode groups is too large ; decrease to ', - MXFPAR,'.' IFAIL=1 RETURN ENDIF IF(NSW.LT.1)THEN PRINT *,' !!!!!! OPTXYA WARNING : There are no'// - ' electrode groups ; use SELECT to get some.' IFAIL=1 RETURN ENDIF * Loop over the electrode groups. DO 120 ISW=1,NSW * Sum the current potential of the fitting parameters. VSUM=0.0 NSUM=0 DO 130 IW=1,NWIRE IF(INDSW(IW).EQ.ISW)THEN VSUM=VSUM+V(IW) NSUM=NSUM+1 ENDIF 130 CONTINUE DO 140 IP=1,4 IF(YNPLAN(IP).AND.INDPLA(IP).EQ.ISW)THEN VSUM=VSUM+VTPLAN(IP) NSUM=NSUM+1 ENDIF 140 CONTINUE IF(TUBE.AND.INDPLA(5).EQ.ISW)THEN VSUM=VSUM+VTTUBE NSUM=NSUM+1 ENDIF * Take the average. IF(NSUM.EQ.0)THEN PRINT *,' !!!!!! OPTXYA WARNING : Group ',ISW,' is'// - ' empty; SET not executed.' IFAIL=1 RETURN ENDIF AFIT(ISW)=VSUM/NSUM 120 CONTINUE *** Subtract from the original settings and store as starting values. DO 150 IW=1,NWIRE IF(INDSW(IW).GT.0)THEN VST(IW)=V(IW)-AFIT(INDSW(IW)) ELSE VST(IW)=V(IW) ENDIF 150 CONTINUE DO 160 IP=1,4 IF(YNPLAN(IP).AND.INDPLA(IP).GT.0)THEN VPLST(IP)=VTPLAN(IP)-AFIT(INDPLA(IP)) ELSE VPLST(IP)=VTPLAN(IP) ENDIF 160 CONTINUE IF(TUBE.AND.INDPLA(5).GT.0)THEN VPLST(5)=VTTUBE-AFIT(INDPLA(5)) ELSE VPLST(5)=VTTUBE ENDIF *** Things seem to be OK, set IFAIL to 0 and return. IFAIL=0 END +DECK,OPTAVE. SUBROUTINE OPTAVE(AVER,IFAIL) *----------------------------------------------------------------------- * OPTAVE - Routine returning the current function average. * (Last changed on 10/ 9/97.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,OPTDATA. +SEQ,PARAMETERS. +SEQ,CONSTANTS. +SEQ,DRIFTLINE. REAL VAR(MXVAR),RES(1),QPLT,AVER,ANG,DRES,EZ INTEGER MODVAR(MXVAR),MODRES(1),ITYPE,IFAIL,I,J,NDATA,ILOC *** Drift line parameters. QPLT=-1.0 ITYPE=1 *** Preset the sum and the number of data-points. AVER=0.0 NDATA=0 *** The variable modes never change. DO 5 I=1,9 MODVAR(I)=2 5 CONTINUE *** Loop over the track or ... IF(PNTTYP.EQ.'TRACK')THEN DO 10 I=1,NPOINT VAR(1)=XT0+REAL(I-1)*(XT1-XT0)/REAL(NPOINT-1) VAR(2)=YT0+REAL(I-1)*(YT1-YT0)/REAL(NPOINT-1) IF(POLAR)CALL CFMCTR(VAR(1),VAR(2),VAR(1),VAR(2),1) CALL EFIELD(VAR(1),VAR(2),0.0, - VAR(3),VAR(4),EZ,VAR(5),VAR(6), - IOPT,ILOC) IF(EVALT.OR.EVALD.OR.EVALA)THEN CALL DLCALC(VAR(1),VAR(2),0.0,QPLT,ITYPE) VAR(7)=TU(NU) IF(EVALD)CALL DLCDIF(VAR(8)) IF(EVALA)CALL DLCTWN(VAR(9)) ENDIF IF(ILOC.EQ.0)THEN IF(POLAR)THEN CALL CFMRTP(VAR(1),VAR(2),VAR(1),VAR(2),1) VAR(3)=VAR(3)/VAR(1) VAR(4)=VAR(4)/VAR(1) VAR(5)=VAR(5)/VAR(1) ENDIF CALL ALGEXE(IENFLD,VAR,MODVAR,9,RES,MODRES,1,IFAIL) IF(IFAIL.EQ.0)THEN AVER=AVER+RES(1) NDATA=NDATA+1 ENDIF ENDIF 10 CONTINUE *** over the grid. ELSEIF(PNTTYP.EQ.'GRID')THEN DO 30 I=1,NGRIDX DO 20 J=1,NGRIDY IF(.NOT.POLAR)THEN VAR(1)=PXMIN+REAL(I-1)*(PXMAX-PXMIN)/REAL(NGRIDX-1) ELSE VAR(1)=LOG(EXP(PXMIN)+REAL(I-1)* - (EXP(PXMAX)-EXP(PXMIN))/REAL(NGRIDX-1)) ENDIF VAR(2)=PYMIN+REAL(J-1)*(PYMAX-PYMIN)/REAL(NGRIDY-1) CALL EFIELD(VAR(1),VAR(2),0.0, - VAR(3),VAR(4),EZ,VAR(5),VAR(6), - IOPT,ILOC) IF(EVALT.OR.EVALD.OR.EVALA)THEN CALL DLCALC(VAR(1),VAR(2),0.0,QPLT,ITYPE) VAR(7)=TU(NU) IF(EVALD)CALL DLCDIF(VAR(8)) IF(EVALA)CALL DLCTWN(VAR(9)) ENDIF IF(ILOC.EQ.0)THEN IF(POLAR)THEN CALL CFMRTP(VAR(1),VAR(2),VAR(1),VAR(2),1) VAR(3)=VAR(3)/VAR(1) VAR(4)=VAR(4)/VAR(1) VAR(5)=VAR(5)/VAR(1) ENDIF CALL ALGEXE(IENFLD,VAR,MODVAR,9,RES,MODRES,1,IFAIL) IF(IFAIL.EQ.0)THEN AVER=AVER+RES(1) NDATA=NDATA+1 ENDIF ENDIF 20 CONTINUE 30 CONTINUE *** over the wires or ... ELSEIF(PNTTYP.EQ.'WIRE')THEN DO 50 I=1,NWIRE IF(WIRTYP(I).NE.'S')GOTO 50 DRES=D(I) D(I)=0.0 DO 60 ANG=0.0,(2.0-1.0/REAL(NPOINT))*PI, - 2.0*PI/REAL(NPOINT) VAR(1)=X(I)+COS(ANG)*DRES/2 VAR(2)=Y(I)+SIN(ANG)*DRES/2 CALL EFIELD(VAR(1),VAR(2),0.0, - VAR(3),VAR(4),EZ,VAR(5),VAR(6), - IOPT,ILOC) VAR(7)=0.0 VAR(8)=0.0 VAR(9)=0.0 IF(ILOC.EQ.0)THEN IF(POLAR)THEN CALL CFMRTP(VAR(1),VAR(2),VAR(1),VAR(2),1) VAR(3)=VAR(3)/VAR(1) VAR(4)=VAR(4)/VAR(1) VAR(5)=VAR(5)/VAR(1) ENDIF CALL ALGEXE(IENFLD,VAR,MODVAR,9,RES,MODRES,1,IFAIL) IF(IFAIL.EQ.0)THEN AVER=AVER+RES(1) NDATA=NDATA+1 ENDIF ENDIF 60 CONTINUE D(I)=DRES 50 CONTINUE *** Or over something unknown. ELSE PRINT *,' ###### OPTAVE ERROR : Unknown averaging type ', - PNTTYP,' received; program bug - please report.' RETURN ENDIF *** Check there are enough data-points. IF(NDATA.LT.1)THEN PRINT *,' !!!!!! OPTAVE WARNING : Insufficient number of', - ' normal data-points found.' IFAIL=1 RETURN ENDIF *** Calculate the average. AVER=AVER/REAL(NDATA) *** Reset IFAIL to 0, things seem to be OK. IFAIL=0 END +DECK,OPTDSN. SUBROUTINE OPTDSN(ACTION,IREFNO) *----------------------------------------------------------------------- * OPTDSN - Saves and restores those parts of the cell description * that are modified during optimisation. * VARIABLES : ACTION : Type of dataset operation. * IREFNO : Record reference number. * (Last changed on 9/10/90.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,PRINTPLOT. LOGICAL OPENED +SELF,IF=SAVE. SAVE IREF +SELF. CHARACTER*(*) ACTION * Open the dataset and log the file. IF(ACTION.EQ.'OPEN')THEN +SELF,IF=CMS. CALL VMCMS('FILEDEF 13 DISK GARFTEMP OPTIMISE A6'// - ' (CHANGE XTENT 1000',IRC) IF(IRC.NE.0)THEN PRINT *,' !!!!!! OPTDSN WARNING : Error issuing a'// - ' FILEDEF for the potential dataset.' GOTO 2020 ENDIF +SELF,IF=CRAY. OPEN(UNIT=13,STATUS='SCRATCH',ACCESS='DIRECT', - FORM='UNFORMATTED',RECL=8+8*NWIRE,IOSTAT=IOS,ERR=2020) IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ OPTDSN DEBUG : Cray'', - '' Optimisation file opened on lun 13, lrecl='',I5)') - 8+8*NWIRE +SELF,IF=-CRAY. OPEN(UNIT=13,STATUS='SCRATCH',ACCESS='DIRECT', - FORM='UNFORMATTED',RECL=8+4*NWIRE,IOSTAT=IOS,ERR=2020) IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ OPTDSN DEBUG :'', - '' Optimisation file opened on lun 13, lrecl='',I5)') - 8+4*NWIRE +SELF. CALL DSNLOG('< Optimisation auxilliary file >','Scratch ', - 'Direct ','Read/Write') IREF=0 * Close the dataset. ELSEIF(ACTION.EQ.'CLOSE')THEN INQUIRE(UNIT=13,OPENED=OPENED) IF(.NOT.OPENED)THEN PRINT *,' ###### OPTDSN ERROR : Dataset not opened;', - ' program bug - please report.' ELSE CLOSE(UNIT=13,IOSTAT=IOS,ERR=2030) IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ OPTDSN DEBUG :'', - '' The optimisation file has been closed.'')') ENDIF * Save a record. ELSEIF(ACTION.EQ.'SAVE')THEN IREFNO=0 INQUIRE(UNIT=13,OPENED=OPENED) IF(.NOT.OPENED)THEN PRINT *,' ###### OPTDSN ERROR : Dataset not;'// - ' opened; program bug - please report.' ELSE IREF=IREF+1 IF(IREF.GT.1000)THEN PRINT *,' !!!!!! OPTDSN WARNING : Cannot'// - ' be saved because the dataset if full.' RETURN ENDIF WRITE(13,REC=IREF,IOSTAT=IOS,ERR=2010) - V0,(V(I),I=1,NWIRE) IREFNO=IREF IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ OPTDSN DEBUG :'', - '' Record '',I3,'' has been saved.'')') IREF ENDIF * Retrieve a record. ELSEIF(ACTION.EQ.'RESTORE')THEN INQUIRE(UNIT=13,OPENED=OPENED) IF(.NOT.OPENED)THEN PRINT *,' ###### OPTDSN ERROR : Dataset not yet;'// - ' opened program bug - please report.' ELSE IF(IREFNO.LE.0.OR.IREFNO.GT.IREF)THEN PRINT *,' !!!!!! OPTDSN WARNING : Illegal'// - ' reference number.' ELSE READ(13,REC=IREFNO,IOSTAT=IOS,ERR=2010) - V0,(V(I),I=1,NWIRE) IF(LDEBUG)WRITE(LUNOUT, - '('' ++++++ OPTDSN DEBUG : Record '',I3, - '' has been retrieved.'')') IREF ENDIF ENDIF * Invalid instruction. ELSE PRINT *,' ###### OPTDSN ERROR : Invalid action arg ', - ACTION,' received; program bug - please report.' ENDIF RETURN *** Handle I/O problems. 2010 CONTINUE PRINT *,' !!!!!! OPTDSN WARNING : I/O error while saving or'// - ' restoring a modification record.' CALL INPIOS(IOS) RETURN 2020 CONTINUE PRINT *,' !!!!!! OPTDSN WARNING : Error opening a modification'// - ' dataset ; do not use SAVE and RESTORE.' CALL INPIOS(IOS) CLOSE(UNIT=13,IOSTAT=IOS,ERR=2030) RETURN 2030 CONTINUE PRINT *,' !!!!!! OPTDSN WARNING : Error closing a modification'// - ' dataset ; probably harmless.' CALL INPIOS(IOS) END +PATCH,GAS. +DECK,GASADD. SUBROUTINE GASADD *----------------------------------------------------------------------- * GASADD - Adds pieces to the gas table. * (Last changed on 7/ 3/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,GASDATA. +SEQ,CONSTANTS. +SEQ,PRINTPLOT. +SEQ,BFIELD. +SEQ,GLOBALS. +SEQ,MATDATA. CHARACTER*(MXCHAR) STRFUN CHARACTER*10 VARLIS(MXVAR),NAME REAL VAR(MXVAR),RES(1) INTEGER NWORD,I,J,K,L,INEXT,INPCMP,IOBJ,NVAR,NCFUN,NCNAME,IENTRY, - IRMAT1,ISMAT1,IRMAT2,ISMAT2,MATSLT,NRES,IFAIL1,NERR,IORD, - IORDR,MODVAR(MXVAR),MODRES(1) LOGICAL USE(MXVAR),OK EXTERNAL INPCMP,MATSLT *** Identify the routine. IF(LIDENT)PRINT *,' /// ROUTINE GASADD ///' *** Make sure that the electric field table is present. IF(NGAS.LT.2)THEN PRINT *,' !!!!!! GASADD WARNING : The electric field'// - ' vector has not been set yet; nothing added.' RETURN ENDIF *** Set the list of variables. VARLIS(1)='EP' VARLIS(2)='ANGLE_EB' VARLIS(3)='VELOCITY' VARLIS(4)='MOBILITY' VARLIS(5)='SIGMA_L' VARLIS(6)='SIGMA_T' VARLIS(7)='TOWNSEND' VARLIS(8)='ATTACHMENT' VARLIS(9)='LORENTZ' VARLIS(10)='B' VARLIS(11)='BOLTZMANN' VARLIS(12)='ECHARGE' VARLIS(13)='P' VARLIS(14)='T' NVAR=14 *** Count words. CALL INPNUM(NWORD) *** Loop over the components. INEXT=2 DO 10 I=2,NWORD IF(I.LT.INEXT)GOTO 10 *** Find out which element is to be changed. IOBJ=0 IF(INPCMP(I,'DR#IFT-#VELOCITY').NE.0)THEN IOBJ=1 ELSEIF(INPCMP(I,'ION-MOB#ILITY')+ - INPCMP(I,'MOB#ILITY').NE.0)THEN IOBJ=2 ELSEIF(INPCMP(I,'LONG#ITUDINAL-DIFF#USION')+ - INPCMP(I,'DIFF#USION').NE.0)THEN IOBJ=3 ELSEIF(INPCMP(I,'TRANS#VERSE-DIFF#USION').NE.0)THEN IOBJ=8 ELSEIF(INPCMP(I,'TOWN#SEND-#COEFFICIENTS').NE.0)THEN IOBJ=4 ELSEIF(INPCMP(I,'ATT#ACHMENT-#COEFFICIENTS').NE.0)THEN IOBJ=6 ELSEIF(INPCMP(I,'LOR#ENTZ-#ANGLES').NE.0)THEN IF(MAGOK)THEN IOBJ=7 ELSE CALL INPMSG(I,'There is no B field.') GOTO 10 ENDIF ELSE CALL INPMSG(I,'Not a known object.') GOTO 10 ENDIF *** Pick up the function string or the pair of matrices. IF(I+1.GT.NWORD)THEN CALL INPMSG(I,'Should have an argument.') GOTO 10 ** Could be a set of matrices. ELSEIF(INPCMP(I+2,'VS').NE.0.AND.I+3.LE.NWORD)THEN * Continue 4 words from here. INEXT=I+4 * Locate both matrices. IRMAT1=0 IRMAT2=0 CALL INPSTR(I+1,I+1,NAME,NCNAME) DO 110 J=1,NGLB IF(GLBMOD(J).EQ.5.AND.GLBVAR(J).EQ.NAME(1:NCNAME)) - IRMAT1=NINT(GLBVAL(J)) 110 CONTINUE ISMAT1=MATSLT(IRMAT1) CALL INPSTR(I+3,I+3,NAME,NCNAME) DO 120 J=1,NGLB IF(GLBMOD(J).EQ.5.AND.GLBVAR(J).EQ.NAME(1:NCNAME)) - IRMAT2=NINT(GLBVAL(J)) 120 CONTINUE ISMAT2=MATSLT(IRMAT2) * Make sure both exist. IF(ISMAT1.EQ.0)CALL INPMSG(I+1,'Not a known matrix.') IF(ISMAT2.EQ.0)CALL INPMSG(I+3,'Not a known matrix.') IF(ISMAT1.EQ.0.OR.ISMAT2.EQ.0)GOTO 10 * Make sure they are 1-dimensional. IF(MDIM(ISMAT1).NE.1)CALL INPMSG(I+1,'Not 1-dimensional.') IF(MDIM(ISMAT2).NE.1)CALL INPMSG(I+3,'Not 1-dimensional.') IF(MDIM(ISMAT1).NE.1.OR.MDIM(ISMAT2).NE.1)GOTO 10 IENTRY=0 * Make sure the table range is covered. IF(MVEC(MORG(ISMAT2)+1).GT.EGAS(1).OR. - MVEC(MORG(ISMAT2)+MLEN(ISMAT2)).LT.EGAS(NGAS))THEN IF(.NOT.GASOK(IOBJ))THEN CALL INPMSG(I+3,'Does not cover the table.') GOTO 10 ELSE PRINT *,' ------ GASADD MESSAGE : Data covers'// - ' table only partially; keeping old values'// - ' where needed.' ENDIF ENDIF * There could still be an order of interpolation. IORD=2 IF(INPCMP(INEXT,'LIN#EAR').NE.0)THEN IORD=1 INEXT=INEXT+1 ELSEIF(INPCMP(INEXT,'QUA#DRATIC').NE.0)THEN IORD=2 INEXT=INEXT+1 ELSEIF(INPCMP(INEXT,'CUB#IC').NE.0)THEN IORD=3 INEXT=INEXT+1 ELSEIF(INPCMP(INEXT,'ORD#ER').NE.0)THEN IF(INEXT+1.LT.NWORD)THEN CALL INPMSG(INEXT,'Should have an argument.') ELSE CALL INPCHK(INEXT+1,IORDR,2) IF(IORDR.GT.0.AND.IORDR.LT.10)THEN IORD=IORDR ELSE CALL INPMSG(INEXT+1,'Out of range [1,10].') ENDIF ENDIF INEXT=INEXT+2 ENDIF * Debugging information. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GASADD DEBUG :'', - '' Component '',I1,'': matrix '',I4,''('',I4, - '') vs '',I4,''('',I4,'').'')') IOBJ,IRMAT1,ISMAT1, - IRMAT2,ISMAT2 ** Could be an incomplete set of matrices. ELSEIF(INPCMP(I+2,'VS').NE.0.AND.I+3.GT.NWORD)THEN CALL INPMSG(I,'Argument invalid or missing.') GOTO 10 ** If a function, translate. ELSE * Continue after the function. INEXT=I+2 * Get the string. CALL INPSTR(I+1,I+1,STRFUN,NCFUN) * Call editor of specified as @. IF(INDEX(STRFUN(1:NCFUN),'@').NE.0)THEN NRES=1 PRINT *,' ------ GASADD MESSAGE : Please edit the'// - ' function.' CALL ALGEDT(VARLIS,NVAR,IENTRY,USE,NRES) IFAIL1=0 IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GASADD DEBUG :'', - '' Component '',I1,'': edited function with'', - '' entry '',I5,'', results '',I5)') IENTRY,NRES * Usual function translation if not. ELSE CALL ALGPRE(STRFUN,NCFUN,VARLIS,NVAR,NRES,USE, - IENTRY,IFAIL1) IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GASADD DEBUG :'', - '' Component '',I1,'': function '',A/26X, - ''entry '',I5,'', results '',I5)') - IOBJ,STRFUN(1:NCFUN),IENTRY,NRES ENDIF * Check use of angle. IF((USE(2).OR.USE(10)).AND..NOT.TAB2D)THEN CALL INPMSG(I+1,'Uses B but there is no B field.') CALL ALGCLR(IENTRY) GOTO 10 * Check use of mobility. ELSEIF(USE(3).AND..NOT.GASOK(1))THEN CALL INPMSG(I+1,'Uses drift velocity data.') CALL ALGCLR(IENTRY) GOTO 10 * Check use of mobility. ELSEIF(USE(4).AND..NOT.GASOK(2))THEN CALL INPMSG(I+1,'Tries to use mobility data.') CALL ALGCLR(IENTRY) GOTO 10 * Check use of longitudinal diffusion. ELSEIF(USE(5).AND..NOT.GASOK(3))THEN CALL INPMSG(I+1,'Uses longitudinal diffusion.') CALL ALGCLR(IENTRY) GOTO 10 * Check use of transverse diffusion. ELSEIF(USE(6).AND..NOT.GASOK(8))THEN CALL INPMSG(I+1,'Uses longitudinal diffusion.') CALL ALGCLR(IENTRY) GOTO 10 * Check use of Townsend coefficients. ELSEIF(USE(7).AND..NOT.GASOK(4))THEN CALL INPMSG(I+1,'Uses Townsend coefficients.') CALL ALGCLR(IENTRY) GOTO 10 * Check use of attachment coefficients. ELSEIF(USE(8).AND..NOT.GASOK(6))THEN CALL INPMSG(I+1,'Uses attachment coefficients.') CALL ALGCLR(IENTRY) GOTO 10 * Check use of Lorentz angle. ELSEIF(USE(9).AND..NOT.GASOK(7))THEN CALL INPMSG(I+1,'Tries to use (v,E) angles.') CALL ALGCLR(IENTRY) GOTO 10 ENDIF * Check return code of translation. IF(IFAIL1.NE.0)THEN CALL INPMSG(I+1,'Not a valid function.') CALL ALGCLR(IENTRY) GOTO 10 ENDIF * Check number of results returned by the function. IF(NRES.NE.1)THEN CALL INPMSG(I+1,'Does not give 1 result.') CALL ALGCLR(IENTRY) GOTO 10 ENDIF ENDIF *** Perform the actual interpolation. NERR=0 OK=.TRUE. ** First the 2-dimensional tables. IF(TAB2D)THEN * Loop over the E/p points, skipping points outside the table. DO 20 J=1,NGAS IF(IENTRY.EQ.0.AND. - (EGAS(J).LT.MVEC(MORG(ISMAT2)+1).OR. - EGAS(J).GT.MVEC(MORG(ISMAT2)+MLEN(ISMAT2))))GOTO 20 * Loop over cos(E-B). DO 30 K=1,NBANG DO 50 L=1,NBTAB VAR(1)=EGAS(J) VAR(2)=180*BANG(K)/PI VAR(3)=VGAS2(J,K,L) VAR(4)=MGAS2(J,K,L) VAR(5)=DGAS2(J,K,L) VAR(6)=OGAS2(J,K,L) VAR(7)=EXP(AGAS2(J,K,L)) VAR(8)=EXP(BGAS2(J,K,L)) VAR(9)=180*WGAS2(J,K,L)/PI VAR(10)=BTAB(L)/100 VAR(11)=BOLTZ VAR(12)=ECHARG VAR(13)=PGAS VAR(14)=TGAS MODVAR(1)=2 MODVAR(2)=2 MODVAR(3)=2 MODVAR(4)=2 MODVAR(5)=2 MODVAR(6)=2 MODVAR(7)=2 MODVAR(8)=2 MODVAR(9)=2 MODVAR(10)=2 MODVAR(11)=2 MODVAR(12)=2 MODVAR(13)=2 MODVAR(14)=2 * Evaluate the formula ... IF(IENTRY.NE.0)THEN CALL ALGEXE(IENTRY,VAR,MODVAR,NVAR,RES, - MODRES,1,IFAIL1) IF(MODRES(1).NE.2.OR.IFAIL1.NE.0)THEN NERR=NERR+1 OK=.FALSE. RES(1)=0 ENDIF * or interpolate the matrices. ELSE CALL MATIN1(IRMAT2,IRMAT1,1,VAR(1),RES(1), - ISMAT2,ISMAT1,IORD,IFAIL1) IF(IFAIL1.NE.0)THEN NERR=NERR+1 OK=.FALSE. RES(1)=0 ENDIF ENDIF * Assign the result. IF(IOBJ.EQ.1)THEN VGAS2(J,K,L)=RES(1) ELSEIF(IOBJ.EQ.2)THEN MGAS2(J,K,L)=RES(1) ELSEIF(IOBJ.EQ.3)THEN DGAS2(J,K,L)=RES(1) ELSEIF(IOBJ.EQ.4)THEN IF(RES(1).GT.0)THEN AGAS2(J,K,L)=LOG(RES(1)) ELSE AGAS2(J,K,L)=-30.0 ENDIF ELSEIF(IOBJ.EQ.6)THEN IF(RES(1).GT.0)THEN BGAS2(J,K,L)=LOG(RES(1)) ELSE BGAS2(J,K,L)=-30.0 ENDIF ELSEIF(IOBJ.EQ.7)THEN WGAS2(J,K,L)=PI*RES(1)/180 ELSEIF(IOBJ.EQ.8)THEN OGAS2(J,K,L)=RES(1) ELSE PRINT *,' ###### GASADD ERROR : Unidentified'// - ' field; program bug - please report.' OK=.FALSE. ENDIF * Next point. 50 CONTINUE 30 CONTINUE 20 CONTINUE ** And the 1-dimensional case. ELSE * Loop over the E/p points, skipping points outside the table. DO 40 J=1,NGAS IF(IENTRY.EQ.0.AND. - (EGAS(J).LT.MVEC(MORG(ISMAT2)+1).OR. - EGAS(J).GT.MVEC(MORG(ISMAT2)+MLEN(ISMAT2))))GOTO 40 VAR(1)=EGAS(J) VAR(2)=0 VAR(3)=VGAS(J) VAR(4)=MGAS(J) VAR(5)=DGAS(J) VAR(6)=OGAS(J) VAR(7)=EXP(AGAS(J)) VAR(8)=EXP(BGAS(J)) VAR(9)=180*WGAS(J)/PI VAR(10)=0 VAR(11)=BOLTZ VAR(12)=ECHARG VAR(13)=PGAS VAR(14)=TGAS MODVAR(1)=2 MODVAR(2)=2 MODVAR(3)=2 MODVAR(4)=2 MODVAR(5)=2 MODVAR(6)=2 MODVAR(7)=2 MODVAR(8)=2 MODVAR(9)=2 MODVAR(10)=2 MODVAR(11)=2 MODVAR(12)=2 MODVAR(13)=2 MODVAR(14)=2 * Evaluate the formula ... IF(IENTRY.NE.0)THEN CALL ALGEXE(IENTRY,VAR,MODVAR,NVAR,RES, - MODRES,1,IFAIL1) IF(MODRES(1).NE.2.OR.IFAIL1.NE.0)THEN NERR=NERR+1 OK=.FALSE. RES(1)=0 ENDIF * or interpolate the matrices. ELSE CALL MATIN1(IRMAT2,IRMAT1,1,VAR(1),RES(1), - ISMAT2,ISMAT1,IORD,IFAIL1) IF(IFAIL1.NE.0)THEN NERR=NERR+1 OK=.FALSE. RES(1)=0 ENDIF ENDIF * Assign the result. IF(IOBJ.EQ.1)THEN VGAS(J)=RES(1) ELSEIF(IOBJ.EQ.2)THEN MGAS(J)=RES(1) ELSEIF(IOBJ.EQ.3)THEN DGAS(J)=RES(1) ELSEIF(IOBJ.EQ.4)THEN IF(RES(1).GT.0)THEN AGAS(J)=LOG(RES(1)) ELSE AGAS(J)=-30.0 ENDIF ELSEIF(IOBJ.EQ.6)THEN IF(RES(1).GT.0)THEN BGAS(J)=LOG(RES(1)) ELSE BGAS(J)=-30.0 ENDIF ELSEIF(IOBJ.EQ.7)THEN WGAS(J)=PI*RES(1)/180 ELSEIF(IOBJ.EQ.8)THEN OGAS(J)=RES(1) ELSE PRINT *,' ###### GASADD ERROR : Unidentified'// - ' field; program bug - please report.' OK=.FALSE. ENDIF * Next point. 40 CONTINUE ENDIF *** Check the error flag and set the GASOK bit accordingly. CALL ALGERR IF(OK)THEN GASOK(IOBJ)=.TRUE. ELSE PRINT *,' !!!!!! GASADD WARNING : In total ',NERR, - ' type or arithmetic errors were found; entry'// - ' deleted.' GASOK(IOBJ)=.FALSE. ENDIF *** If a formula was used, delete the entry point. IF(IENTRY.GT.0)CALL ALGCLR(IENTRY) *** Next item. 10 CONTINUE *** Print the error messages. CALL INPERR END +DECK,GASCAL. SUBROUTINE GASCAL(INSTR,IFAIL) *----------------------------------------------------------------------- * GASCAL - Processes gas related procedure calls. * (Last changed on 13/ 2/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,GASDATA. +SEQ,MATDATA. +SEQ,ALGDATA. +SEQ,BFIELD. CHARACTER*(MXINCH) STRING INTEGER INPCMX,IFAIL,IFAIL1,IFAIL3,INSTR,IPROC,NARG,ISIZ(MXMDIM), - IREP,ISEP,IREF(7),ISLOT(7),NDAT,MATSLT,I,J,NC,IAUX,NDATA REAL GASVEL,GASMOB,GASDFT,GASTWN,GASATT,GASDFL,GASLOR, - GASVT1,GASVT2 EXTERNAL INPCMX,MATSLT,GASVEL,GASMOB,GASDFT,GASTWN,GASATT, - GASDFL,GASLOR,GASVT1,GASVT2 *** Assume the CALL will fail. IFAIL=1 *** Verify that gas initialisation has been done. IF(.NOT.GASSET)THEN PRINT *,' !!!!!! GASCAL WARNING : Gas data not available'// - ' ; procedure not executed.' RETURN ENDIF *** Some easy reference variables. NARG=INS(INSTR,3) IPROC=INS(INSTR,1) *** Get gas availability flags. IF(IPROC.EQ.-201)THEN * Check arguments. IF(NARG.NE.2.OR.MODARG(1).NE.1.OR.ARGREF(2,1).GE.2)THEN PRINT *,' !!!!!! GASCAL WARNING : Incorrect'// - ' argument list for GAS_AVAILABILITY.' RETURN ENDIF * Clear the return argument. CALL ALGREU(NINT(ARG(2)),MODARG(2),ARGREF(2,1)) * Get hold of the item requested. CALL STRBUF('READ',NINT(ARG(1)),STRING,NC,IFAIL1) * Convert to upper case. CALL CLTOU(STRING(1:NC)) * Drift velocity. IF(INPCMX(STRING(1:NC),'DR#IFT-VEL#OCITY').NE.0)THEN IF(GASOK(1))THEN ARG(2)=1 ELSE ARG(2)=0 ENDIF MODARG(2)=3 * Ion mobility. ELSEIF(INPCMX(STRING(1:NC),'ION-MOB#ILITY').NE.0)THEN IF(GASOK(2))THEN ARG(2)=1 ELSE ARG(2)=0 ENDIF MODARG(2)=3 * Longitudinal diffusion. ELSEIF(INPCMX(STRING(1:NC), - 'LONG#ITUDINAL-DIFF#USION-#COEFFICIENT')+ - INPCMX(STRING(1:NC), - 'DIFF#USION-#COEFFICIENT').NE.0)THEN IF(GASOK(3))THEN ARG(2)=1 ELSE ARG(2)=0 ENDIF MODARG(2)=3 * Townsend coefficient. ELSEIF(INPCMX(STRING(1:NC), - 'TOWN#SEND-#COEFFICIENT').NE.0)THEN IF(GASOK(4))THEN ARG(2)=1 ELSE ARG(2)=0 ENDIF MODARG(2)=3 * Clustering data. ELSEIF(INPCMX(STRING(1:NC), - 'CLUS#TERING-DATA').NE.0)THEN IF(GASOK(5))THEN ARG(2)=1 ELSE ARG(2)=0 ENDIF MODARG(2)=3 * Attachment coefficient. ELSEIF(INPCMX(STRING(1:NC), - 'ATT#ACHMENT-#COEFFICIENT').NE.0)THEN IF(GASOK(6))THEN ARG(2)=1 ELSE ARG(2)=0 ENDIF MODARG(2)=3 * Lorentz angle. ELSEIF(INPCMX(STRING(1:NC), - 'LOR#ENTZ-#ANGLE').NE.0)THEN IF(GASOK(7))THEN ARG(2)=1 ELSE ARG(2)=0 ENDIF MODARG(2)=3 * Transverse diffusion. ELSEIF(INPCMX(STRING(1:NC), - 'TRANS#VERSE-DIFF#USION-#COEFFICIENT').NE.0)THEN IF(GASOK(3))THEN ARG(2)=1 ELSE ARG(2)=0 ENDIF MODARG(2)=3 * Unknown item. ELSE PRINT *,' !!!!!! GASCAL WARNING : '// - STRING(1:NC)//' is not a known gas item.' ARG(2)=0 MODARG(2)=0 ENDIF *** Get gas data. ELSEIF(IPROC.EQ.-202)THEN * Check arguments. IF(NARG.LT.1.OR.NARG.GT.3.OR. - (NARG.GE.1.AND.ARGREF(1,1).GE.2).OR. - (NARG.GE.2.AND.ARGREF(2,1).GE.2).OR. - (NARG.GE.3.AND.ARGREF(3,1).GE.2))THEN PRINT *,' !!!!!! GASCAL WARNING : Incorrect'// - ' argument list for GET_GAS_DATA.' RETURN ENDIF * Clear the storage. IF(NARG.GE.1)CALL ALGREU(NINT(ARG(1)),MODARG(1),ARGREF(1,1)) IF(NARG.GE.2)CALL ALGREU(NINT(ARG(2)),MODARG(2),ARGREF(2,1)) IF(NARG.GE.3)CALL ALGREU(NINT(ARG(3)),MODARG(3),ARGREF(3,1)) * Store pressure. IF(NARG.GE.1)THEN ARG(1)=PGAS MODARG(1)=2 ENDIF * Store temperature. IF(NARG.GE.2)THEN ARG(2)=TGAS MODARG(2)=2 ENDIF * Store identifier. IF(NARG.GE.3)THEN DO 10 I=LEN(GASID),1,-1 IF(GASID(I:I).NE.' ')THEN NC=I GOTO 20 ENDIF 10 CONTINUE NC=1 20 CONTINUE CALL STRBUF('STORE',IAUX,GASID,NC,IFAIL3) ARG(3)=REAL(IAUX) MODARG(3)=1 ENDIF *** Get drift velocity, mobility, diffusion, Townsend, attachment. ELSEIF(IPROC.LE.-203.AND.IPROC.GE.-212)THEN ** Check arguments. IF((.NOT.MAGOK).AND.(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(3).NE.2.AND.MODARG(3).NE.5).OR. - ARGREF(4,1).GE.2))THEN PRINT *,' !!!!!! GASCAL WARNING : Incorrect'// - ' argument list for getting a no-B gas table.' RETURN ELSEIF(MAGOK.AND.(NARG.NE.7.OR. - (MODARG(1).NE.2.AND.MODARG(1).NE.5).OR. - (MODARG(2).NE.2.AND.MODARG(2).NE.5).OR. - (MODARG(3).NE.2.AND.MODARG(3).NE.5).OR. - (MODARG(4).NE.2.AND.MODARG(4).NE.5).OR. - (MODARG(5).NE.2.AND.MODARG(5).NE.5).OR. - (MODARG(6).NE.2.AND.MODARG(6).NE.5).OR. - ARGREF(7,1).GE.2))THEN PRINT *,' !!!!!! GASCAL WARNING : Incorrect'// - ' argument list for getting a B gas table.' RETURN ELSEIF(NGAS.LT.1.OR. - (IPROC.EQ.-203.AND..NOT.GASOK(1)).OR. - (IPROC.EQ.-204.AND..NOT.GASOK(2)).OR. - (IPROC.EQ.-205.AND..NOT.GASOK(3)).OR. - (IPROC.EQ.-206.AND..NOT.GASOK(4)).OR. - (IPROC.EQ.-207.AND..NOT.GASOK(6)).OR. - (IPROC.EQ.-208.AND..NOT.GASOK(7)).OR. - (IPROC.EQ.-209.AND..NOT.GASOK(8)))THEN PRINT *,' !!!!!! GASCAL WARNING : Requested'// - ' gas data is not available.' RETURN ENDIF ** Clear the storage. IF(MAGOK)THEN CALL ALGREU(NINT(ARG(7)),MODARG(7),ARGREF(7,1)) ELSE CALL ALGREU(NINT(ARG(4)),MODARG(4),ARGREF(4,1)) ENDIF ** Are all arguments scalars ? IF((.NOT.MAGOK).AND. - MODARG(1).EQ.2.AND.MODARG(2).EQ.2.AND. - MODARG(3).EQ.2)THEN IF(IPROC.EQ.-203)THEN ARG(4)=GASVEL(ARG(1),ARG(2),ARG(3),0.0,0.0,0.0) ELSEIF(IPROC.EQ.-204)THEN ARG(4)=GASMOB(ARG(1),ARG(2),ARG(3),0.0,0.0,0.0) ELSEIF(IPROC.EQ.-205)THEN ARG(4)=GASDFL(ARG(1),ARG(2),ARG(3),0.0,0.0,0.0) ELSEIF(IPROC.EQ.-206)THEN ARG(4)=GASTWN(ARG(1),ARG(2),ARG(3),0.0,0.0,0.0) ELSEIF(IPROC.EQ.-207)THEN ARG(4)=GASATT(ARG(1),ARG(2),ARG(3),0.0,0.0,0.0) ELSEIF(IPROC.EQ.-208)THEN ARG(4)=GASLOR(ARG(1),ARG(2),ARG(3),0.0,0.0,0.0) ELSEIF(IPROC.EQ.-209)THEN ARG(4)=GASDFT(ARG(1),ARG(2),ARG(3),0.0,0.0,0.0) ELSEIF(IPROC.EQ.-210)THEN ARG(4)=SQRT( - GASVEL(ARG(1),ARG(2),ARG(3),0.0,0.0,0.0)**2+ - GASVT1(ARG(1),ARG(2),ARG(3),0.0,0.0,0.0)**2+ - GASVT2(ARG(1),ARG(2),ARG(3),0.0,0.0,0.0)**2) ELSEIF(IPROC.EQ.-211)THEN ARG(4)=GASVT1(ARG(1),ARG(2),ARG(3),0.0,0.0,0.0) ELSEIF(IPROC.EQ.-212)THEN ARG(4)=GASVT2(ARG(1),ARG(2),ARG(3),0.0,0.0,0.0) ELSE PRINT *,' !!!!!! GASCAL WARNING : Incorrect'// - ' procedure code received; please report.' ARG(4)=0 ENDIF MODARG(4)=2 ELSEIF(MAGOK.AND. - MODARG(1).EQ.2.AND.MODARG(2).EQ.2.AND. - MODARG(3).EQ.2.AND.MODARG(4).EQ.2.AND. - MODARG(5).EQ.2.AND.MODARG(6).EQ.2)THEN IF(IPROC.EQ.-203)THEN ARG(7)=GASVEL(ARG(1),ARG(2),ARG(3), - ARG(4),ARG(5),ARG(6)) ELSEIF(IPROC.EQ.-204)THEN ARG(7)=GASMOB(ARG(1),ARG(2),ARG(3), - ARG(4),ARG(5),ARG(6)) ELSEIF(IPROC.EQ.-205)THEN ARG(7)=GASDFL(ARG(1),ARG(2),ARG(3), - ARG(4),ARG(5),ARG(6)) ELSEIF(IPROC.EQ.-206)THEN ARG(7)=GASTWN(ARG(1),ARG(2),ARG(3), - ARG(4),ARG(5),ARG(6)) ELSEIF(IPROC.EQ.-207)THEN ARG(7)=GASATT(ARG(1),ARG(2),ARG(3), - ARG(4),ARG(5),ARG(6)) ELSEIF(IPROC.EQ.-208)THEN ARG(7)=GASLOR(ARG(1),ARG(2),ARG(3), - ARG(4),ARG(5),ARG(6)) ELSEIF(IPROC.EQ.-209)THEN ARG(7)=GASDFT(ARG(1),ARG(2),ARG(3), - ARG(4),ARG(5),ARG(6)) ELSEIF(IPROC.EQ.-210)THEN ARG(7)=SQRT( - GASVEL(ARG(1),ARG(2),ARG(3), - ARG(4),ARG(5),ARG(6))**2+ - GASVT1(ARG(1),ARG(2),ARG(3), - ARG(4),ARG(5),ARG(6))**2+ - GASVT2(ARG(1),ARG(2),ARG(3), - ARG(4),ARG(5),ARG(6))**2) ELSEIF(IPROC.EQ.-211)THEN ARG(7)=GASVT1(ARG(1),ARG(2),ARG(3), - ARG(4),ARG(5),ARG(6)) ELSEIF(IPROC.EQ.-212)THEN ARG(7)=GASVT2(ARG(1),ARG(2),ARG(3), - ARG(4),ARG(5),ARG(6)) ELSE PRINT *,' !!!!!! GASCAL WARNING : Incorrect'// - ' procedure code received; please report.' ARG(7)=0 ENDIF MODARG(7)=2 ** At least one of them is a matrix. ELSE * Figure out what the dimensions are. NDAT=-1 IF(MAGOK)THEN NDATA=6 ELSE NDATA=3 ENDIF DO 30 I=1,NDATA IF(MODARG(I).EQ.5)THEN IREF(I)=NINT(ARG(I)) ISLOT(I)=MATSLT(IREF(I)) IF(ISLOT(I).LE.0)THEN PRINT *,' !!!!!! GASCAL WARNING : Unable'// - ' locate a matrix.' RETURN ELSEIF(MMOD(ISLOT(I)).NE.2)THEN PRINT *,' !!!!!! GASCAL WARNING : E or B'// - ' vector of incorrect type.' RETURN ENDIF IF(NDAT.LT.0)THEN NDAT=MLEN(ISLOT(I)) ELSEIF(NDAT.NE.MLEN(ISLOT(I)))THEN PRINT *,' !!!!!! GASCAL WARNING : E and'// - ' B have inconsistent lengths.' RETURN ENDIF ENDIF 30 CONTINUE IF(NDAT.LT.1)THEN PRINT *,' !!!!!! GASCAL WARNING : Unable'// - ' to find an E or B vector.' RETURN ENDIF * Now book matrices for the missing elements and initialise them. DO 40 I=1,NDATA IF(MODARG(I).NE.5)THEN ISIZ(1)=NDAT CALL MATADM('ALLOCATE',IREF(I),1,ISIZ,2,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! GASCAL WARNING : Unable'// - ' to get a vector replacement.' RETURN ENDIF ISLOT(I)=MATSLT(IREF(I)) IF(ISLOT(I).LE.0)THEN PRINT *,' !!!!!! GASCAL WARNING : Unable'// - ' to locate a vector replacement.' RETURN ENDIF DO 50 J=1,MLEN(ISLOT(I)) MVEC(MORG(ISLOT(I))+J)=ARG(I) 50 CONTINUE ENDIF 40 CONTINUE * Allocate an output vector. ISIZ(1)=NDAT CALL MATADM('ALLOCATE',IREF(NDATA+1),1,ISIZ,2,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! GASCAL WARNING : Unable'// - ' to get an output vector.' RETURN ENDIF * And finally locate all vectors. DO 60 I=1,NDATA+1 ISLOT(I)=MATSLT(IREF(I)) IF(ISLOT(I).LE.0)THEN PRINT *,' !!!!!! GASCAL WARNING : Unable'// - ' to locate E, B or output.' RETURN ENDIF 60 CONTINUE * And compute the data. IF(MAGOK)THEN DO 70 I=1,NDAT IF(IPROC.EQ.-203)THEN MVEC(MORG(ISLOT(7))+I)=GASVEL( - MVEC(MORG(ISLOT(1))+I), - MVEC(MORG(ISLOT(2))+I), - MVEC(MORG(ISLOT(3))+I), - MVEC(MORG(ISLOT(4))+I), - MVEC(MORG(ISLOT(5))+I), - MVEC(MORG(ISLOT(6))+I)) ELSEIF(IPROC.EQ.-204)THEN MVEC(MORG(ISLOT(7))+I)=GASMOB( - MVEC(MORG(ISLOT(1))+I), - MVEC(MORG(ISLOT(2))+I), - MVEC(MORG(ISLOT(3))+I), - MVEC(MORG(ISLOT(4))+I), - MVEC(MORG(ISLOT(5))+I), - MVEC(MORG(ISLOT(6))+I)) ELSEIF(IPROC.EQ.-205)THEN MVEC(MORG(ISLOT(7))+I)=GASDFL( - MVEC(MORG(ISLOT(1))+I), - MVEC(MORG(ISLOT(2))+I), - MVEC(MORG(ISLOT(3))+I), - MVEC(MORG(ISLOT(4))+I), - MVEC(MORG(ISLOT(5))+I), - MVEC(MORG(ISLOT(6))+I)) ELSEIF(IPROC.EQ.-206)THEN MVEC(MORG(ISLOT(7))+I)=GASTWN( - MVEC(MORG(ISLOT(1))+I), - MVEC(MORG(ISLOT(2))+I), - MVEC(MORG(ISLOT(3))+I), - MVEC(MORG(ISLOT(4))+I), - MVEC(MORG(ISLOT(5))+I), - MVEC(MORG(ISLOT(6))+I)) ELSEIF(IPROC.EQ.-207)THEN MVEC(MORG(ISLOT(7))+I)=GASATT( - MVEC(MORG(ISLOT(1))+I), - MVEC(MORG(ISLOT(2))+I), - MVEC(MORG(ISLOT(3))+I), - MVEC(MORG(ISLOT(4))+I), - MVEC(MORG(ISLOT(5))+I), - MVEC(MORG(ISLOT(6))+I)) ELSEIF(IPROC.EQ.-208)THEN MVEC(MORG(ISLOT(7))+I)=GASLOR( - MVEC(MORG(ISLOT(1))+I), - MVEC(MORG(ISLOT(2))+I), - MVEC(MORG(ISLOT(3))+I), - MVEC(MORG(ISLOT(4))+I), - MVEC(MORG(ISLOT(5))+I), - MVEC(MORG(ISLOT(6))+I)) ELSEIF(IPROC.EQ.-209)THEN MVEC(MORG(ISLOT(7))+I)=GASDFT( - MVEC(MORG(ISLOT(1))+I), - MVEC(MORG(ISLOT(2))+I), - MVEC(MORG(ISLOT(3))+I), - MVEC(MORG(ISLOT(4))+I), - MVEC(MORG(ISLOT(5))+I), - MVEC(MORG(ISLOT(6))+I)) ELSEIF(IPROC.EQ.-210)THEN MVEC(MORG(ISLOT(7))+I)=SQRT( - GASVEL( - MVEC(MORG(ISLOT(1))+I), - MVEC(MORG(ISLOT(2))+I), - MVEC(MORG(ISLOT(3))+I), - MVEC(MORG(ISLOT(4))+I), - MVEC(MORG(ISLOT(5))+I), - MVEC(MORG(ISLOT(6))+I))**2+ - GASVT1( - MVEC(MORG(ISLOT(1))+I), - MVEC(MORG(ISLOT(2))+I), - MVEC(MORG(ISLOT(3))+I), - MVEC(MORG(ISLOT(4))+I), - MVEC(MORG(ISLOT(5))+I), - MVEC(MORG(ISLOT(6))+I))**2+ - GASVT2( - MVEC(MORG(ISLOT(1))+I), - MVEC(MORG(ISLOT(2))+I), - MVEC(MORG(ISLOT(3))+I), - MVEC(MORG(ISLOT(4))+I), - MVEC(MORG(ISLOT(5))+I), - MVEC(MORG(ISLOT(6))+I))**2) ELSEIF(IPROC.EQ.-211)THEN MVEC(MORG(ISLOT(7))+I)=GASVT1( - MVEC(MORG(ISLOT(1))+I), - MVEC(MORG(ISLOT(2))+I), - MVEC(MORG(ISLOT(3))+I), - MVEC(MORG(ISLOT(4))+I), - MVEC(MORG(ISLOT(5))+I), - MVEC(MORG(ISLOT(6))+I)) ELSEIF(IPROC.EQ.-212)THEN MVEC(MORG(ISLOT(7))+I)=GASVT2( - MVEC(MORG(ISLOT(1))+I), - MVEC(MORG(ISLOT(2))+I), - MVEC(MORG(ISLOT(3))+I), - MVEC(MORG(ISLOT(4))+I), - MVEC(MORG(ISLOT(5))+I), - MVEC(MORG(ISLOT(6))+I)) ELSE PRINT *,' !!!!!! GASCAL WARNING : Wrong'// - ' procedure code received; report.' MVEC(MORG(ISLOT(4))+I)=0 ENDIF 70 CONTINUE ELSE DO 90 I=1,NDAT IF(IPROC.EQ.-203)THEN MVEC(MORG(ISLOT(4))+I)=GASVEL( - MVEC(MORG(ISLOT(1))+I), - MVEC(MORG(ISLOT(2))+I), - MVEC(MORG(ISLOT(3))+I),0.0,0.0,0.0) ELSEIF(IPROC.EQ.-204)THEN MVEC(MORG(ISLOT(4))+I)=GASMOB( - MVEC(MORG(ISLOT(1))+I), - MVEC(MORG(ISLOT(2))+I), - MVEC(MORG(ISLOT(3))+I),0.0,0.0,0.0) ELSEIF(IPROC.EQ.-205)THEN MVEC(MORG(ISLOT(4))+I)=GASDFL( - MVEC(MORG(ISLOT(1))+I), - MVEC(MORG(ISLOT(2))+I), - MVEC(MORG(ISLOT(3))+I),0.0,0.0,0.0) ELSEIF(IPROC.EQ.-206)THEN MVEC(MORG(ISLOT(4))+I)=GASTWN( - MVEC(MORG(ISLOT(1))+I), - MVEC(MORG(ISLOT(2))+I), - MVEC(MORG(ISLOT(3))+I),0.0,0.0,0.0) ELSEIF(IPROC.EQ.-207)THEN MVEC(MORG(ISLOT(4))+I)=GASATT( - MVEC(MORG(ISLOT(1))+I), - MVEC(MORG(ISLOT(2))+I), - MVEC(MORG(ISLOT(3))+I),0.0,0.0,0.0) ELSEIF(IPROC.EQ.-208)THEN MVEC(MORG(ISLOT(4))+I)=GASLOR( - MVEC(MORG(ISLOT(1))+I), - MVEC(MORG(ISLOT(2))+I), - MVEC(MORG(ISLOT(3))+I),0.0,0.0,0.0) ELSEIF(IPROC.EQ.-209)THEN MVEC(MORG(ISLOT(4))+I)=GASDFT( - MVEC(MORG(ISLOT(1))+I), - MVEC(MORG(ISLOT(2))+I), - MVEC(MORG(ISLOT(3))+I),0.0,0.0,0.0) ELSEIF(IPROC.EQ.-210)THEN MVEC(MORG(ISLOT(4))+I)=SQRT( - GASVEL( - MVEC(MORG(ISLOT(1))+I), - MVEC(MORG(ISLOT(2))+I), - MVEC(MORG(ISLOT(3))+I),0.0,0.0,0.0)**2+ - GASVT1( - MVEC(MORG(ISLOT(1))+I), - MVEC(MORG(ISLOT(2))+I), - MVEC(MORG(ISLOT(3))+I),0.0,0.0,0.0)**2+ - GASVT2( - MVEC(MORG(ISLOT(1))+I), - MVEC(MORG(ISLOT(2))+I), - MVEC(MORG(ISLOT(3))+I),0.0,0.0,0.0)**2) ELSEIF(IPROC.EQ.-211)THEN MVEC(MORG(ISLOT(4))+I)=GASVT1( - MVEC(MORG(ISLOT(1))+I), - MVEC(MORG(ISLOT(2))+I), - MVEC(MORG(ISLOT(3))+I),0.0,0.0,0.0) ELSEIF(IPROC.EQ.-212)THEN MVEC(MORG(ISLOT(4))+I)=GASVT2( - MVEC(MORG(ISLOT(1))+I), - MVEC(MORG(ISLOT(2))+I), - MVEC(MORG(ISLOT(3))+I),0.0,0.0,0.0) ELSE PRINT *,' !!!!!! GASCAL WARNING : Wrong'// - ' procedure code received; report.' MVEC(MORG(ISLOT(4))+I)=0 ENDIF 90 CONTINUE ENDIF * Delete temporary matrices. DO 80 I=1,NDATA IF(MODARG(I).NE.5)THEN ISIZ(1)=NDAT CALL MATADM('DELETE',IREF(I),1,ISIZ,2,IFAIL1) IF(IFAIL1.NE.0)PRINT *,' !!!!!! GASCAL WARNING'// - ' : Unable to delete a vector replacement.' ENDIF 80 CONTINUE * And save the output. ARG(NDATA+1)=IREF(NDATA+1) MODARG(NDATA+1)=5 ENDIF *** Get E/p. ELSEIF(IPROC.EQ.-213)THEN * Check arguments. IF(NARG.NE.1.OR.ARGREF(1,1).GE.2)THEN PRINT *,' !!!!!! GASCAL WARNING : Incorrect'// - ' argument list for GET_EP_TABLE.' RETURN ELSEIF(NGAS.LT.1)THEN PRINT *,' !!!!!! GASCAL WARNING : No E/p table'// - ' available.' RETURN ENDIF * Clear the storage. CALL ALGREU(NINT(ARG(1)),MODARG(1),ARGREF(1,1)) * Get a matrix of the proper size. ISIZ(1)=NGAS CALL MATADM('ALLOCATE',IREP,1,ISIZ,2,IFAIL1) ISEP=MATSLT(IREP) IF(IFAIL1.NE.0.OR.ISEP.LE.0)THEN PRINT *,' !!!!!! GASCAL WARNING : Unable to obtain'// - ' matrix storage.' RETURN ENDIF * Copy the contents. DO 150 I=1,NGAS MVEC(MORG(ISEP)+I)=EGAS(I) 150 CONTINUE * And save the output. ARG(1)=IREP MODARG(1)=5 *** Unknown gas operation. ELSE PRINT *,' !!!!!! GASCAL WARNING : Unknown procedure code'// - ' received; nothing done.' IFAIL=1 RETURN ENDIF *** Seems to have worked. IFAIL=0 END +DECK,GASCHK. SUBROUTINE GASCHK(IFAIL) *----------------------------------------------------------------------- * GASCHK - Checks the validity of tha gas data entered in GASINP. * VARIABLES : IFAIL : 1 if routine failed 0 if succesful * (Last changed on 21/ 2/01.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,GASDATA. +SEQ,PRINTPLOT. DOUBLE PRECISION SUMCLS INTEGER IFAIL,I,J,K LOGICAL OK *** Identify the routine if requested. IF(LIDENT)PRINT *,' /// ROUTINE GASCHK ///' *** Preset IFAIL to 0, i.e. pass. IFAIL=0 OK=.TRUE. *** Table check: check the number of data points. IF(NGAS.LT.1)THEN PRINT *,' !!!!!! GASCHK WARNING : The electron transport'// - ' property table has too few points.' GASOK(1)=.FALSE. GASOK(2)=.FALSE. GASOK(3)=.FALSE. GASOK(4)=.FALSE. GASOK(6)=.FALSE. GASOK(7)=.FALSE. GASOK(8)=.FALSE. GASOK(9)=.FALSE. GASOK(10)=.FALSE. OK=.FALSE. ENDIF DO 10 I=1,NGAS * Check that the E/p array is all positive. IF(EGAS(I).LE.0.0)THEN PRINT *,' !!!!!! GASCHK WARNING : E/p is not strictly', - ' positive in table entry ',I,'; table is rejected.' GASOK(1)=.FALSE. GASOK(2)=.FALSE. GASOK(3)=.FALSE. GASOK(4)=.FALSE. GASOK(6)=.FALSE. GASOK(7)=.FALSE. GASOK(8)=.FALSE. GASOK(9)=.FALSE. GASOK(10)=.FALSE. OK=.FALSE. ENDIF * Check that the E/p array is in increasing order. IF(I.GT.1)THEN IF(EGAS(I).LE.EGAS(I-1))THEN PRINT *,' !!!!!! GASCHK WARNING : E/p is not in'// - ' increasing order; table is rejected.' GASOK(1)=.FALSE. GASOK(2)=.FALSE. GASOK(3)=.FALSE. GASOK(4)=.FALSE. GASOK(6)=.FALSE. GASOK(7)=.FALSE. GASOK(8)=.FALSE. GASOK(9)=.FALSE. GASOK(10)=.FALSE. OK=.FALSE. ENDIF ENDIF ** Case of a 2 dimensional table. IF(TAB2D)THEN DO 20 J=1,NBANG DO 30 K=1,NBTAB * Check that the v || E is all positive (leave other components). IF(GASOK(1).AND.VGAS2(I,J,K).LE.0.0)THEN PRINT *,' !!!!!! GASCHK WARNING : v || E is not > 0'// - ' in table entry ',I,J,K,'; Vdrift is rejected.' GASOK(1)=.FALSE. OK=.FALSE. ENDIF * Check that the ion mobility is all positive. IF(GASOK(2).AND.MGAS2(I,J,K).LE.0.0)THEN PRINT *,' !!!!!! GASCHK WARNING : Ion mobility < 0', - ' at table entry ',I,J,K,'; mobility rejected.' GASOK(2)=.FALSE. OK=.FALSE. ENDIF * Check that the sigma-diffusion array is all positive. IF(GASOK(3).AND.DGAS2(I,J,K).LT.0.0)THEN PRINT *,' !!!!!! GASCHK WARNING : Long. diffusion < 0', - ' at table entry ',I,J,K,'; data are rejected.' GASOK(3)=.FALSE. OK=.FALSE. ENDIF IF(GASOK(8).AND.OGAS2(I,J,K).LT.0.0)THEN PRINT *,' !!!!!! GASCHK WARNING : Tr. diffusion < 0', - ' at table entry ',I,J,K,'; data are rejected.' OK=.FALSE. GASOK(8)=.FALSE. ENDIF * Check that the Townsend coefficients are all reasonable. IF(GASOK(4).AND.AGAS2(I,J,K).LT.-30.001)THEN PRINT *,' ------ GASCHK MESSAGE : Setting alpha/p ='// - ' 0 in table entry ',I,J,K,'.' AGAS2(I,J,K)=-30 ENDIF * Check that the attachment coefficients are all positive. IF(GASOK(6).AND.BGAS2(I,J,K).LT.-30.001)THEN PRINT *,' ------ GASCHK MESSAGE : Setting eta/p ='// - ' 0 in table entry ',I,J,K,'.' BGAS2(I,J,K)=-30 ENDIF 30 CONTINUE 20 CONTINUE ** Case of a 1-dimensional table. ELSE * Check that the v || E is all positive (leave other components). IF(GASOK(1).AND.VGAS(I).LE.0.0)THEN PRINT *,' !!!!!! GASCHK WARNING : v || E is not > 0'// - ' in table entry ',I,'; Vdrift is rejected.' OK=.FALSE. GASOK(1)=.FALSE. ENDIF * Check that the ion mobility is all positive. IF(GASOK(2).AND.MGAS(I).LE.0.0)THEN PRINT *,' !!!!!! GASCHK WARNING : Ion mobility < 0', - ' at table entry ',I,'; ion mobility rejected.' OK=.FALSE. GASOK(2)=.FALSE. ENDIF * Check that the sigma-diffusion array is all positive. IF(GASOK(3).AND.DGAS(I).LT.0.0)THEN PRINT *,' !!!!!! GASCHK WARNING : Long. diffusion < 0', - ' at table entry ',I,'; data are rejected.' OK=.FALSE. GASOK(3)=.FALSE. ENDIF IF(GASOK(8).AND.OGAS(I).LT.0.0)THEN PRINT *,' !!!!!! GASCHK WARNING : Tr. diffusion < 0', - ' at table entry ',I,'; data are rejected.' GASOK(8)=.FALSE. OK=.FALSE. ENDIF * Check that the Townsend coefficients are reasonable. IF(GASOK(4).AND.AGAS(I).LT.-30.001)THEN PRINT *,' ------ GASCHK MESSAGE : Setting alpha/p ='// - ' 0 in table entry ',I,J,K,'.' AGAS(I)=-30 ENDIF * Check that the attachment coefficients are all positive. IF(GASOK(6).AND.BGAS(I).LT.-30.001)THEN PRINT *,' ------ GASCHK MESSAGE : Setting eta/p ='// - ' 0 in table entry ',I,J,K,'.' BGAS(I)=-30 ENDIF ENDIF 10 CONTINUE *** Check interpolation and extrapolation methods. IF(NGAS.GT.1.AND.GASOK(1).AND.(((.NOT.TAB2D).AND. - (IVMETH.LT.0.OR.IVMETH.GT.MIN(10,NGAS-1))).OR. - (TAB2D.AND.(IVMETH.LT.0.OR.IVMETH.GT.2))))THEN IVMETH=MIN(2,NGAS-1) PRINT *,' !!!!!! GASCHK WARNING : Invalid drift velocity'// - ' interpolation; taking polynomial of order ',IVMETH OK=.FALSE. ENDIF IF(GASOK(1).AND.(IVEXTR.LT.0.OR.IVEXTR.GT.2.OR. - JVEXTR.LT.0.OR.JVEXTR.GT.2).AND..NOT.TAB2D)THEN PRINT *,' !!!!!! GASCHK WARNING : Invalid extrapolation'// - ' method for v; assuming linear.' IVEXTR=1 JVEXTR=1 OK=.FALSE. ENDIF IF(NGAS.GT.1.AND.GASOK(2).AND.(((.NOT.TAB2D).AND. - (IMMETH.LT.0.OR.IMMETH.GT.MIN(10,NGAS-1))).OR. - (TAB2D.AND.(IMMETH.LT.0.OR.IMMETH.GT.2))))THEN IMMETH=MIN(2,NGAS-1) PRINT *,' !!!!!! GASCHK WARNING : Invalid ion mobility'// - ' interpolation; taking polynomial of order ',IMMETH OK=.FALSE. ENDIF IF(GASOK(2).AND.(IMEXTR.LT.0.OR.IMEXTR.GT.2.OR. - JMEXTR.LT.0.OR.JMEXTR.GT.2).AND..NOT.TAB2D)THEN PRINT *,' !!!!!! GASCHK WARNING : Invalid extrapolation'// - ' method for the ion mobility; assuming linear.' IMEXTR=1 JMEXTR=1 OK=.FALSE. ENDIF IF(NGAS.GT.1.AND.GASOK(3).AND.(((.NOT.TAB2D).AND. - (IDMETH.LT.0.OR.IDMETH.GT.MIN(10,NGAS-1))).OR. - (TAB2D.AND.(IDMETH.LT.0.OR.IDMETH.GT.2))))THEN IDMETH=MIN(2,NGAS-1) PRINT *,' !!!!!! GASCHK WARNING : Invalid sigma L'// - ' interpolation; taking polynomial of order ',IDMETH OK=.FALSE. ENDIF IF(GASOK(3).AND.(IDEXTR.LT.0.OR.IDEXTR.GT.2).AND..NOT.TAB2D)THEN PRINT *,' !!!!!! GASCHK WARNING : Invalid extrapolation'// - ' method for sigma L; assuming linear.' IDEXTR=1 JDEXTR=1 OK=.FALSE. ENDIF IF(NGAS.GT.1.AND.GASOK(4).AND.(((.NOT.TAB2D).AND. - (IAMETH.LT.0.OR.IAMETH.GT.MIN(10,NGAS-1))).OR. - (TAB2D.AND.(IAMETH.LT.0.OR.IAMETH.GT.2))))THEN IAMETH=MIN(2,NGAS-1) PRINT *,' !!!!!! GASCHK WARNING : Invalid Townsend'// - ' interpolation; taking polynomial of order ',IAMETH OK=.FALSE. ENDIF IF(GASOK(4).AND.(IAEXTR.LT.0.OR.IAEXTR.GT.2).AND..NOT.TAB2D)THEN PRINT *,' !!!!!! GASCHK WARNING : Invalid extrapolation'// - ' method for Townsend coefficient; assuming linear.' IAEXTR=1 JAEXTR=1 OK=.FALSE. ENDIF IF(NGAS.GT.1.AND.GASOK(6).AND.(((.NOT.TAB2D).AND. - (IBMETH.LT.0.OR.IBMETH.GT.MIN(10,NGAS-1))).OR. - (TAB2D.AND.(IBMETH.LT.0.OR.IBMETH.GT.2))))THEN IBMETH=MIN(2,NGAS-1) PRINT *,' !!!!!! GASCHK WARNING : Invalid attachment'// - ' interpolation; taking polynomial of order ',IBMETH OK=.FALSE. ENDIF IF(GASOK(6).AND.(IBEXTR.LT.0.OR.IBEXTR.GT.2).AND..NOT.TAB2D)THEN PRINT *,' !!!!!! GASCHK WARNING : Invalid extrapolation'// - ' method for the attachment; assuming linear.' IBEXTR=1 JBEXTR=1 OK=.FALSE. ENDIF IF(NGAS.GT.1.AND.GASOK(7).AND.(((.NOT.TAB2D).AND. - (IWMETH.LT.0.OR.IWMETH.GT.MIN(10,NGAS-1))).OR. - (TAB2D.AND.(IWMETH.LT.0.OR.IWMETH.GT.2))))THEN IWMETH=MIN(2,NGAS-1) PRINT *,' !!!!!! GASCHK WARNING : Invalid (v,E) angle'// - ' interpolation; taking polynomial of order ',IWMETH OK=.FALSE. ENDIF IF(GASOK(7).AND.(IWEXTR.LT.0.OR.IWEXTR.GT.2.OR. - JWEXTR.LT.0.OR.JWEXTR.GT.2).AND..NOT.TAB2D)THEN PRINT *,' !!!!!! GASCHK WARNING : Invalid extrapolation'// - ' method for the (v,E) angle; assuming linear.' IWEXTR=1 JWEXTR=1 OK=.FALSE. ENDIF IF(NGAS.GT.1.AND.GASOK(8).AND.(((.NOT.TAB2D).AND. - (IOMETH.LT.0.OR.IOMETH.GT.MIN(10,NGAS-1))).OR. - (TAB2D.AND.(IOMETH.LT.0.OR.IOMETH.GT.2))))THEN IOMETH=MIN(2,NGAS-1) PRINT *,' !!!!!! GASCHK WARNING : Invalid sigma T'// - ' interpolation; taking polynomial of order ',IOMETH OK=.FALSE. ENDIF IF(GASOK(8).AND.(IOEXTR.LT.0.OR.IOEXTR.GT.2.OR. - JOEXTR.LT.0.OR.JOEXTR.GT.2).AND..NOT.TAB2D)THEN PRINT *,' !!!!!! GASCHK WARNING : Invalid extrapolation'// - ' method for sigma T; assuming linear.' IOEXTR=1 JOEXTR=1 OK=.FALSE. ENDIF IF(NGAS.GT.1.AND.GASOK(9).AND.(((.NOT.TAB2D).AND. - (IXMETH.LT.0.OR.IXMETH.GT.MIN(10,NGAS-1))).OR. - (TAB2D.AND.(IXMETH.LT.0.OR.IXMETH.GT.2))))THEN IXMETH=MIN(2,NGAS-1) PRINT *,' !!!!!! GASCHK WARNING : Invalid v || Btrans'// - ' interpolation; using polynomial of order ',IXMETH OK=.FALSE. ENDIF IF(GASOK(9).AND.(IXEXTR.LT.0.OR.IXEXTR.GT.2.OR. - JXEXTR.LT.0.OR.JXEXTR.GT.2).AND..NOT.TAB2D)THEN PRINT *,' !!!!!! GASCHK WARNING : Invalid extrapolation'// - ' method for v || Btrans; assuming linear.' IXEXTR=1 JXEXTR=1 OK=.FALSE. ENDIF IF(NGAS.GT.1.AND.GASOK(10).AND.(((.NOT.TAB2D).AND. - (IYMETH.LT.0.OR.IYMETH.GT.MIN(10,NGAS-1))).OR. - (TAB2D.AND.(IYMETH.LT.0.OR.IYMETH.GT.2))))THEN IYMETH=MIN(2,NGAS-1) PRINT *,' !!!!!! GASCHK WARNING : Invalid v || ExB'// - ' interpolation; taking polynomial of order ',IYMETH OK=.FALSE. ENDIF IF(GASOK(10).AND.(IYEXTR.LT.0.OR.IYEXTR.GT.2.OR. - JYEXTR.LT.0.OR.JYEXTR.GT.2).AND..NOT.TAB2D)THEN PRINT *,' !!!!!! GASCHK WARNING : Invalid extrapolation'// - ' method for v || ExB; assuming linear.' IYEXTR=1 JYEXTR=1 OK=.FALSE. ENDIF *** Mean check: should be positive if cluster data have been entered. IF(GASOK(5).AND.CMEAN.LE.0)THEN PRINT *,' !!!!!! GASCHK WARNING : Number of clusters/cm'// - ' is absent or not positive; cluster data reset.' GASOK(5)=.FALSE. OK=.FALSE. ENDIF * MEAN makes no sense if no other cluster data are present. IF(CLSTYP.EQ.'NOT SET'.AND.GASOK(5))THEN PRINT *,' !!!!!! GASCHK WARNING : The MEAN parameter by'// - ' itself is not enough to have cluster data.' PRINT *,' Include the other', - ' parameters (A, Z etc), use HEED or use CLUSTER.' GASOK(5)=.FALSE. OK=.FALSE. ENDIF *** Cluster check: parameters for the Landau approximation must be > 0. IF(CLSTYP.EQ.'LANDAU'.AND.GASOK(5))THEN IF(A .LE.0)PRINT *,' !!!!!! GASCHK WARNING : The'// - ' number of nucleons is absent or not positive;'// - ' cluster data reset.' IF(Z .LE.0)PRINT *,' !!!!!! GASCHK WARNING : The'// - ' nuclear charge is absent or not positive;'// - ' cluster data reset.' IF(EMPROB.LE.0)PRINT *,' !!!!!! GASCHK WARNING : The most'// - ' probable energy loss is absent or not positive;'// - ' cluster data reset.' IF(EPAIR .LE.0)PRINT *,' !!!!!! GASCHK WARNING : The pair'// - ' creation energy is absent or not positive;'// - ' cluster data reset.' IF(RHO .LE.0)PRINT *,' !!!!!! GASCHK WARNING : The gas'// - ' density is absent or not positive;'// - ' cluster data reset.' IF(A.LE.0.OR.Z.LE.0.OR.EMPROB.LE.0.OR.EPAIR.LE.0.OR. - RHO.LE.0.OR.CMEAN.LE.0)THEN PRINT *,' !!!!!! GASCHK WARNING : No Landau based'// - ' cluster size distribution will be generated.' GASOK(5)=.FALSE. OK=.FALSE. ENDIF ENDIF * Direct cluster data, check number of points. IF((CLSTYP.EQ.'TABLE'.OR.CLSTYP.EQ.'FUNCTION'.OR. - CLSTYP.EQ.'FILE').AND.GASOK(5).AND.NCLS.LE.1)THEN PRINT *,' !!!!!! GASCHK WARNING : The number of cluster', - ' size distribution data points is insufficient.' GASOK(5)=.FALSE. OK=.FALSE. ENDIF * Direct cluster data, check positiveness. IF((CLSTYP.EQ.'TABLE'.OR.CLSTYP.EQ.'FUNCTION').AND.GASOK(5))THEN SUMCLS=0 DO 40 I=1,NCLS IF(CLSDIS(I).LT.0)THEN PRINT *,' !!!!!! GASCHK WARNING : The probability for', - ' cluster size ',I,' is set to 0, was ',CLSDIS(I) CLSDIS(I)=0 ENDIF SUMCLS=SUMCLS+CLSDIS(I) 40 CONTINUE * Direct cluster data, check integral. IF(SUMCLS.LE.0.0)THEN PRINT *,' !!!!!! GASCHK WARNING : The integral'// - ' over the cluster size distribution is'// - ' zero ; distribution rejected.' GASOK(5)=.FALSE. OK=.FALSE. ENDIF ENDIF * Check the consitency between CLSTYP and GASOK(5). IF(CLSTYP.NE.'FUNCTION'.AND.CLSTYP.NE.'TABLE'.AND.CLSTYP.NE. - 'LANDAU'.AND.CLSTYP.NE.'FILE'.AND.CLSTYP.NE.'OVERLAP'.AND. - GASOK(5))THEN PRINT *,' ###### GASCHK ERROR : Inconsistent cluster'// - ' type and flag; program bug, please report.' GASOK(5)=.FALSE. OK=.FALSE. ENDIF *** Flag data as unuseable if not a single table is present. IF(.NOT.(GASOK(1).OR.GASOK(2).OR.GASOK(3).OR.GASOK(4).OR. - GASOK(5).OR.GASOK(6).OR.GASOK(7).OR.GASOK(8).OR. - GASOK(9).OR.GASOK(10)))THEN PRINT *,' !!!!!! GASCHK WARNING : Not a single gas'// - ' element left in the description; gas rejected.' IFAIL=1 ELSEIF((JFAIL.EQ.2.OR.JFAIL.EQ.3).AND..NOT.OK)THEN PRINT *,' !!!!!! GASCHK WARNING : Gas marked as'// - ' unuseable because of the above errors.' IFAIL=1 ENDIF *** Generate some debugging output. IF(LDEBUG)PRINT *,' ++++++ GASCHK DEBUG : After checking the'// - ' GASOK bits are: ',(GASOK(I),I=1,10) *** And register the amount of CPU time used for checking. CALL TIMLOG('Checking the gas data makes sense: ') END +DECK,GASDEF. SUBROUTINE GASDEF(IFAIL) *----------------------------------------------------------------------- * GASDEF - Routine controlling the gas input and output routines. * VARIABLES : LGASPL : Controls plotting of the gas data. * LGASPR : Controls printing of the gas data. * (Last changed on 5/ 2/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,GASDATA. +SEQ,PRINTPLOT. INTEGER IFAIL LOGICAL LGASPL,LGASPR,LGASWR +SELF,IF=SAVE. SAVE LGASPL,LGASPR +SELF. DATA LGASPL,LGASPR/.FALSE.,.FALSE./ *** Identify the routine, if requested. IF(LIDENT)PRINT *,' /// ROUTINE GASDEF ///' *** Identify the new section. WRITE(*,'(''1'')') PRINT *,' ' PRINT *,' ================================================' PRINT *,' ========== Start of gas definition ==========' PRINT *,' ================================================' PRINT *,' ' *** Initialise IFAIL to OK, reset the overall gas availability flag. IFAIL=0 GASSET=.FALSE. *** First read and check all data. CALL GASINP(LGASPL,LGASPR,LGASWR,IFAIL) IF(IFAIL.NE.0)THEN IF(JFAIL.EQ.1)THEN PRINT *,' !!!!!! GASDEF WARNING : Input of the'// - ' gas data failed; CO2 will be used.' ELSEIF(JFAIL.EQ.2)THEN PRINT *,' !!!!!! GASDEF WARNING : Input of the'// - ' gas data failed; no gas data.' RETURN ELSE PRINT *,' !!!!!! GASDEF WARNING : Input of the'// - ' gas data failed; program quit.' CALL QUIT ENDIF ELSE CALL GASCHK(IFAIL) IF(IFAIL.NE.0)THEN IF(JFAIL.EQ.1)THEN PRINT *,' !!!!!! GASDEF WARNING : Gas data'// - ' not useable; CO2 will be used.' ELSEIF(JFAIL.EQ.2)THEN PRINT *,' !!!!!! GASDEF WARNING : Gas data'// - ' not useable; no gas data.' RETURN ELSE PRINT *,' !!!!!! GASDEF WARNING : Gas data'// - ' not useable; program quit.' CALL QUIT ENDIF ELSE GOTO 10 ENDIF ENDIF *** Provide an emergency entry for creation of gasdata. ENTRY XXXGAS(IFAIL) CALL CO2 TAB2D=.FALSE. LGASWR=.FALSE. *** Prepare the gas data for use later on. 10 CONTINUE CALL GASPRE(IFAIL) *** Print, plot and write them as requested. IF(LGASPR)CALL GASPRT IF(LGASPL)CALL GASPLT IF(LGASWR)CALL GASWRT(2) *** Seems to have worked, make gas available. GASSET=.TRUE. END +DECK,GASGET. SUBROUTINE GASGET(IFAIL) *----------------------------------------------------------------------- * GASGET - This routine retrieves the gas data written to an external * dataset written by a WRITE instruction. * VARIABLES : NWORD : Number of parameters provided. * STRING : String for character manipulation. * (Last changed on 7/ 4/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,GASDATA. +SEQ,BFIELD. +SEQ,PRINTPLOT. CHARACTER*(MXCHAR) STRING CHARACTER*8 MEMBER CHARACTER*(MXNAME) FILE INTEGER IFAIL,NCFILE,NCMEMB,I,II,J,K,IOS,IFAIL1,NWORD LOGICAL DSNCMP,EXIS EXTERNAL DSNCMP *** Identify the routine. IF(LIDENT)PRINT *,' /// ROUTINE GASGET ///' *** Initialise IFAIL on 1 (i.e. fail). IFAIL=1 FILE=' ' MEMBER='*' NCFILE=8 NCMEMB=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.2)THEN CALL INPSTR(2,2,STRING,NCFILE) FILE=STRING ENDIF * If there's a second argument, it is the member name. IF(NWORD.GE.3)THEN CALL INPSTR(3,3,STRING,NCMEMB) MEMBER=STRING ENDIF * Check the various lengths. IF(NCFILE.GT.MXNAME)THEN PRINT *,' !!!!!! GASGET WARNING : The file name is'// - ' truncated to MXNAME (=',MXNAME,') characters.' NCFILE=MIN(NCFILE,MXNAME) ENDIF IF(NCMEMB.GT.8)THEN PRINT *,' !!!!!! GASGET WARNING : The member name is'// - ' shortened to ',MEMBER,', first 8 characters.' NCMEMB=MIN(NCMEMB,8) ELSEIF(NCMEMB.LE.0)THEN PRINT *,' !!!!!! GASGET 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 *,' !!!!!! GASGET 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.3)PRINT *,' !!!!!! GASGET WARNING : GET takes'// - ' at most two arguments (dataset and member); rest ignored.' *** Open a dataset and inform DSNLOG. CALL DSNOPN(FILE,NCFILE,12,'READ-LIBRARY',IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! GASGET WARNING : Opening ',FILE(1:NCFILE), - ' failed ; gas data are not read.' RETURN ENDIF CALL DSNLOG(FILE,'Gas data ','Sequential','Read only ') IF(LDEBUG)PRINT *,' ++++++ GASGET 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,'GAS ',12,EXIS,'RESPECT') IF(.NOT.EXIS)THEN CALL DSNLOC(MEMBER,NCMEMB,'GAS ',12,EXIS,'IGNORE') IF(EXIS)THEN PRINT *,' ###### GASGET ERROR : Gas description '// - MEMBER(1:NCMEMB)//' has been deleted from '// - FILE(1:NCFILE)//'; not read.' ELSE PRINT *,' ###### GASGET ERROR : Gas description '// - MEMBER(1:NCMEMB)//' not found in '//FILE(1:NCFILE) ENDIF CLOSE(UNIT=12,IOSTAT=IOS,ERR=2030) RETURN ENDIF * Check that this member contains indeed gas data. READ(12,'(A80)',END=2000,IOSTAT=IOS,ERR=2010) STRING IF(LDEBUG)THEN PRINT *,' ++++++ GASGET DEBUG : Dataset header'// - ' record follows:' PRINT *,STRING ENDIF WRITE(*,'('' Member '',A8,'' was created on '',A8, - '' at '',A8/'' Remarks: '',A29)') - STRING(32:39),STRING(11:18),STRING(23:30),STRING(51:79) * Check the version. READ(12,'(A14)',END=2000,IOSTAT=IOS,ERR=2010) STRING IF(STRING(1:14).NE.' Version : 3')THEN PRINT *,' !!!!!! GASGET WARNING : This member'// - ' can not be read because of a change in format.' CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) RETURN ENDIF *** Read the rest of the dataset. READ(12,'(13X,10L1)',END=2000,IOSTAT=IOS,ERR=2010) - (GASOK(I),I=1,10) READ(12,'(13X,A)',END=2000,IOSTAT=IOS,ERR=2010) GASID READ(12,'(13X,A80)',END=2000,IOSTAT=IOS,ERR=2010) FCNTAB READ(12,'(13X,L1,3I10)',END=2000,IOSTAT=IOS,ERR=2010) - TAB2D,NGAS,NBANG,NBTAB C READ(12,'(13X,E15.8)',END=2000,IOSTAT=IOS,ERR=2010) BREAD C IF(ABS(BREAD-SQRT(B0XY**2+B0Z**2)).GT.1E-4*(1+ABS(BREAD)+ C - SQRT(B0XY**2+B0Z**2)))THEN C PRINT *,' !!!!!! GASGET WARNING : The gas table to be'// C - ' read was made for B=',BREAD/100,' T' C PRINT *,' while the current B-'// C - 'field is ',SQRT(B0XY**2+B0Z**2)/100,' T; not read.' C CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) C RETURN C ENDIF * Skip the header line. READ(12,*,END=2000,IOSTAT=IOS,ERR=2010) * Check the number of E points. IF(NGAS.LE.0.OR.NGAS.GT.MXLIST)THEN PRINT *,' !!!!!! GASGET WARNING : Number of gas points in', - ' dataset ',FILE(1:NCFILE),' out of range: ',NGAS CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) RETURN * Check the number of angles. ELSEIF(TAB2D.AND.(NBANG.LE.0.OR.NBANG.GT.MXBANG))THEN PRINT *,' !!!!!! GASGET WARNING : Number of E-B angles in', - ' dataset ',FILE(1:NCFILE),' out of range: ',NBANG CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) RETURN * Check the number of B points. ELSEIF(TAB2D.AND.(NBTAB.LE.0.OR.NBTAB.GT.MXBTAB))THEN PRINT *,' !!!!!! GASGET WARNING : Number of B fields in', - ' dataset ',FILE(1:NCFILE),' out of range: ',NBTAB CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) RETURN * Read a 2-dimensional table. ELSEIF(TAB2D)THEN READ(12,'(/(5E15.8))',IOSTAT=IOS,ERR=2010,END=2000) - (BANG(I),I=1,NBANG) READ(12,'(/(5E15.8))',IOSTAT=IOS,ERR=2010,END=2000) - (BTAB(I),I=1,NBTAB) DO 210 I=1,NGAS DO 220 J=1,NBANG DO 230 K=1,NBTAB READ(12,'(8E15.8/2E15.8)',IOSTAT=IOS,ERR=2010,END=2000) - EGAS(I),VGAS2(I,J,K),XGAS2(I,J,K),YGAS2(I,J,K), - DGAS2(I,J,K),OGAS2(I,J,K), - AGAS2(I,J,K),BGAS2(I,J,K),MGAS2(I,J,K),WGAS2(I,J,K) 230 CONTINUE 220 CONTINUE 210 CONTINUE * Read a 1-dimensional table. ELSE DO 212 I=1,NGAS READ(12,'(8E15.8/15X,7E15.8/15X,4E15.8)',END=2000, - IOSTAT=IOS,ERR=2010) - EGAS(I), - VGAS(I),CVGAS(I),XGAS(I),CXGAS(I),YGAS(I),CYGAS(I), - DGAS(I),CDGAS(I),OGAS(I),COGAS(I), - AGAS(I),CAGAS(I),BGAS(I),CBGAS(I),MGAS(I),CMGAS(I), - WGAS(I),CWGAS(I) 212 CONTINUE READ(12,'(9X,9(/I2,2E15.8))',END=2000,IOSTAT=IOS,ERR=2010) - IVEXTR,VEXTR1,VEXTR2, - IXEXTR,XEXTR1,XEXTR2,IYEXTR,YEXTR1,YEXTR2, - IDEXTR,DEXTR1,DEXTR2, - IAEXTR,AEXTR1,AEXTR2,IBEXTR,BEXTR1,BEXTR2, - IMEXTR,MEXTR1,MEXTR2,IWEXTR,WEXTR1,WEXTR2, - IOEXTR,OEXTR1,OEXTR2 READ(12,'(9X,9(/I2,2E15.8))',END=2000,IOSTAT=IOS,ERR=2010) - JVEXTR,VEXTR3,VEXTR4, - JXEXTR,XEXTR3,XEXTR4,JYEXTR,YEXTR3,YEXTR4, - JDEXTR,DEXTR3,DEXTR4, - JAEXTR,AEXTR3,AEXTR4,JBEXTR,BEXTR3,BEXTR4, - JMEXTR,MEXTR3,MEXTR4,JWEXTR,WEXTR3,WEXTR4, - JOEXTR,OEXTR3,OEXTR4 ENDIF * Read interpolation methods. READ(12,'(13X,BN,2I10)',IOSTAT=IOS,ERR=2010) IATHR,IBTHR READ(12,'(9X,BN,9I10)',IOSTAT=IOS,ERR=2010) - IVMETH,IXMETH,IYMETH,IDMETH,IAMETH,IBMETH,IMMETH, - IWMETH,IOMETH * Read cluster data. READ(12,'(4(8X,E15.8,1X))',END=2000,IOSTAT=IOS,ERR=2010) - A,Z,EMPROB,EPAIR * Ion diffusion. READ(12,'(16X,2E15.8)') DLION,DTION * Further cluster data. READ(12,'(4(8X,E15.8,1X))',END=2000,IOSTAT=IOS,ERR=2010) - CMEAN,RHO,PGAS,TGAS * Clustering model and cluster size distribution. READ(12,'(13X,A10)',END=2000,IOSTAT=IOS,ERR=2010) CLSTYP READ(12,'(13X,A80)',END=2000,IOSTAT=IOS,ERR=2010) FCNCLS READ(12,'(13X,BN,2I10)',END=2000,IOSTAT=IOS,ERR=2010) NCLS READ(12,'(13X,D25.18)',END=2000,IOSTAT=IOS,ERR=2010) CLSAVE DO 240 II=1,NCLS,5 READ(12,'(5D25.18)',END=2000,IOSTAT=IOS,ERR=2010) - (CLSDIS(I),I=II,MIN(II+4,NCLS)) 240 CONTINUE * Heed initialisation data. CALL GASHGT(IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! GASGET WARNING : Reading Heed data'// - ' failed ; gas data not available.' RETURN ENDIF *** Close the file after the operation. CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) IFAIL=0 CALL TIMLOG('Reading the gas data from a dataset: ') RETURN *** Handle the I/O error conditions. 2000 CONTINUE PRINT *,' ###### GASGET ERROR : EOF encountered while reading', - ' '//FILE(1:NCFILE)//' from unit 12 ; no gas data read.' CALL INPIOS(IOS) CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) RETURN 2010 CONTINUE PRINT *,' ###### GASGET ERROR : Error while reading'// - ' '//FILE(1:NCFILE)//' from unit 12 ; no gas data read.' CALL INPIOS(IOS) CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) RETURN 2030 CONTINUE PRINT *,' ###### GASGET ERROR : Dataset '//FILE(1:NCFILE)// - ' on unit 12 cannot be closed ; results not predictable.' CALL INPIOS(IOS) END +DECK,GASINP. SUBROUTINE GASINP(LGASPL,LGASPR,LGASWR,IFAIL) *----------------------------------------------------------------------- * GASINP - Subroutine initialising gasdata (i.e. filling /GASDAT/). * VARIABLES : IFAIL : 1 if routine failed 0 if succesful * (Last changed on 12/ 9/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,GASDATA. +SEQ,BFIELD. +SEQ,PRINTPLOT. +SEQ,CONSTANTS. CHARACTER*(MXCHAR) STRING CHARACTER*10 VARTAB(MXVAR),VARCLS(MXVAR),UNIT CHARACTER*20 STRAUX LOGICAL USE(MXVAR),STDSTR,LGASPL,LGASPR,LGASWR,FLAG(MXWORD+3), - OVERLP,EPLOG,OK REAL VAR(MXVAR),RES(MXWORD),SIZ,CLSR,PGASR,TGASR, - PGASRR,TGASRR,DATAR,DIONR,YMINR,YMAXR, - EPMIN,EPMAX,EPMINR,EPMAXR, - BANGMN,BANGMX,BAMINR,BAMAXR, - BTABMN,BTABMX,BTMINR,BTMAXR INTEGER MODVAR(MXVAR),MODRES(MXWORD),IFAIL,INPCMP,INPTYP,I,J,K, - INEXT,II,IINEXT,NWORD,IENTRY,NRES,NC,ICLS,IMETHR,IFAIL1, - IFAIL2,IFAIL3,IRANGE,NCLR,IOBJ,IEXTRR,NNGAS, - ITAB,IEP,IDRIFT,IVB,IVEXB,IDIFF,ITRANS,IMOBIL,ITOWN,IATT, - ILOREN,IFCN,NCUNIT,NGASR,NBANGR,NBTABR,NCAUX EXTERNAL STDSTR,INPCMP,INPTYP +SELF,IF=AST. EXTERNAL ASTCCH +SELF,IF=SAVE. SAVE VARTAB,VARCLS +SELF. DATA (VARTAB(I),I=1,7)/ - 'EP ','BOLTZMANN ','ECHARGE ','ANGLE_EB ', - 'B ','T ','P '/ DATA VARCLS(1)/'N '/ *** Define some output formats. 1050 FORMAT(/' LOCAL OPTIONS CURRENTLY IN EFFECT:'// - ' Plotting graphs of the gas data (GAS-PLOT): ',L1/ - ' Printing a gas summary table (GAS-PRINT): ',L1/) *** Identify the routine, if requested. IF(LIDENT)PRINT *,' /// ROUTINE GASINP ///' *** Preset the control variables. LGASWR=.FALSE. *** Preset the gas data. CALL GASINT *** Loop over the input commands, until a new heading is found. CALL INPPRM('Gas','NEW-PRINT') 10 CONTINUE *** Read a new input line. CALL INPWRD(NWORD) +SELF,IF=AST. *** Set up ASTCCH as the condition handler. CALL LIB$ESTABLISH(ASTCCH) +SELF. *** Skip this line if it is blank. CALL INPSTR(1,1,STRING,NC) IF(NWORD.EQ.0)GOTO 10 *** Leave if the first sign in the command is &. IF(STRING(1:1).EQ.'&')THEN IF(LDEBUG)PRINT *,' ++++++ GASINP DEBUG : On leaving,', - ' the GASOK bits are ',(GASOK(I),I=1,10) CALL TIMLOG('Reading the gas data: ') RETURN *** Add an item to the gas tables. ELSEIF(INPCMP(1,'ADD')+INPCMP(1,'REPL#ACE').NE.0)THEN * Call the routine. CALL GASADD *** Axes for the plots. ELSEIF(INPCMP(1,'PL#OT-OPT#IONS')+INPCMP(1,'AX#ES').NE.0)THEN * No arguments: list current settings. IF(NWORD.EQ.1)THEN WRITE(LUNOUT, - '(/'' GAS PLOT OPTIONS:''/ - '' Quantity '', - '' Log-x Log-y Range''/)') IF(.NOT.GASOPT(1,3))THEN WRITE(LUNOUT,'('' Drift velocity: '', - '' Not plotted.'')') ELSEIF(GASOPT(1,4))THEN WRITE(LUNOUT,'('' Drift velocity: '', - 2L6,2X,2E12.5)') (GASOPT(1,J),J=1,2), - (GASRNG(1,J),J=1,2) ELSE WRITE(LUNOUT,'('' Drift velocity: '', - 2L6,2X,''Automatic'')') (GASOPT(1,J),J=1,2) ENDIF IF(.NOT.GASOPT(2,3))THEN WRITE(LUNOUT,'('' Ion mobility: '', - '' Not plotted.'')') ELSEIF(GASOPT(2,4))THEN WRITE(LUNOUT,'('' Ion mobility: '', - 2L6,2X,2E12.5)') (GASOPT(2,J),J=1,2), - (GASRNG(2,J),J=1,2) ELSE WRITE(LUNOUT,'('' Ion mobility: '', - 2L6,2X,''Automatic'')') (GASOPT(2,J),J=1,2) ENDIF IF(.NOT.GASOPT(3,3))THEN WRITE(LUNOUT,'('' Diffusion coefficients: '', - '' Not plotted.'')') ELSEIF(GASOPT(3,4))THEN WRITE(LUNOUT,'('' Diffusion coefficients: '', - 2L6,2X,2E12.5)') (GASOPT(3,J),J=1,2), - (GASRNG(3,J),J=1,2) ELSE WRITE(LUNOUT,'('' Diffusion coefficients: '', - 2L6,2X,''Automatic'')') (GASOPT(3,J),J=1,2) ENDIF IF(.NOT.GASOPT(4,3))THEN WRITE(LUNOUT,'('' Townsend & attachment: '', - '' Not plotted.'')') ELSEIF(GASOPT(4,4))THEN WRITE(LUNOUT,'('' Townsend & attachment: '', - 2L6,2X,2E12.5)') (GASOPT(4,J),J=1,2), - (GASRNG(4,J),J=1,2) ELSE WRITE(LUNOUT,'('' Townsend & attachment: '', - 2L6,2X,''Automatic'')') (GASOPT(4,J),J=1,2) ENDIF IF(.NOT.GASOPT(7,3))THEN WRITE(LUNOUT,'('' Angle between v and E: '', - '' Not plotted.'')') ELSEIF(GASOPT(7,4))THEN WRITE(LUNOUT,'('' Angle between v and E: '', - 2L6,2X,2E12.5)') (GASOPT(7,J),J=1,2), - (GASRNG(7,J),J=1,2) ELSE WRITE(LUNOUT,'('' Angle between v and E: '', - 2L6,2X,''Automatic'')') (GASOPT(7,J),J=1,2) ENDIF IF(.NOT.GASOPT(5,3))THEN WRITE(LUNOUT,'('' Cluster size distribution:'', - '' Not plotted.'')') ELSE WRITE(LUNOUT,'('' Cluster size distribution:'', - 2L6)') (GASOPT(5,J),J=1,2) ENDIF GOTO 10 ENDIF * Loop over the arguments. INEXT=2 DO 700 I=2,NWORD IF(INEXT.GT.I)GOTO 700 * Identify the plot. IOBJ=0 IF(INPCMP(I,'DR#IFT-#VELOCITY-#PLOT').NE.0)THEN IOBJ=1 GASOPT(1,3)=.TRUE. ELSEIF(INPCMP(I,'NODR#IFT-#VELOCITY-#PLOT').NE.0)THEN IOBJ=0 GASOPT(1,3)=.FALSE. ELSEIF(INPCMP(I,'ION-MOB#ILITY-#PLOT')+ - INPCMP(I,'MOB#ILITY-#PLOT').NE.0)THEN GASOPT(2,3)=.TRUE. IOBJ=2 ELSEIF(INPCMP(I,'NOION-MOB#ILITY-#PLOT')+ - INPCMP(I,'NOMOB#ILITY-#PLOT').NE.0)THEN GASOPT(2,3)=.FALSE. IOBJ=0 ELSEIF(INPCMP(I,'DIFF#USION-#COEFFICIENTS-#PLOT')+ - INPCMP(I,'DIFF#USION-#PLOT').NE.0)THEN IOBJ=3 GASOPT(3,3)=.TRUE. ELSEIF(INPCMP(I,'NODIFF#USION-#COEFFICIENTS-#PLOT')+ - INPCMP(I,'NODIFF#USION-#PLOT').NE.0)THEN IOBJ=0 GASOPT(3,3)=.FALSE. ELSEIF(INPCMP(I,'TOWN#SEND-#COEFFICIENTS-#PLOT')+ - INPCMP(I,'TOWN#SEND-#PLOT')+ - INPCMP(I,'ATT#ACHMENT-#COEFFICIENTS-#PLOT')+ - INPCMP(I,'ATT#ACHMENT-#PLOT').NE.0)THEN IOBJ=4 GASOPT(4,3)=.TRUE. ELSEIF(INPCMP(I,'NOTOWN#SEND-#COEFFICIENTS-#PLOT')+ - INPCMP(I,'NOTOWN#SEND-#PLOT')+ - INPCMP(I,'ATT#ACHMENT-#COEFFICIENTS-#PLOT')+ - INPCMP(I,'ATT#ACHMENT-#PLOT').NE.0)THEN IOBJ=0 GASOPT(4,3)=.FALSE. ELSEIF(INPCMP(I,'CLUS#TER-#SIZE-#DISTRIBUTION-#PLOT')+ - INPCMP(I,'CLUS#TER-#SIZE-#PLOT').NE.0)THEN IOBJ=5 GASOPT(5,3)=.TRUE. ELSEIF(INPCMP(I,'NOCLUS#TER-#SIZE-#DISTRIBUTION-#PLOT')+ - INPCMP(I,'NOCLUS#TER-#SIZE-#PLOT').NE.0)THEN IOBJ=0 GASOPT(5,3)=.FALSE. ELSEIF(INPCMP(I,'LOR#ENTZ-#ANGLES-#PLOT').NE.0)THEN IOBJ=7 GASOPT(7,3)=.TRUE. ELSEIF(INPCMP(I,'NOLOR#ENTZ-#ANGLES-#PLOT').NE.0)THEN IOBJ=0 GASOPT(7,3)=.FALSE. ELSE CALL INPMSG(I,'Not a known plot.') GOTO 700 ENDIF * Skip rest if plot not requested. IF(IOBJ.EQ.0)GOTO 700 * Identify the axes and ranges. DO 730 J=I+1,NWORD IF(J.LT.INEXT)GOTO 730 IF(INPCMP(J,'LIN#EAR-X').NE.0)THEN GASOPT(IOBJ,1)=.FALSE. INEXT=J+1 ELSEIF(INPCMP(J,'LOG#ARITHMIC-X').NE.0)THEN GASOPT(IOBJ,1)=.TRUE. INEXT=J+1 ELSEIF(INPCMP(J,'LIN#EAR-Y').NE.0)THEN GASOPT(IOBJ,2)=.FALSE. INEXT=J+1 ELSEIF(INPCMP(J,'LOG#ARITHMIC-Y').NE.0)THEN GASOPT(IOBJ,2)=.TRUE. INEXT=J+1 ELSEIF(INPCMP(J,'RANGE')+INPCMP(J,'SCALE').NE.0)THEN IF(INPCMP(J+1,'AUTO#MATIC').NE.0)THEN GASOPT(IOBJ,4)=.FALSE. INEXT=J+2 ELSEIF(INPTYP(J+1).LE.0.OR.INPTYP(J+2).LE.0)THEN CALL INPMSG(J,'Values missing') ELSE GASOPT(IOBJ,4)=.TRUE. CALL INPCHK(J+1,2,IFAIL1) CALL INPCHK(J+2,2,IFAIL2) CALL INPRDR(J+1,YMINR,0.0) CALL INPRDR(J+2,YMAXR,0.0) IF(IFAIL1.EQ.0.AND.IFAIL2.EQ.0)THEN IF(YMINR.NE.YMAXR)THEN GASRNG(IOBJ,1)=MIN(YMINR,YMAXR) GASRNG(IOBJ,2)=MAX(YMINR,YMAXR) ELSE CALL INPMSG(J+1, - 'Zero range not permitted.') CALL INPMSG(J+1, - 'See previous message.') ENDIF ENDIF INEXT=J+3 ENDIF ELSE INEXT=J GOTO 700 ENDIF 730 CONTINUE * Next plot. 700 CONTINUE * Dump error messages. CALL INPERR *** Call the routine A50E50 if ARGON-50-ETHANE-50 is the keyword. ELSEIF(INPCMP(1,'A#RGON-50-E#THANE-50')+ - INPCMP(1,'E#THANE-50-A#RGON-50').NE.0)THEN CALL A50E50 *** Call the routine A20E80 if ARGON-20-ETHANE-80 is the keyword. ELSEIF(INPCMP(1,'A#RGON-20-E#THANE-80')+ - INPCMP(1,'E#THANE-80-A#RGON-20').NE.0)THEN CALL A20E80 *** Call the routine A80E20 if ARGON-80-ETHANE-20 is the keyword. ELSEIF(INPCMP(1,'A#RGON-80-E#THANE-20')+ - INPCMP(1,'E#THANE-20-A#RGON-80').NE.0)THEN CALL A80E20 *** Call the routine A73M20 if ARGON-73-ETHANE-20-PROPANOL-7 is asked. ELSEIF(INPCMP(1,'A#RGON-73-M#ETHANE-20-#PROPANOL-#7')+ - INPCMP(1,'M#ETHANE-20-A#RGON-73-#PROPANOL-#7').NE.0)THEN CALL A73M20 *** Call the routine C80E20 if CO2-80-ETHANE-20 is the keyword. ELSEIF(INPCMP(1,'CO2-80-E#THANE-20')+ - INPCMP(1,'E#THANE-20-CO2-80').NE.0)THEN CALL C80E20 *** Call the routine C90E10 if CO2-90-ETHANE-10 is the keyword. ELSEIF(INPCMP(1,'CO2-90-E#THANE-10')+ - INPCMP(1,'E#THANE-10-CO2-90').NE.0)THEN CALL C90E10 *** Call the routine C90I10 if CO2-90-ISOBUTANE-10 is the keyword. ELSEIF(INPCMP(1,'CO2-90-I#SOBUTANE-10')+ - INPCMP(1,'I#SOBUTANE-10-CO2-90').NE.0)THEN CALL C90I10 *** Call the routine CO2 to transfer data if CO2 is a keyword. ELSEIF(INPCMP(1,'CO2').NE.0)THEN CALL CO2 *** Read the cluster size distribution if CLUSTER-SIZE is a keyword. ELSEIF(INPCMP(1,'CL#USTER-#SIZE-#DISTRIBUTION').NE.0)THEN ** Initialise. NFCLS=0 FCNCLS='?' NCLS=MXPAIR OVERLP=.FALSE. ** Read further command line arguments. IINEXT=2 DO 30 II=2,NWORD IF(II.LT.IINEXT)GOTO 30 * Function following ? IF(INPCMP(II,'F#UNCTION').NE.0)THEN CALL INPSTR(II+1,II+1,STRING,NFCLS) FCNCLS=STRING(1:NFCLS) IINEXT=II+2 * Maximum number of entries for functions. ELSEIF(INPCMP(II,'N-#MAXIMUM')+ - INPCMP(II,'MAX#IMUM-#CLUSTER-#SIZE').NE.0)THEN CALL INPCHK(II+1,1,IFAIL1) CALL INPRDI(II+1,NCLR,0) IF(NCLR.LE.0.AND.IFAIL1.EQ.0)THEN CALL INPMSG(II+1,'Not a positive integer.') ELSEIF(NCLR.GT.MXPAIR.OR.IFAIL1.NE.0)THEN CALL INPMSG(II+1,'Should be < MXPAIR.') NCLS=MXPAIR ELSE NCLS=NCLR ENDIF IINEXT=II+2 * Overlap with table entries. ELSEIF(INPCMP(II,'OVERLAP-#TABLE-#AND-#FUNCTION').NE.0)THEN OVERLP=.TRUE. ELSEIF(INPCMP(II,'NOOVERLAP-#TABLE-#AND-#FUNCTION').NE. - 0)THEN OVERLP=.FALSE. * Other keywords are not known. ELSE CALL INPMSG(II+1,'Not a known keyword.') ENDIF 30 CONTINUE * Print error messages. CALL INPERR ** Check that a function was indeed specified. IF(NWORD.GT.1.AND.NFCLS.LE.0)PRINT *,' !!!!!! GASINP'// - ' WARNING : Cluster function not found.' IF(NWORD.GT.1.AND.NFCLS.LE.0.AND..NOT.OVERLP)THEN PRINT *,' !!!!!! GASINP WARNING : Also no OVERLAP'// - ' option; CLUSTER ignored.' GOTO 10 ENDIF ** If a function is present, process it. IF(NFCLS.GE.1)THEN IF(INDEX(FCNCLS(1:NFCLS),'@').NE.0)THEN NRES=1 CALL ALGEDT(VARCLS,1,IENTRY,USE,NRES) ELSE CALL ALGPRE(FCNCLS,NFCLS,VARCLS,1,NRES,USE,IENTRY, - IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! GASINP WARNING : Cluster'// - ' size distribution function rejected.' CALL ALGCLR(IENTRY) GOTO 10 ENDIF ENDIF IF(NRES.NE.1)THEN PRINT *,' !!!!!! GASINP WARNING : Number of'// - ' results returned by the cluster size'// - ' distribution function is not 1.' CALL ALGCLR(IENTRY) GOTO 10 ENDIF * Enter the function into the CLSDIS histogram. DO 200 I=1,NCLS VAR(1)=I-1.0 MODVAR(1)=2 CALL ALGEXE(IENTRY,VAR,MODVAR,1,RES,MODRES,1,IFAIL1) SIZ=RES(1) VAR(1)=I-0.5 CALL ALGEXE(IENTRY,VAR,MODVAR,1,RES,MODRES,1,IFAIL2) SIZ=SIZ+4.0*RES(1) VAR(1)=I CALL ALGEXE(IENTRY,VAR,MODVAR,1,RES,MODRES,1,IFAIL3) SIZ=(SIZ+RES(1))/6.0 IF(SIZ.LT.0.0.OR.IFAIL1+IFAIL2+IFAIL3.NE.0)THEN PRINT *,' !!!!!! GASINP WARNING : Function gave'// - ' non-positive probability or arithmetic'// - ' error for size ',I,' ; set to 0.' CLSDIS(I)=0 ELSE CLSDIS(I)=SIZ ENDIF 200 CONTINUE * Print number of algebra errors. CALL ALGERR * Finally accept the function and remember it was a function. GASOK(5)=.TRUE. CLSTYP='FUNCTION' * Release the instruction list. CALL ALGCLR(IENTRY) ENDIF ** Read a table. IF(NWORD.EQ.1.OR.OVERLP)THEN ICLS=0 IFAIL=0 * Output a prompt in interactive use. IF(STDSTR('INPUT')) - PRINT *,' ====== GASINP INPUT :'// - ' Please enter the cluster size distribution ;'// - ' terminate with a blank line.' CALL INPPRM('Cluster','ADD-NOPRINT') * Read the table line by line. 210 CONTINUE CALL INPWRD(NWORD) IF(NWORD.EQ.0)GOTO 230 CALL INPSTR(1,1,STRING,NC) IF(STRING(1:1).EQ.'&')THEN PRINT *,' !!!!!! GASINP WARNING : You can not'// - ' leave the section here ; line ignored.' GOTO 210 ENDIF * And read all probabilities within each line. DO 220 I=1,NWORD ICLS=ICLS+1 IF(ICLS.GT.MXPAIR)GOTO 210 CALL INPCHK(I,2,IFAIL1) CALL INPRDR(I,CLSR,0.0) IF(CLSR.LT.0.0)THEN CALL INPMSG(I,'Probabilities may not be < 0. ') CLSDIS(ICLS)=0 ELSE CLSDIS(ICLS)=CLSR ENDIF 220 CONTINUE CALL INPERR GOTO 210 * End of reading loop: check some correct data is present. 230 CONTINUE * If this was a pure table, set NCLS. IF(.NOT.OVERLP)NCLS=ICLS IF(NCLS.GT.MXPAIR)THEN PRINT *,' !!!!!! GASINP WARNING : Too many', - ' cluster size points ; excess ignored.' NCLS=MXPAIR GASOK(5)=.TRUE. IF(OVERLP)THEN CLSTYP='OVERLAP' ELSE CLSTYP='TABLE' ENDIF ELSEIF(NCLS.EQ.0)THEN PRINT *,' !!!!!! GASINP WARNING : The CLUSTER'// - ' statement is empty and is ignored.' ELSE GASOK(5)=.TRUE. IF(OVERLP)THEN CLSTYP='OVERLAP' ELSE CLSTYP='TABLE' ENDIF ENDIF * Reset the prompt. CALL INPPRM(' ','BACK-PRINT') ENDIF *** Call routine ETHANE to transfer data if ETHANE is a keyword. ELSEIF(INPCMP(1,'ETH#ANE').NE.0)THEN CALL ETHANE *** Set the extrapolation method. ELSEIF(INPCMP(1,'EXT#RAPOLATIONS').NE.0)THEN * Print the current settings if entered without argument. IF(NWORD.EQ.1)THEN WRITE(LUNOUT,'(/1X,A)') ' Currently, the'// - ' extraplation methods for large E/p, are'// - ' set as follows:' * Drift velocity for large E/p. IF(IVEXTR.EQ.0)THEN WRITE(LUNOUT,'(5X,A)') 'v || E: constant,' ELSEIF(IVEXTR.EQ.1)THEN WRITE(LUNOUT,'(5X,A)') 'v || E: linear,' ELSEIF(IVEXTR.EQ.2)THEN WRITE(LUNOUT,'(5X,A)') 'v || E: exponential,' ENDIF * Drift velocity ExB component large E/p. IF(IXEXTR.EQ.0)THEN WRITE(LUNOUT,'(5X,A)') 'v || Btrans: constant,' ELSEIF(IXEXTR.EQ.1)THEN WRITE(LUNOUT,'(5X,A)') 'v || Btrans: linear,' ELSEIF(IXEXTR.EQ.2)THEN WRITE(LUNOUT,'(5X,A)') 'v || Btrans: exponential,' ENDIF * Drift velocity B component for large E/p. IF(IYEXTR.EQ.0)THEN WRITE(LUNOUT,'(5X,A)') 'v || ExB: constant,' ELSEIF(IYEXTR.EQ.1)THEN WRITE(LUNOUT,'(5X,A)') 'v || ExB: linear,' ELSEIF(IYEXTR.EQ.2)THEN WRITE(LUNOUT,'(5X,A)') 'v || ExB: exponential,' ENDIF * Lorentz angle for large E/p. IF(IWEXTR.EQ.0)THEN WRITE(LUNOUT,'(5X,A)') '(v,E) angle: constant,' ELSEIF(IWEXTR.EQ.1)THEN WRITE(LUNOUT,'(5X,A)') '(v,E) angle: linear,' ELSEIF(IWEXTR.EQ.2)THEN WRITE(LUNOUT,'(5X,A)') - '(v,E) angle: exponential,' ENDIF * Mobility for large E/p. IF(IMEXTR.EQ.0)THEN WRITE(LUNOUT,'(5X,A)') 'ion mobility: constant,' ELSEIF(IMEXTR.EQ.1)THEN WRITE(LUNOUT,'(5X,A)') 'ion mobility: linear,' ELSEIF(IMEXTR.EQ.2)THEN WRITE(LUNOUT,'(5X,A)') - 'ion mobility: exponential,' ENDIF * Longitudinal diffusion for large E/p. IF(IDEXTR.EQ.0)THEN WRITE(LUNOUT,'(5X,A)') - 'longitudinal diffusion: constant,' ELSEIF(IDEXTR.EQ.1)THEN WRITE(LUNOUT,'(5X,A)') - 'longitudinal diffusion: linear,' ELSEIF(IDEXTR.EQ.2)THEN WRITE(LUNOUT,'(5X,A)') - 'longitudinal diffusion: exponential,' ENDIF * Transverse diffusion for large E/p. IF(IOEXTR.EQ.0)THEN WRITE(LUNOUT,'(5X,A)') - 'transverse diffusion: constant,' ELSEIF(IOEXTR.EQ.1)THEN WRITE(LUNOUT,'(5X,A)') - 'transverse diffusion: linear,' ELSEIF(IOEXTR.EQ.2)THEN WRITE(LUNOUT,'(5X,A)') - 'transverse diffusion: exponential,' ENDIF * Townsend coefficient for large E/p. IF(IAEXTR.EQ.0)THEN WRITE(LUNOUT,'(5X,A)') - 'Townsend coefficient: constant,' ELSEIF(IAEXTR.EQ.1)THEN WRITE(LUNOUT,'(5X,A)') - 'Townsend coefficient: linear,' ELSEIF(IAEXTR.EQ.2)THEN WRITE(LUNOUT,'(5X,A)') - 'Townsend coefficient: exponential,' ENDIF * Attachment coefficient for large E/p. IF(IBEXTR.EQ.0)THEN WRITE(LUNOUT,'(5X,A)') - 'attachment coefficient: constant.' ELSEIF(IBEXTR.EQ.1)THEN WRITE(LUNOUT,'(5X,A)') - 'attachment coefficient: linear.' ELSEIF(IBEXTR.EQ.2)THEN WRITE(LUNOUT,'(5X,A)') - 'attachment coefficient: exponential.' ENDIF * Small values. WRITE(LUNOUT,'(/1X,A)') ' The extrapolations'// - ' to E/p below the first table point are done'// - ' as follows:' * Drift velocity for small E/p. IF(JVEXTR.EQ.0)THEN WRITE(LUNOUT,'(5X,A)') 'v || E: constant,' ELSEIF(JVEXTR.EQ.1)THEN WRITE(LUNOUT,'(5X,A)') 'v || E: linear,' ELSEIF(JVEXTR.EQ.2)THEN WRITE(LUNOUT,'(5X,A)') 'v || E: exponential,' ENDIF IF(JXEXTR.EQ.0)THEN WRITE(LUNOUT,'(5X,A)') 'v || Btrans: constant,' ELSEIF(JXEXTR.EQ.1)THEN WRITE(LUNOUT,'(5X,A)') 'v || Btrans: linear,' ELSEIF(JXEXTR.EQ.2)THEN WRITE(LUNOUT,'(5X,A)') 'v || Btrans: exponential,' ENDIF IF(JYEXTR.EQ.0)THEN WRITE(LUNOUT,'(5X,A)') 'v || ExB: constant,' ELSEIF(JYEXTR.EQ.1)THEN WRITE(LUNOUT,'(5X,A)') 'v || ExB: linear,' ELSEIF(JYEXTR.EQ.2)THEN WRITE(LUNOUT,'(5X,A)') 'v || ExB: exponential,' ENDIF * Lorentz angle for small E/p. IF(JWEXTR.EQ.0)THEN WRITE(LUNOUT,'(5X,A)') '(v,E) angle: constant,' ELSEIF(JWEXTR.EQ.1)THEN WRITE(LUNOUT,'(5X,A)') '(v,E) angle: linear,' ELSEIF(JWEXTR.EQ.2)THEN WRITE(LUNOUT,'(5X,A)') - '(v,E) angle: exponential,' ENDIF * Ion mobility for small E/p. IF(JMEXTR.EQ.0)THEN WRITE(LUNOUT,'(5X,A)') 'ion mobility: constant,' ELSEIF(JMEXTR.EQ.1)THEN WRITE(LUNOUT,'(5X,A)') 'ion mobility: linear,' ELSEIF(JMEXTR.EQ.2)THEN WRITE(LUNOUT,'(5X,A)') - 'ion mobility: exponential,' ENDIF * Longitudinal diffusion for small E/p. IF(JDEXTR.EQ.0)THEN WRITE(LUNOUT,'(5X,A)') - 'longitudinal diffusion: constant,' ELSEIF(JDEXTR.EQ.1)THEN WRITE(LUNOUT,'(5X,A)') - 'longitudinal diffusion: linear,' ELSEIF(JDEXTR.EQ.2)THEN WRITE(LUNOUT,'(5X,A)') - 'longitudinal diffusion: exponential,' ENDIF * Transverse diffusion for small E/p. IF(JOEXTR.EQ.0)THEN WRITE(LUNOUT,'(5X,A)') - 'transverse diffusion: constant,' ELSEIF(JOEXTR.EQ.1)THEN WRITE(LUNOUT,'(5X,A)') - 'transverse diffusion: linear,' ELSEIF(JOEXTR.EQ.2)THEN WRITE(LUNOUT,'(5X,A)') - 'transverse diffusion: exponential,' ENDIF * Townsend coefficient for small E/p. IF(JAEXTR.EQ.0)THEN WRITE(LUNOUT,'(5X,A)') - 'Townsend coefficient: constant,' ELSEIF(JAEXTR.EQ.1)THEN WRITE(LUNOUT,'(5X,A)') - 'Townsend coefficient: linear,' ELSEIF(JAEXTR.EQ.2)THEN WRITE(LUNOUT,'(5X,A)') - 'Townsend coefficient: exponential,' ENDIF * Attachment coefficient for small E/p. IF(JBEXTR.EQ.0)THEN WRITE(LUNOUT,'(5X,A)') - 'attachment coefficient: constant.' ELSEIF(JBEXTR.EQ.1)THEN WRITE(LUNOUT,'(5X,A)') - 'attachment coefficient: linear.' ELSEIF(JBEXTR.EQ.2)THEN WRITE(LUNOUT,'(5X,A)') - 'attachment coefficient: exponential.' ENDIF * Number of points used for the extrapolations. IF(IVEXTR.EQ.0.OR. - IXEXTR.EQ.0.OR.IYEXTR.EQ.0.OR. - IAEXTR.EQ.0.OR.IBEXTR.EQ.0.OR. - IMEXTR.EQ.0.OR.IWEXTR.EQ.0.OR. - IDEXTR.EQ.0.OR.IOEXTR.EQ.0.OR. - JVEXTR.EQ.0.OR.JDEXTR.EQ.0.OR. - JXEXTR.EQ.0.OR.JYEXTR.EQ.0.OR. - JAEXTR.EQ.0.OR.JBEXTR.EQ.0.OR. - JMEXTR.EQ.0.OR.JWEXTR.EQ.0.OR. - JOEXTR.EQ.0) - WRITE(LUNOUT,'(/1X,A/)') - ' Constant extrapolations use the last point.' IF(IVEXTR.GT.0.OR. - IXEXTR.GT.0.OR.IYEXTR.GT.0.OR. - IAEXTR.GT.0.OR.IBEXTR.GT.0.OR. - IMEXTR.GT.0.OR.IWEXTR.GT.0.OR. - IDEXTR.GT.0.OR.IOEXTR.GT.0.OR. - JVEXTR.GT.0.OR.JDEXTR.GT.0.OR. - JXEXTR.GT.0.OR.JYEXTR.GT.0.OR. - JAEXTR.GT.0.OR.JBEXTR.GT.0.OR. - JMEXTR.GT.0.OR.JWEXTR.GT.0.OR. - JOEXTR.GT.0) - WRITE(LUNOUT,'(/1X,A/)') - ' Linear and exponential extrapolations are'// - ' based on the last 2 points.' WRITE(LUNOUT,'('' '')') ENDIF * Read the string if there are arguments. INEXT=2 DO 710 I=2,NWORD IF(I.LT.INEXT)GOTO 710 IF(I+1.GT.NWORD)THEN CALL INPMSG(I,'The method should be specified') GOTO 710 ELSEIF(INPCMP(I+1,'C#ONSTANT').NE.0)THEN IEXTRR=0 INEXT=I+2 ELSEIF(INPCMP(I+1,'E#XPONENTIALLY').NE.0)THEN IEXTRR=2 INEXT=I+2 ELSEIF(INPCMP(I+1,'L#INEARLY').NE.0)THEN IEXTRR=1 INEXT=I+2 ELSE CALL INPMSG(I,'Valid method not specified. ') CALL INPMSG(I+1,'Unknown extrapolation method. ') GOTO 710 ENDIF IF(INPCMP(I,'H#IGH-DR#IFT-#VELOCITY')+ - INPCMP(I,'DR#IFT-#VELOCITY').NE.0)THEN IVEXTR=IEXTRR ELSEIF(INPCMP(I,'H#IGH-DI#FFUSION-#COEFFICIENT')+ - INPCMP(I,'DI#FFUSION-#COEFFICIENT')+ - INPCMP(I,'H#IGH-LONG#ITUDINAL-'// - 'DI#FFUSION-#COEFFICIENT')+ - INPCMP(I,'LONG#ITUDINAL-'// - 'DI#FFUSION-#COEFFICIENT').NE.0)THEN IDEXTR=IEXTRR ELSEIF(INPCMP(I,'H#IGH-TRANS#VERSE-'// - 'DI#FFUSION-#COEFFICIENT')+ - INPCMP(I,'TRANS#VERSE-'// - 'DI#FFUSION-#COEFFICIENT').NE.0)THEN IOEXTR=IEXTRR ELSEIF(INPCMP(I,'H#IGH-LOR#ENTZ-#ANGLE')+ - INPCMP(I,'LOR#ENTZ-#ANGLE').NE.0)THEN IWEXTR=IEXTRR ELSEIF(INPCMP(I,'H#IGH-T#OWNSEND-#COEFFICIENT')+ - INPCMP(I,'T#OWNSEND-#COEFFICIENT').NE.0)THEN IAEXTR=IEXTRR ELSEIF(INPCMP(I,'H#IGH-A#TTACHMENT-#COEFFICIENT')+ - INPCMP(I,'A#TTACHMENT-#COEFFICIENT').NE.0)THEN IBEXTR=IEXTRR ELSEIF(INPCMP(I,'H#IGH-ION-MOB#ILITY')+ - INPCMP(I,'ION-MOB#ILITY').NE.0)THEN IMEXTR=IEXTRR ELSEIF(INPCMP(I,'L#OW-DR#IFT-#VELOCITY').NE.0)THEN JVEXTR=IEXTRR ELSEIF(INPCMP(I,'L#OW-DI#FFUSION-#COEFFICIENT')+ - INPCMP(I,'L#OW-LONG#ITUDINAL-'// - 'DI#FFUSION-#COEFFICIENT').NE.0)THEN JDEXTR=IEXTRR ELSEIF(INPCMP(I,'L#OW-TRANS#VERSE-'// - 'DI#FFUSION-#COEFFICIENT').NE.0)THEN JOEXTR=IEXTRR ELSEIF(INPCMP(I,'L#OW-LOR#ENTZ-#ANGLE').NE.0)THEN JWEXTR=IEXTRR ELSEIF(INPCMP(I,'L#OW-T#OWNSEND-#COEFFICIENT').NE.0)THEN JAEXTR=IEXTRR ELSEIF(INPCMP(I,'L#OW-A#TTACHMENT-#COEFFICIENT').NE.0)THEN JBEXTR=IEXTRR ELSEIF(INPCMP(I,'L#OW-ION-MOB#ILITY').NE.0)THEN JMEXTR=IEXTRR ELSE CALL INPMSG(I,'Unknown object to extrapolate.') ENDIF 710 CONTINUE CALL INPERR *** Set the interpolation method. ELSEIF(INPCMP(1,'INT#ERPOLATIONS').NE.0)THEN * Print the current settings if entered without argument. IF(NWORD.EQ.1)THEN WRITE(LUNOUT,'(/1X,A)') - ' Currently the interpolation methods'// - ' are chosen as follows:' * Drift velocity. IF(IVMETH.EQ.0)THEN WRITE(LUNOUT,'(5X,''v || E: Cubic splines,'')') ELSE WRITE(LUNOUT,'(5X,''v || E: Newton'', - '' interpolation of order'',I3,'','')') - IVMETH ENDIF IF(IXMETH.EQ.0)THEN WRITE(LUNOUT,'(5X,''v || Btrans: Cubic'', - '' splines,'')') ELSE WRITE(LUNOUT,'(5X,''v || Btrans: Newton'', - '' interpolation of order'',I3,'','')') - IXMETH ENDIF IF(IYMETH.EQ.0)THEN WRITE(LUNOUT,'(5X,''v || ExB: Cubic'', - '' splines,'')') ELSE WRITE(LUNOUT,'(5X,''v || ExB: Newton'', - '' interpolation of order'',I3,'','')') - IYMETH ENDIF * Lorentz angle. IF(IWMETH.EQ.0)THEN WRITE(LUNOUT,'(5X,''(v,E) angle: Cubic'', - '' splines,'')') ELSE WRITE(LUNOUT,'(5X,''(v,E) angle: Newton'', - '' interpolation of order'',I3,'','')') - IWMETH ENDIF * Ion mobility. IF(IMMETH.EQ.0)THEN WRITE(LUNOUT,'(5X,''ion mobility: Cubic'', - '' splines,'')') ELSE WRITE(LUNOUT,'(5X,''ion mobility: Newton'', - '' interpolation of order'',I3,'','')') - IMMETH ENDIF * Longitudinal diffusion. IF(IDMETH.EQ.0)THEN WRITE(LUNOUT,'(5X,''longitudinal diffusion:'', - '' Cubic splines,'')') ELSE WRITE(LUNOUT,'(5X,''longitudinal diffusion:'', - '' Newton interpolation of order'',I3, - '','')') IDMETH ENDIF * Transverse diffusion. IF(IOMETH.EQ.0)THEN WRITE(LUNOUT,'(5X,''transverse diffusion:'', - '' Cubic splines,'')') ELSE WRITE(LUNOUT,'(5X,''transverse diffusion:'', - '' Newton interpolation of order'',I3, - '','')') IOMETH ENDIF * Townsend coefficient. IF(IAMETH.EQ.0)THEN WRITE(LUNOUT,'(5X,''Townsend coefficient:'', - '' Cubic splines,'')') ELSE WRITE(LUNOUT,'(5X,''Townsend coefficient:'', - '' Newton interpolation of order'',I3, - '','')') IAMETH ENDIF * Attachment coefficient. IF(IBMETH.EQ.0)THEN WRITE(LUNOUT,'(5X,''attachment coefficient:'', - '' Cubic splines.'')') ELSE WRITE(LUNOUT,'(5X,''attachment coefficient:'', - '' Newton interpolation of order'',I3, - ''.'')') IBMETH ENDIF WRITE(LUNOUT,'('' '')') ENDIF * Read the string if there are arguments. INEXT=2 DO 720 I=2,NWORD IF(I.LT.INEXT)GOTO 720 IF(I+1.GT.NWORD)THEN CALL INPMSG(I,'The method should be specified') GOTO 720 ELSEIF(INPCMP(I+1,'SPL#INES').NE.0)THEN IMETHR=0 INEXT=I+2 ELSEIF(INPCMP(I+1,'LIN#EAR').NE.0)THEN IMETHR=1 INEXT=I+2 ELSEIF(INPCMP(I+1,'QUA#DRATIC').NE.0)THEN IMETHR=2 INEXT=I+2 ELSEIF(INPCMP(I+1,'CUB#IC').NE.0)THEN IMETHR=3 INEXT=I+2 ELSEIF(INPCMP(I+1,'NEW#TON-#POLYNOMIALS').NE.0)THEN IF(NWORD.LT.I+2.OR.INPTYP(I+2).NE.1)THEN IMETHR=2 INEXT=I+2 ELSE CALL INPCHK(I+2,1,IFAIL1) CALL INPRDI(I+2,IMETHR,2) IF(IMETHR.LT.1)THEN CALL INPMSG(I+2, - 'The order must be 1 or larger.') IMETHR=2 ENDIF INEXT=I+3 ENDIF ELSE CALL INPMSG(I,'Not followed by a method. ') CALL INPMSG(I+1,'Unknown interpolation method. ') INEXT=I+2 GOTO 720 ENDIF IF(INPCMP(I,'DR#IFT-#VELOCITY').NE.0)THEN IVMETH=IMETHR ELSEIF(INPCMP(I,'LOR#ENTZ-#ANGLE').NE.0)THEN IWMETH=IMETHR ELSEIF(INPCMP(I,'ION-MOB#ILITY').NE.0)THEN IMMETH=IMETHR ELSEIF(INPCMP(I,'DI#FFUSION-#COEFFICIENT')+ - INPCMP(I,'LONG#ITUDINAL-'// - 'DI#FFUSION-#COEFFICIENT').NE.0)THEN IDMETH=IMETHR ELSEIF(INPCMP(I,'TRANS#VERSE-'// - 'DI#FFUSION-#COEFFICIENT').NE.0)THEN IOMETH=IMETHR ELSEIF(INPCMP(I,'T#OWNSEND-#COEFFICIENT').NE.0)THEN IAMETH=IMETHR ELSEIF(INPCMP(I,'A#TTACHMENT-#COEFFICIENT').NE.0)THEN IBMETH=IMETHR ELSE CALL INPMSG(I,'Unknown object to interpolate.') ENDIF 720 CONTINUE CALL INPERR *** Call routine ISOBUT to transfer data if ISOBUTANE is a keyword. ELSEIF(INPCMP(1,'ISO#BUTANE').NE.0)THEN CALL ISOBUT *** Call routine METHAN to transfer data if METHANE is a keyword. ELSEIF(INPCMP(1,'MET#HANE').NE.0)THEN CALL METHAN *** Set GAS-ID if this is a keyword. ELSEIF(INPCMP(1,'GAS-ID#ENTIFIER').NE.0)THEN IF(NWORD.EQ.1.AND.GASID.EQ.' ')THEN WRITE(LUNOUT,'(2X/''The gas identification has'', - '' not yet been set.''/)') ELSEIF(NWORD.EQ.1)THEN WRITE(LUNOUT,'(2X/''The current gas identification'', - '' is: '',A/)') GASID ELSE CALL INPSTR(2,2,STRING,NC) IF(NC.GT.80)PRINT *,' !!!!!! GASINP WARNING : The'// - ' gas identifier is truncated to 80 characters.' GASID=STRING(1:MIN(NC,80)) ENDIF *** Read the gas from dataset, if GET is a keyword. ELSEIF(INPCMP(1,'GET').NE.0)THEN CALL GASGET(IFAIL1) IF(IFAIL1.NE.0)CALL GASINT *** Heed gas mixing. ELSEIF(INPCMP(1,'HEED').NE.0)THEN CALL GASHEE(IFAIL1) *** Gas mixing. ELSEIF(INPCMP(1,'MIX').NE.0)THEN CALL GASMIX *** Magboltz gas mixing. ELSEIF(INPCMP(1,'MAGBOLTZ').NE.0)THEN CALL GASBMC(IFAIL1) *** Identify the options if OPTION is a keyword. ELSEIF(INPCMP(1,'OPT#IONS').NE.0)THEN IF(NWORD.EQ.1)PRINT 1050,LGASPL,LGASPR DO 400 I=2,NWORD * Check for gas plot options. IF(INPCMP(I,'NOG#AS-PL#OT').NE.0)THEN LGASPL=.FALSE. ELSEIF(INPCMP(I,'G#AS-PL#OT').NE.0)THEN LGASPL=.TRUE. * Check for gas print options. ELSEIF(INPCMP(I,'NOG#AS-PR#INT').NE.0)THEN LGASPR=.FALSE. ELSEIF(INPCMP(I,'G#AS-PR#INT').NE.0)THEN LGASPR=.TRUE. * Option is not known. ELSE CALL INPMSG(I,'The option is not known. ') ENDIF 400 CONTINUE CALL INPERR *** Find the gas-parameter setting instructions. ELSEIF(INPCMP(1,'PAR#AMETERS').NE.0)THEN IF(NWORD.LT.3)WRITE(LUNOUT,'('' CURRENT SETTINGS OF'', - '' SOME GAS PARAMETERS: ''// - '' Number of protons in one molecule : '',F5.0/ - '' Atomic number of the gas : '',F5.0/ - '' Density : '',E10.3, - '' [g/cm3]''// - '' Average number of clusters per cm : '',F10.2/ - '' Most probable energy loss per cm : '',F10.2, - '' [eV/cm]''/ - '' Energy needed for one ion pair : '',F10.2, - '' [eV]''// - '' Longitudinal ion diffusion : '',F10.3, - '' [cm for 1 cm of drift]''/ - '' Transverse ion diffusion : '',F10.3, - '' [cm for 1 cm of drift]'')') - A,Z,RHO,CMEAN,EMPROB,EPAIR,DLION,DTION DO 500 I=2,NWORD-1,2 IF(INPCMP(I,'A').NE.0)THEN CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,A,-1.0) GASOK(5)=.TRUE. CLSTYP='LANDAU' IF(A.LE.0.0.AND.IFAIL1.EQ.0) - CALL INPMSG(I+1,'The atomic number must be > 0.') ELSEIF(INPCMP(I,'Z').NE.0)THEN CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,Z,-1.0) GASOK(5)=.TRUE. CLSTYP='LANDAU' IF(Z.LE.0.0.AND.IFAIL1.EQ.0) - CALL INPMSG(I+1,'The nuclear charge is not > 0.') ELSEIF(INPCMP(I,'E#NERGY-M#OST-#PROBABLE')+ - INPCMP(I,'M#OST-PR#OBABLE-E#NERGY-#LOSS').NE.0)THEN CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,EMPROB,-1.0) GASOK(5)=.TRUE. CLSTYP='LANDAU' IF(EMPROB.LE.0.0.AND.IFAIL1.EQ.0) - CALL INPMSG(I+1,'The energy loss should be > 0.') ELSEIF(INPCMP(I,'ME#AN').NE.0.OR. - INPCMP(I,'N-#MEAN').NE.0)THEN CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,CMEAN,-1.0) GASOK(5)=.TRUE. IF(CMEAN.LE.0.0.AND.IFAIL1.EQ.0) - CALL INPMSG(I+1,'The cluster spacing is not > 0') ELSEIF(INPCMP(I,'P#AIR-C#REATION-#ENERGY')+ - INPCMP(I,'E#NERGY-P#AIR').NE.0)THEN CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,EPAIR,-1.0) GASOK(5)=.TRUE. CLSTYP='LANDAU' IF(EPAIR.LE.0.0.AND.IFAIL1.EQ.0) - CALL INPMSG(I+1,'The pair energy should be > 0.') ELSEIF(INPCMP(I,'R#HO').NE.0.OR. - INPCMP(I,'D#ENSITY').NE.0)THEN CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,RHO,-1.0) GASOK(5)=.TRUE. CLSTYP='LANDAU' IF(RHO.LE.0.0.AND.IFAIL1.EQ.0) - CALL INPMSG(I+1,'The density should be > 0. ') ELSEIF(INPCMP(I,'TR#ANSVERSE-ION-DIFF#USION').NE.0)THEN CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,DIONR,-1.0) IF(DIONR.LT.0.0.AND.IFAIL1.EQ.0)THEN CALL INPMSG(I+1,'The diffusion should be > 0. ') ELSEIF(DIONR.GE.0)THEN DTION=DIONR ENDIF ELSEIF(INPCMP(I,'LONG#ITUDINAL-ION-DIFF#USION').NE.0)THEN CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,DIONR,-1.0) IF(DIONR.LT.0.0.AND.IFAIL1.EQ.0)THEN CALL INPMSG(I+1,'The diffusion should be > 0. ') ELSEIF(DIONR.GE.0)THEN DLION=DIONR ENDIF ELSEIF(INPCMP(I,'ION-DIFF#USION').NE.0)THEN CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,DIONR,-1.0) IF(DIONR.LT.0.0.AND.IFAIL1.EQ.0)THEN CALL INPMSG(I+1,'The diffusion should be > 0. ') ELSEIF(DIONR.GE.0)THEN DTION=DIONR DLION=DIONR ENDIF ELSE CALL INPMSG(I,'The keyword is not known. ') CALL INPMSG(I+1,'See the preceding message. ') ENDIF 500 CONTINUE * Check for an extra keyword. IF(NWORD.EQ.2*INT(REAL(NWORD)/2.0).AND.NWORD.GT.1) - CALL INPMSG(NWORD,'Extra keyword cannot be used. ') CALL INPERR *** If PRESSURE is a keyword, find the pressure. ELSEIF(INPCMP(1,'PR#ESSURE').NE.0)THEN IF(NWORD.EQ.1)THEN CALL OUTFMT(PGAS,2,STRAUX,NCAUX,'LEFT') WRITE(LUNOUT,'('' The pressure of the gas is '', - A,'' Torr.'')') STRAUX(1:NCAUX) ELSEIF(NWORD.EQ.2.OR.NWORD.EQ.3)THEN IF(NWORD.EQ.3)THEN CALL INPSTR(3,3,UNIT,NCUNIT) ELSE UNIT='TORR' NCUNIT=4 ENDIF CALL INPCHK(2,2,IFAIL1) CALL INPRDR(2,PGASRR,760.0) CALL UNITS(PGASRR,UNIT(1:NCUNIT),PGASR,'TORR',IFAIL2) IF(IFAIL2.NE.0)THEN CALL INPMSG(3,'Not a valid pressure unit.') ELSEIF(PGASR.LE.0.0.AND.IFAIL1.EQ.0)THEN CALL INPMSG(2,'The pressure must be positive.') IFAIL1=1 ELSE PGAS=PGASR ENDIF CALL INPERR IF(IFAIL1.NE.0)PRINT *,' !!!!!! GASINP WARNING : The', - ' PRESSURE statement is ignored.' ELSE PRINT *,' !!!!!! GASINP WARNING : PRESSURE takes', - ' a single argument ; excess ignored.' ENDIF *** The RESET instruction. ELSEIF(INPCMP(1,'RES#ET')+INPCMP(1,'DEL#ETE').NE.0)THEN DO 60 I=2,NWORD * Drift velocity. IF(INPCMP(I,'DR#IFT-#VELOCITY').NE.0)THEN GASOK(1)=.FALSE. GASOK(9)=.FALSE. GASOK(10)=.FALSE. IVEXTR=1 JVEXTR=0 IVMETH=2 IXEXTR=1 JXEXTR=0 IXMETH=2 IYEXTR=1 JYEXTR=0 IYMETH=2 * Ion mobility. ELSEIF(INPCMP(I,'ION-MOB#ILITY')+ - INPCMP(I,'MOB#ILITY').NE.0)THEN GASOK(2)=.FALSE. IMEXTR=1 JMEXTR=0 IMMETH=2 * Diffusion. ELSEIF(INPCMP(I,'LONG#ITUDINAL-DIFF#USION').NE.0)THEN GASOK(3)=.FALSE. IDEXTR=1 JDEXTR=0 IDMETH=2 ELSEIF(INPCMP(I,'TRANS#VERSE-DIFF#USION').NE.0)THEN GASOK(8)=.FALSE. IOEXTR=1 JOEXTR=0 IOMETH=2 ELSEIF(INPCMP(I,'DIFF#USION').NE.0)THEN GASOK(8)=.FALSE. IOEXTR=1 JOEXTR=0 IOMETH=2 GASOK(3)=.FALSE. IDEXTR=1 JDEXTR=0 IDMETH=2 * Townsend coefficients. ELSEIF(INPCMP(I,'TOWN#SEND-#COEFFICIENTS').NE.0)THEN GASOK(4)=.FALSE. IAEXTR=1 JAEXTR=0 IAMETH=2 * Clustering data. ELSEIF(INPCMP(I,'CLUST#ERING-#DATA').NE.0)THEN GASOK(5)=.FALSE. HEEDOK=.FALSE. NCLS=0 CLSTYP='NOT SET' FCNCLS=' ' NFCLS=1 A=0 Z=0 EMPROB=0 EPAIR=0 RHO=0 CMEAN=0 * Attachment coefficients. ELSEIF(INPCMP(I,'ATT#ACHMENT-#COEFFICIENTS').NE.0)THEN GASOK(6)=.FALSE. IBEXTR=1 JBEXTR=0 IBMETH=2 * Lorentz angle. ELSEIF(INPCMP(I,'LOR#ENTZ-#ANGLES').NE.0)THEN GASOK(7)=.FALSE. IWEXTR=1 JWEXTR=0 IWMETH=2 * Gas identifier. ELSEIF(INPCMP(I,'GAS-ID#ENTIFIER').NE.0)THEN GASID=' ' * All tables. ELSEIF(INPCMP(I,'TAB#LES').NE.0)THEN NGAS=0 TAB2D=.FALSE. GASOK(1)=.FALSE. GASOK(2)=.FALSE. GASOK(3)=.FALSE. GASOK(4)=.FALSE. GASOK(6)=.FALSE. GASOK(7)=.FALSE. GASOK(8)=.FALSE. GASOK(9)=.FALSE. GASOK(10)=.FALSE. FCNTAB=' ' NFTAB=1 IVEXTR=1 IXEXTR=1 IYEXTR=1 IDEXTR=1 IOEXTR=1 IAEXTR=1 IBEXTR=1 IMEXTR=1 IWEXTR=1 JVEXTR=0 JXEXTR=0 JYEXTR=0 JDEXTR=0 JOEXTR=0 JAEXTR=0 JBEXTR=0 JMEXTR=0 JWEXTR=0 IVMETH=2 IXMETH=2 IYMETH=2 IDMETH=2 IOMETH=2 IAMETH=2 IBMETH=2 IMMETH=2 IWMETH=2 * All the rest is not known. ELSE CALL INPMSG(I,'Is not known, can not be reset') ENDIF 60 CONTINUE * Reset everything. IF(NWORD.EQ.1)CALL GASINT * Dump error messages. CALL INPERR *** Read gas table if TABLE is a keyword. ELSEIF(INPCMP(1,'TAB#LE').NE.0)THEN * Initialize the various pointers: the function data. NFTAB=1 FCNTAB=' ' IFCN=0 * The table data. ITAB=0 IDIFF=0 ITRANS=0 IDRIFT=0 IVB=0 IVEXB=0 IEP=0 ITOWN=0 IATT=0 IMOBIL=0 ILOREN=0 * Table type. TAB2D=.FALSE. * E range. IRANGE=0 EPMIN=100.0/PGAS EPMAX=100000.0/PGAS EPLOG=.TRUE. NGAS=20 * E-B angles. IF(MAGOK)THEN BANGMN=0 BANGMX=PI/2 NBANG=4 ELSE BANGMN=PI/2 BANGMX=PI/2 NBANG=1 ENDIF * B field magnitude. IF(MAGOK)THEN IF(ABS((BFMIN-BFMAX)*BSCALE).LT.0.0001)THEN BTABMN=BFMIN*BSCALE BTABMX=BFMAX*BSCALE NBTAB=1 ELSE BTABMN=BFMIN*BSCALE BTABMX=BFMAX*BSCALE NBTAB=6 ENDIF ELSE BTABMN=0 BTABMX=0 NBTAB=1 ENDIF * Reset the relevant GASOK bits. GASOK(1)=.FALSE. GASOK(2)=.FALSE. GASOK(3)=.FALSE. GASOK(4)=.FALSE. GASOK(6)=.FALSE. GASOK(7)=.FALSE. GASOK(8)=.FALSE. GASOK(9)=.FALSE. GASOK(10)=.FALSE. ** Flag the words. DO 600 I=1,NWORD+3 IF(I.GT.NWORD)THEN FLAG(I)=.TRUE. ELSE IF(INPCMP(I,'E/P')+ - INPCMP(I,'A#TTACHMENT-#COEFFICIENT')+ - INPCMP(I,'DI#FFUSION-#COEFFICIENT')+ - INPCMP(I,'LONG#ITUDINAL-'// - 'DI#FFUSION-#COEFFICIENT')+ - INPCMP(I,'TRANS#VERSE-'// - 'DI#FFUSION-#COEFFICIENT')+ - INPCMP(I,'DUM#MY')+ - INPCMP(I,'DR#IFT-#VELOCITY')+ - INPCMP(I,'E-VEL#OCITY')+ - INPCMP(I,'B#TRANSVERSE-VEL#OCITY')+ - INPCMP(I,'EXB-VEL#OCITY')+ - INPCMP(I,'LOR#ENTZ-#ANGLE')+ - INPCMP(I,'ION-MOB#ILITY')+ - INPCMP(I,'T#OWNSEND-#COEFFICIENT')+ - INPCMP(I,'N-E/P')+INPCMP(I,'E/P-R#ANGE')+ - INPCMP(I,'LIN#EAR-#E/P-#SCALE')+ - INPCMP(I,'LOG#ARITHMIC-#E/P-#SCALE')+ - INPCMP(I,'N-B')+INPCMP(I,'B-R#ANGE')+ - INPCMP(I,'B-F#IELD')+ - INPCMP(I,'N-ANG#LE')+INPCMP(I,'ANG#LE-R#ANGE')+ - INPCMP(I,'ANG#LE').NE.0)THEN FLAG(I)=.TRUE. ELSE FLAG(I)=.FALSE. ENDIF ENDIF 600 CONTINUE ** Read the command string, segment by segment. INEXT=2 OK=.TRUE. DO 610 I=2,NWORD IF(I.LT.INEXT)GOTO 610 * Skip dummy fields. IF(INPCMP(I,'DUM#MY').NE.0)THEN IF(FLAG(I+1))THEN ITAB=ITAB+1 INEXT=I+1 ELSE INEXT=I+2 ENDIF * Check for E/p. ELSEIF(INPCMP(I,'E/P').NE.0)THEN IF(IEP.NE.0)THEN CALL INPMSG(I,'Has already been entered. ') OK=.FALSE. ELSE IF(FLAG(I+1))THEN ITAB=ITAB+1 IEP=ITAB INEXT=I+1 ELSEIF(I.LT.NWORD)THEN CALL INPMSG(I, - 'E/p cannot be a function. ') OK=.FALSE. ENDIF ENDIF * Check for the attachment coefficient. ELSEIF(INPCMP(I,'A#TTACHMENT-#COEFFICIENT').NE.0)THEN IF(IATT.NE.0)THEN CALL INPMSG(I,'Has already been entered. ') OK=.FALSE. ELSE IF(FLAG(I+1))THEN ITAB=ITAB+1 IATT=ITAB ELSEIF(I.LT.NWORD)THEN IFCN=IFCN+1 IATT=-IFCN CALL INPSTR(I+1,I+1,STRING,NC) FCNTAB(NFTAB:NFTAB+NC)=STRING(1:NC)//',' NFTAB=NFTAB+NC+1 INEXT=I+2 ENDIF GASOK(6)=.TRUE. ENDIF * Check for a longitudinal diffusion coefficient. ELSEIF(INPCMP(I,'DI#FFUSION-#COEFFICIENT')+ - INPCMP(I,'LONG#ITUDINAL-'// - 'DI#FFUSION-#COEFFICIENT').NE.0)THEN IF(IDIFF.NE.0)THEN CALL INPMSG(I,'Has already been entered. ') OK=.FALSE. ELSE IF(FLAG(I+1))THEN ITAB=ITAB+1 IDIFF=ITAB ELSEIF(I+1.LE.NWORD)THEN IFCN=IFCN+1 IDIFF=-IFCN CALL INPSTR(I+1,I+1,STRING,NC) FCNTAB(NFTAB:NFTAB+NC)=STRING(1:NC)//',' NFTAB=NFTAB+NC+1 INEXT=I+2 ENDIF GASOK(3)=.TRUE. ENDIF * Check for a transverse diffusion coefficient. ELSEIF(INPCMP(I,'TRANS#VERSE-'// - 'DI#FFUSION-#COEFFICIENT').NE.0)THEN IF(ITRANS.NE.0)THEN CALL INPMSG(I,'Has already been entered. ') OK=.FALSE. ELSE IF(FLAG(I+1))THEN ITAB=ITAB+1 ITRANS=ITAB ELSEIF(I+1.LE.NWORD)THEN IFCN=IFCN+1 ITRANS=-IFCN CALL INPSTR(I+1,I+1,STRING,NC) FCNTAB(NFTAB:NFTAB+NC)=STRING(1:NC)//',' NFTAB=NFTAB+NC+1 INEXT=I+2 ENDIF GASOK(8)=.TRUE. ENDIF * Check for a drift velocity terms. ELSEIF(INPCMP(I,'DR#IFT-#VELOCITY')+ - INPCMP(I,'E-VEL#OCITY').NE.0)THEN IF(IDRIFT.NE.0)THEN CALL INPMSG(I,'Has already been entered. ') OK=.FALSE. ELSE IF(FLAG(I+1))THEN ITAB=ITAB+1 IDRIFT=ITAB ELSEIF(I.LT.NWORD)THEN IFCN=IFCN+1 IDRIFT=-IFCN CALL INPSTR(I+1,I+1,STRING,NC) FCNTAB(NFTAB:NFTAB+NC)=STRING(1:NC)//',' NFTAB=NFTAB+NC+1 INEXT=I+2 ENDIF GASOK(1)=.TRUE. ENDIF ELSEIF(INPCMP(I,'B#TRANSVERSE-VEL#OCITY')+ - INPCMP(I,'B#TRANSVERSAL-VEL#OCITY').NE.0)THEN IF(.NOT.MAGOK)THEN CALL INPMSG(I,'There is no magnetic field.') OK=.FALSE. ELSEIF(IVB.NE.0)THEN CALL INPMSG(I,'Has already been entered. ') OK=.FALSE. ELSE IF(FLAG(I+1))THEN ITAB=ITAB+1 IVB=ITAB ELSEIF(I.LT.NWORD)THEN IFCN=IFCN+1 IVB=-IFCN CALL INPSTR(I+1,I+1,STRING,NC) FCNTAB(NFTAB:NFTAB+NC)=STRING(1:NC)//',' NFTAB=NFTAB+NC+1 INEXT=I+2 ENDIF GASOK(9)=.TRUE. ENDIF ELSEIF(INPCMP(I,'EXB-VEL#OCITY').NE.0)THEN IF(.NOT.MAGOK)THEN CALL INPMSG(I,'There is no magnetic field.') OK=.FALSE. ELSEIF(IVEXB.NE.0)THEN CALL INPMSG(I,'Has already been entered. ') OK=.FALSE. ELSE IF(FLAG(I+1))THEN ITAB=ITAB+1 IVEXB=ITAB ELSEIF(I.LT.NWORD)THEN IFCN=IFCN+1 IVEXB=-IFCN CALL INPSTR(I+1,I+1,STRING,NC) FCNTAB(NFTAB:NFTAB+NC)=STRING(1:NC)//',' NFTAB=NFTAB+NC+1 INEXT=I+2 ENDIF GASOK(10)=.TRUE. ENDIF * Check for the Lorentz angle. ELSEIF(INPCMP(I,'LOR#ENTZ-#ANGLE').NE.0)THEN IF(.NOT.MAGOK)THEN CALL INPMSG(I,'There is no magnetic field.') OK=.FALSE. ELSEIF(ILOREN.NE.0)THEN CALL INPMSG(I,'Has already been entered.') OK=.FALSE. ELSE IF(FLAG(I+1))THEN ITAB=ITAB+1 ILOREN=ITAB ELSEIF(I.LT.NWORD)THEN IFCN=IFCN+1 ILOREN=-IFCN CALL INPSTR(I+1,I+1,STRING,NC) FCNTAB(NFTAB:NFTAB+NC)=STRING(1:NC)//',' NFTAB=NFTAB+NC+1 INEXT=I+2 ENDIF GASOK(7)=.TRUE. ENDIF * Check for the mobility. ELSEIF(INPCMP(I,'ION-MOB#ILITY').NE.0)THEN IF(IMOBIL.NE.0)THEN CALL INPMSG(I,'Has already been entered. ') OK=.FALSE. ELSE IF(FLAG(I+1))THEN ITAB=ITAB+1 IMOBIL=ITAB ELSEIF(I.LT.NWORD)THEN IFCN=IFCN+1 IMOBIL=-IFCN CALL INPSTR(I+1,I+1,STRING,NC) FCNTAB(NFTAB:NFTAB+NC)=STRING(1:NC)//',' NFTAB=NFTAB+NC+1 INEXT=I+2 ENDIF GASOK(2)=.TRUE. ENDIF * Check for the Townsend coefficient. ELSEIF(INPCMP(I,'T#OWNSEND-#COEFFICIENT').NE.0)THEN IF(ITOWN.NE.0)THEN CALL INPMSG(I,'Has already been entered. ') OK=.FALSE. ELSE IF(FLAG(I+1))THEN ITAB=ITAB+1 ITOWN=ITAB ELSEIF(I.LT.NWORD)THEN IFCN=IFCN+1 ITOWN=-IFCN CALL INPSTR(I+1,I+1,STRING,NC) FCNTAB(NFTAB:NFTAB+NC)=STRING(1:NC)//',' NFTAB=NFTAB+NC+1 INEXT=I+2 ENDIF GASOK(4)=.TRUE. ENDIF * Look for the E/P-RANGE parameter. ELSEIF(INPCMP(I,'E/P-R#ANGE').NE.0)THEN IF(FLAG(I+1))THEN CALL INPMSG(I,'RANGE should have 2 arguments.') OK=.FALSE. INEXT=I+1 ELSEIF(.NOT.FLAG(I+1).AND.FLAG(I+2))THEN CALL INPMSG(I,'RANGE should have 2 arguments.') CALL INPMSG(I+1,'See the previous message. ') INEXT=I+2 OK=.FALSE. ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPCHK(I+2,2,IFAIL2) CALL INPRDR(I+1,EPMINR,0.1) CALL INPRDR(I+2,EPMAXR,100.0) IF(IFAIL1.EQ.0.AND.EPMINR.LE.0.0)THEN CALL INPMSG(I+1, - 'The minimum E/P should be > 0.') OK=.FALSE. ELSEIF(IFAIL2.EQ.0.AND.EPMAXR.LE.0.0)THEN CALL INPMSG(I+1, - 'The maximum E/P should be > 0.') OK=.FALSE. ELSE IF(EPMINR.EQ.EPMAXR)THEN CALL INPMSG(I+1, - 'A zero range not is permitted.') CALL INPMSG(I+2, - 'A zero range not is permitted.') OK=.FALSE. ELSE EPMIN=MIN(EPMINR,EPMAXR) EPMAX=MAX(EPMINR,EPMAXR) IRANGE=1 ENDIF ENDIF INEXT=I+3 ENDIF * Look for the N-E/P parameter. ELSEIF(INPCMP(I,'N-E/P').NE.0)THEN IF(FLAG(I+1))THEN CALL INPMSG(I,'N should have one argument. ') INEXT=I+1 OK=.FALSE. ELSE CALL INPCHK(I+1,1,IFAIL1) CALL INPRDI(I+1,NGASR,20) IF(IFAIL1.EQ.0.AND.NGASR.LE.1)THEN CALL INPMSG(I+1, - 'Number of gas points is < 2. ') OK=.FALSE. ELSEIF(IFAIL1.EQ.0.AND.NGASR.GT.MXLIST)THEN CALL INPMSG(I+1, - 'Number of gas points > MXLIST.') OK=.FALSE. ELSEIF(IFAIL1.EQ.0)THEN NGAS=NGASR IRANGE=1 ENDIF INEXT=I+2 ENDIF * Kind of E/p scale. ELSEIF(INPCMP(I,'LIN#EAR-#E/P-#SCALE').NE.0)THEN EPLOG=.FALSE. ELSEIF(INPCMP(I,'LOG#ARITHMIC-#E/P-#SCALE').NE.0)THEN EPLOG=.TRUE. * Look for the B-RANGE parameter. ELSEIF(INPCMP(I,'B-R#ANGE').NE.0)THEN IF(FLAG(I+1))THEN CALL INPMSG(I,'RANGE should have 2 arguments.') INEXT=I+1 OK=.FALSE. ELSEIF(.NOT.FLAG(I+1).AND.FLAG(I+2))THEN CALL INPMSG(I,'RANGE should have 2 arguments.') CALL INPMSG(I+1,'See the previous message. ') INEXT=I+2 OK=.FALSE. ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPCHK(I+2,2,IFAIL2) CALL INPRDR(I+1,BTMINR,BTABMN/100) CALL INPRDR(I+2,BTMAXR,BTABMX/100) IF(IFAIL1.EQ.0.AND.BTMINR.LE.0.0)THEN CALL INPMSG(I+1, - 'The minimum B should be > 0.') OK=.FALSE. ELSEIF(IFAIL2.EQ.0.AND.BTMAXR.LE.0.0)THEN CALL INPMSG(I+1, - 'The maximum B should be > 0.') OK=.FALSE. ELSE IF(BTMINR.EQ.BTMAXR)THEN CALL INPMSG(I+1, - 'A zero range not is permitted.') CALL INPMSG(I+2, - 'A zero range not is permitted.') OK=.FALSE. ELSE BTABMN=100*MIN(BTMINR,BTMAXR) BTABMX=100*MAX(BTMINR,BTMAXR) TAB2D=.TRUE. ENDIF ENDIF INEXT=I+3 ENDIF * Look for the N-B parameter. ELSEIF(INPCMP(I,'N-B').NE.0)THEN IF(FLAG(I+1))THEN CALL INPMSG(I,'N should have one argument. ') INEXT=I+1 OK=.FALSE. ELSE CALL INPCHK(I+1,1,IFAIL1) CALL INPRDI(I+1,NBTABR,NBTAB) IF(IFAIL1.EQ.0.AND.NBTABR.LE.1)THEN CALL INPMSG(I+1, - 'Number of B fields is < 2. ') OK=.FALSE. ELSEIF(IFAIL1.EQ.0.AND.NBTABR.GT.MXBTAB)THEN CALL INPMSG(I+1, - 'Number of B fields > MXBTAB.') OK=.FALSE. ELSEIF(IFAIL1.EQ.0)THEN NBTAB=NBTABR TAB2D=.TRUE. ENDIF INEXT=I+2 ENDIF * Look for the B-field keyword. ELSEIF(INPCMP(I,'B-F#IELD').NE.0)THEN CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,BTMINR,(BTABMN+BTABMX)/200) IF(IFAIL1.EQ.0.AND.NWORD.GE.I+1)THEN IF(BTMINR.LT.0)THEN CALL INPMSG(I+1,'B field is not > 0.') OK=.FALSE. ELSE BTABMN=100*BTMINR BTABMX=100*BTMINR NBTAB=1 TAB2D=.TRUE. ENDIF ELSE CALL INPMSG(I,'Missing or invalid arguments. ') OK=.FALSE. ENDIF INEXT=I+2 * Look for the ANGLE-RANGE parameter. ELSEIF(INPCMP(I,'ANG#LE-R#ANGE').NE.0)THEN IF(FLAG(I+1))THEN CALL INPMSG(I,'RANGE should have 2 arguments.') INEXT=I+1 OK=.FALSE. ELSEIF(.NOT.FLAG(I+1).AND.FLAG(I+2))THEN CALL INPMSG(I,'RANGE should have 2 arguments.') CALL INPMSG(I+1,'See the previous message. ') INEXT=I+2 OK=.FALSE. ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPCHK(I+2,2,IFAIL2) CALL INPRDR(I+1,BAMINR,180*BANGMN/PI) CALL INPRDR(I+2,BAMAXR,180*BANGMX/PI) IF(IFAIL1.EQ.0.AND. - (BAMINR.LT.0.OR.BAMINR.GT.90.0))THEN CALL INPMSG(I+1, - 'Min angle not in range [0,90].') OK=.FALSE. ELSEIF(IFAIL2.EQ.0.AND. - (BAMAXR.LT.0.OR.BAMAXR.GT.90.0))THEN CALL INPMSG(I+1, - 'Max angle not in range [0,90].') OK=.FALSE. ELSE IF(BAMINR.EQ.BAMAXR)THEN CALL INPMSG(I+1, - 'A zero range not is permitted.') CALL INPMSG(I+2, - 'A zero range not is permitted.') OK=.FALSE. ELSE BANGMN=PI*MIN(BAMINR,BAMAXR)/180 BANGMX=PI*MAX(BAMINR,BAMAXR)/180 TAB2D=.TRUE. ENDIF ENDIF INEXT=I+3 ENDIF * Look for the N-ANGLE parameter. ELSEIF(INPCMP(I,'N-ANG#LE').NE.0)THEN IF(FLAG(I+1))THEN CALL INPMSG(I,'N should have one argument. ') INEXT=I+1 OK=.FALSE. ELSE CALL INPCHK(I+1,1,IFAIL1) CALL INPRDI(I+1,NBANGR,NBANG) IF(IFAIL1.EQ.0.AND.NBANGR.LE.1)THEN CALL INPMSG(I+1, - 'Number of angles is < 2. ') OK=.FALSE. ELSEIF(IFAIL1.EQ.0.AND.NBANGR.GT.MXBANG)THEN CALL INPMSG(I+1, - 'Number of angles > MXBANG.') OK=.FALSE. ELSEIF(IFAIL1.EQ.0)THEN NBANG=NBANGR TAB2D=.TRUE. ENDIF INEXT=I+2 ENDIF * Look for the ANGLE keyword. ELSEIF(INPCMP(I,'ANG#LE').NE.0)THEN CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,BAMINR,180*BANGMN/PI) IF(IFAIL1.EQ.0.AND.NWORD.GE.I+1)THEN IF(BAMINR.LT.0.OR.BAMINR.GT.90.0)THEN CALL INPMSG(I+1,'Out of range [0,90].') OK=.FALSE. ELSE BANGMN=PI*BAMINR/180 BANGMX=PI*BAMINR/180 NBANG=1 TAB2D=.TRUE. ENDIF ELSE CALL INPMSG(I,'Missing or invalid arguments. ') OK=.FALSE. ENDIF INEXT=I+2 * Unknown entry. ELSE CALL INPMSG(I,'Unknown table entry, ignored. ') ITAB=ITAB+1 OK=.FALSE. INEXT=I+1 ENDIF * Next entry. 610 CONTINUE ** Dump the error messages. CALL INPERR * Check for B dependence in table. IF(TAB2D.AND..NOT.MAGOK)THEN PRINT *,' !!!!!! GASINP WARNING : The table has'// - ' a B dependence, but there is no B field;'// - ' dependence reset.' TAB2D=.FALSE. OK=.FALSE. ENDIF ** Check whether we have to continue or not. IF(JFAIL.EQ.2.AND..NOT.OK)THEN PRINT *,' ###### GASINP ERROR : TABLE not'// - ' executed because of the above errors.' NGAS=0 GOTO 10 ELSEIF(JFAIL.EQ.3.AND..NOT.OK)THEN PRINT *,' ###### GASINP ERROR : Program terminated'// - ' because of the above errors.' NGAS=0 CALL QUIT RETURN ENDIF ** Preset the OK flag again for the data processing. OK=.TRUE. ** Take care of defaults: no arguments provided. IF(ITAB.EQ.0.AND.IFCN.EQ.0)THEN IEP=1 IDRIFT=2 IVB=0 IVEXB=0 IDIFF=3 ITOWN=0 IATT=0 IMOBIL=0 ILOREN=0 ITRANS=0 ITAB=3 GASOK(1)=.TRUE. GASOK(2)=.FALSE. GASOK(3)=.TRUE. GASOK(4)=.FALSE. GASOK(6)=.FALSE. GASOK(7)=.FALSE. GASOK(8)=.FALSE. GASOK(9)=.FALSE. GASOK(10)=.FALSE. ENDIF * Table will follow: preset NGAS to 0. IF(ITAB.NE.0)NGAS=0 * If there have not been any B or angle declarations, reset N. IF(.NOT.TAB2D)THEN NBTAB=1 NBANG=1 ENDIF ** Warn if a RANGE or an N has been specified when not needed. IF(IRANGE.NE.0.AND.(IEP.GT.0.OR. - IDRIFT.GT.0.OR.IVB.GT.0.OR.IVEXB.GT.0.OR. - IDIFF.GT.0.OR.ITOWN.GT.0.OR.IATT.GT.0.OR. - IMOBIL.GT.0.OR.ILOREN.GT.0.OR.ITRANS.GT.0))THEN PRINT *,' !!!!!! GASINP WARNING : RANGE and N'// - ' ignored because a table is expected.' OK=.FALSE. ENDIF ** Generate some debugging output. IF(LDEBUG)THEN WRITE(LUNOUT,'('' ++++++ GASINP DEBUG : TABLE '', - ''debug output:''/26X,''Function: "'',A,''"''/26X, - ''IEP='',I2,'', IDRIFT='',I2,'', IVB='',I2, - '', IVEXB='',I2,'', IDIFF='',I2, - '', ITOWN='',I2,'', IATT='',I2,'', IMOBIL='',I2, - '', ILOREN='',I2,'', ITRANS='',I2)') - FCNTAB(1:MAX(1,NFTAB-2)), - IEP,IDRIFT,IVB,IVEXB,IDIFF,ITOWN,IATT, - IMOBIL,ILOREN,ITRANS WRITE(LUNOUT,'(26X,''EPMIN='',E10.3,'', EPMAX='',E10.3, - '', NGAS='',I3)') EPMIN,EPMAX,NGAS ENDIF ** Check whether a function has been specified somewhere. IENTRY=0 IF(IDRIFT.LT.0.OR.IVB.LT.0.OR.IVEXB.LT.0.OR. - IDIFF.LT.0.OR.ITRANS.LT.0.OR.ITOWN.LT.0.OR. - IATT.LT.0.OR.IMOBIL.LT.0.OR.ILOREN.LT.0)THEN * Check for the presence of a function. IF(NFTAB.LE.2)THEN PRINT *,' !!!!!! GASINP WARNING : The function'// - ' seems to be empty; rejected.' NGAS=0 GOTO 10 ENDIF * Remove the comma at the end of the string. FCNTAB(NFTAB-1:NFTAB-1)=' ' NFTAB=NFTAB-2 * Convert the string to an instruction list (via ALGEDT if @ appears). IF(INDEX(FCNTAB(1:NFTAB),'@').NE.0)THEN NRES=IFCN CALL ALGEDT(VARTAB,7,IENTRY,USE,NRES) ELSE CALL ALGPRE(FCNTAB,NFTAB,VARTAB,7,NRES,USE,IENTRY, - IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! GASINP WARNING : Entries'// - ' specified as functions are ignored:' IF(IDRIFT.LT.0)PRINT *,' '// - ' the drift velocity || E' IF(IVB.LT.0)PRINT *,' '// - ' the drift velocity || Btrans' IF(IVEXB.LT.0)PRINT *,' '// - ' the drift velocity || ExB' IF(ILOREN.LT.0)PRINT *,' '// - ' the Lorentz angle' IF(IDIFF.LT.0)PRINT *,' '// - ' the longitudinal diffusion' IF(ITRANS.LT.0)PRINT *,' '// - ' the transverse diffusion' IF(ITOWN.LT.0)PRINT *,' '// - ' the Townsend coefficient' IF(IATT.LT.0)PRINT *,' '// - ' the attachment coefficient' IF(IMOBIL.LT.0)PRINT *,' '// - ' the ion mobility' NGAS=0 CALL ALGCLR(IENTRY) GOTO 10 ENDIF ENDIF IF(NRES.NE.IFCN)THEN PRINT *,' !!!!!! GASINP WARNING : Number'// - ' of functions being returned is wrong.' NGAS=0 CALL ALGCLR(IENTRY) GOTO 10 ENDIF * Warn if the function does not depend explicitely on EP. IF(.NOT.USE(1))PRINT *,' ------ GASINP MESSAGE : The'// - ' function is independent of E/p, but accepted.' * Ensure the function does not depend on B or angle if 1D. IF((.NOT.TAB2D).AND.(USE(4).OR.USE(5)))THEN PRINT *,' !!!!!! GASINP WARNING : The function'// - ' depends on B or angle(E,B) but the table'// - ' has no B part; rejected.' NGAS=0 CALL ALGCLR(IENTRY) GOTO 10 ENDIF ENDIF ** Read the cards if at least one item has been tabulated. IF(IDRIFT.GT.0.OR.IVB.GT.0.OR.IVEXB.GT.0.OR. - IDIFF.GT.0.OR.ITRANS.GT.0.OR.IMOBIL.GT.0.OR. - ITOWN.GT.0.OR.IATT.GT.0.OR.ILOREN.GT.0.OR. - IEP.GT.0)THEN * Check that E/p has been specified. IF(IEP.EQ.0)THEN PRINT *,' !!!!!! GASINP WARNING : E/p has to be'// - ' present in the table; table rejected.' NGAS=0 IF(IENTRY.NE.0)CALL ALGCLR(IENTRY) GOTO 10 ENDIF * Prompt in interactive mode. NGAS=0 IF(STDSTR('INPUT')) - PRINT *,' ====== GASINP INPUT :'// - ' Please enter the table, enter a'// - ' blank line when ready.' CALL INPPRM('Table','ADD-NOPRINT') * And start an input loop. 620 CONTINUE CALL INPWRD(NWORD) IF(NWORD.EQ.0)GOTO 660 CALL INPSTR(1,1,STRING,NC) * Take appropriate action if a & is met. IF(STRING(1:1).EQ.'&')THEN PRINT *,' !!!!!! GASINP WARNING : You can not'// - ' leave the section here ; line is ignored.' GOTO 620 ENDIF * Make sure each line contains the right number of items. IF(NWORD.NE.ITAB)THEN PRINT *,' !!!!!! GASINP WARNING : Gas tables'// - ' must contain the number of items listed'// - ' in the TABLE line.' GOTO 620 ENDIF * Preset error flag. IFAIL1=0 * Read the items and check their syntax + validity. NGAS=NGAS+1 DO 630 I=1,ITAB CALL INPCHK(I,2,IFAIL2) IF(IFAIL2.NE.0)IFAIL1=1 CALL INPRDR(I,DATAR,-1.0) DO 631 J=1,NBANG DO 632 K=1,NBTAB IF(NGAS.LE.MXLIST.AND.IFAIL2.EQ.0)THEN IF(I.EQ.IEP)THEN EGAS(NGAS)=DATAR ELSEIF(I.EQ.IDRIFT)THEN VGAS(NGAS)=DATAR VGAS2(NGAS,J,K)=DATAR ELSEIF(I.EQ.IVB)THEN XGAS(NGAS)=DATAR XGAS2(NGAS,J,K)=DATAR ELSEIF(I.EQ.IVEXB)THEN YGAS(NGAS)=DATAR YGAS2(NGAS,J,K)=DATAR ELSEIF(I.EQ.ILOREN)THEN IF(DATAR.LT.0.OR.DATAR.GT.90.0)THEN PRINT *,' !!!!!! GASINP WARNING :'// - ' Lorentz angle outside the'// - ' range [0,90] degrees.' IFAIL1=1 WGAS(NGAS)=0 ELSE WGAS(NGAS)=PI*DATAR/180.0 ENDIF WGAS2(NGAS,J,K)=WGAS(NGAS) ELSEIF(I.EQ.IDIFF)THEN DGAS(NGAS)=DATAR DGAS2(NGAS,J,K)=DATAR ELSEIF(I.EQ.ITRANS)THEN OGAS(NGAS)=DATAR OGAS2(NGAS,J,K)=DATAR ELSEIF(I.EQ.ITOWN)THEN IF(DATAR.EQ.0)THEN AGAS(NGAS)=-30 ELSEIF(DATAR.GT.0)THEN AGAS(NGAS)=MAX(-30.0,LOG(DATAR)) ELSE PRINT *,' !!!!!! GASINP WARNING :'// - ' Townsend coefficient < 0;'// - ' data rejected.' IFAIL1=1 AGAS(NGAS)=-30.0 ENDIF AGAS2(NGAS,J,K)=AGAS(NGAS) ELSEIF(I.EQ.IATT)THEN IF(DATAR.EQ.0)THEN BGAS(NGAS)=-30 ELSEIF(DATAR.GT.0)THEN BGAS(NGAS)=MAX(-30.0,LOG(DATAR)) ELSE PRINT *,' !!!!!! GASINP WARNING :'// - ' Attachment coefficient < 0;'// - ' data rejected.' IFAIL1=1 BGAS(NGAS)=-30.0 ENDIF BGAS2(NGAS,J,K)=BGAS(NGAS) ELSEIF(I.EQ.IMOBIL)THEN MGAS(NGAS)=DATAR MGAS2(NGAS,J,K)=DATAR ENDIF ENDIF 632 CONTINUE 631 CONTINUE 630 CONTINUE * Evaluate the function value, if needed. IF(IDRIFT.LT.0.OR.IVB.LT.0.OR.IVEXB.LT.0.OR. - IDIFF.LT.0.OR.ITRANS.LT.0.OR.ILOREN.LT.0.OR. - ITOWN.LT.0.OR.IATT.LT.0.OR.IMOBIL.LT.0)THEN DO 641 J=1,NBANG IF(NBANG.GT.1)THEN BANG(J)=BANGMN+REAL(J-1)*(BANGMX-BANGMN)/ - REAL(NBANG-1) ELSE BANG(J)=(BANGMN+BANGMX)/2 ENDIF DO 642 K=1,NBTAB IF(NBTAB.GT.1)THEN BTAB(K)=BTABMN+REAL(K-1)*(BTABMX-BTABMN)/ - REAL(NBTAB-1) ELSE BTAB(K)=(BTABMN+BTABMX)/2 ENDIF VAR(1)=EGAS(NGAS) VAR(2)=BOLTZ VAR(3)=ECHARG VAR(4)=180*BANG(J)/PI VAR(5)=BTAB(K)/100 VAR(6)=TGAS VAR(7)=PGAS MODVAR(1)=2 MODVAR(2)=2 MODVAR(3)=2 MODVAR(4)=2 MODVAR(5)=2 MODVAR(6)=2 MODVAR(7)=2 CALL ALGEXE(IENTRY,VAR,MODVAR,7, - RES,MODRES,NRES,IFAIL2) IF(IFAIL2.NE.0)THEN PRINT *,' !!!!!! GASINP WARNING : Error'// - ' evaluating the function.' IFAIL1=1 ENDIF DO 640 I=1,IFCN IF(MODRES(I).NE.2)THEN PRINT *,' !!!!!! GASINP WARNING : Function'// - ' does not return a number.' IFAIL1=1 RES(I)=0 ENDIF IF(I.EQ.-IDRIFT)THEN VGAS(NGAS)=RES(I) VGAS2(NGAS,J,K)=RES(I) ELSEIF(I.EQ.-IVB)THEN XGAS(NGAS)=RES(I) XGAS2(NGAS,J,K)=RES(I) ELSEIF(I.EQ.-IVEXB)THEN YGAS(NGAS)=RES(I) YGAS2(NGAS,J,K)=RES(I) ELSEIF(I.EQ.-ILOREN)THEN IF(RES(I).LT.0.OR.RES(I).GT.90.0)THEN PRINT *,' !!!!!! GASINP WARNING :'// - ' Lorentz angle outside the'// - ' range [0,90] degrees.' IFAIL1=1 WGAS(NGAS)=0 ELSE WGAS(NGAS)=PI*RES(I)/180.0 ENDIF WGAS2(NGAS,J,K)=WGAS(NGAS) ELSEIF(I.EQ.-IDIFF)THEN DGAS(NGAS)=RES(I) DGAS2(NGAS,J,K)=RES(I) ELSEIF(I.EQ.-ITRANS)THEN OGAS(NGAS)=RES(I) OGAS2(NGAS,J,K)=RES(I) ELSEIF(I.EQ.-ITOWN)THEN IF(RES(I).EQ.0)THEN AGAS(NGAS)=-30.0 ELSEIF(RES(I).GT.0)THEN AGAS(NGAS)=MAX(-30.0,LOG(RES(I))) ELSE AGAS(NGAS)=-30.0 PRINT *,' !!!!!! GASINP WARNING :'// - ' Townsend coefficient < 0;'// - ' data rejected.' IFAIL1=1 ENDIF AGAS2(NGAS,J,K)=AGAS(NGAS) ELSEIF(I.EQ.-IATT)THEN IF(RES(I).EQ.0)THEN BGAS(NGAS)=-30.0 ELSEIF(RES(I).GT.0)THEN BGAS(NGAS)=MAX(-30.0,LOG(RES(I))) ELSE BGAS(NGAS)=-30.0 PRINT *,' !!!!!! GASINP WARNING :'// - ' Attachment coefficient < 0;'// - ' data rejected.' IFAIL1=1 ENDIF BGAS2(NGAS,J,K)=BGAS(NGAS) ELSEIF(I.EQ.-IMOBIL)THEN MGAS(NGAS)=RES(I) MGAS2(NGAS,J,K)=RES(I) ENDIF 640 CONTINUE 642 CONTINUE 641 CONTINUE ENDIF * Dump error messages. CALL INPERR IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! GASINP WARNING : The input'// - ' line is ignored, see preceding message.' NGAS=NGAS-1 OK=.FALSE. ENDIF * Proceed with the next line. GOTO 620 ** End of list, carry out a few checks. 660 CONTINUE * Reset the prompt. CALL INPPRM(' ','BACK-PRINT') * Warn if the table was empty. IF(NGAS.LE.2)PRINT *,' !!!!!! GASINP WARNING : The'// - ' gas table did not contain enough points (> 2).' * Warn if parts of the table were omitted for lack of storage space. IF(NGAS.GT.MXLIST)THEN PRINT *,' !!!!!! GASINP WARNING : ',NGAS-MXLIST, - ' data points could not be stored ; you'// - ' could increase the MXLIST parameter.' NGAS=MXLIST OK=.FALSE. ENDIF ** If the table is presented as a pure function: ELSEIF(IDRIFT.LT.0.OR.IVB.LT.0.OR.IVEXB.LT.0.OR. - IDIFF.LT.0.OR.ITRANS.LT.0.OR.ILOREN.LT.0.OR. - ITOWN.LT.0.OR.IATT.LT.0.OR.IMOBIL.LT.0)THEN * Make the table using the function. NNGAS=NGAS DO 680 I=1,NNGAS * Preset the error flag for this E/p. IFAIL1=0 * Set E/p. IF(EPLOG)THEN EGAS(I)=EPMIN*(EPMAX/EPMIN)** - (REAL(I-1)/REAL(NGAS-1)) ELSE EGAS(I)=EPMIN+(EPMAX-EPMIN)* - (REAL(I-1)/REAL(NGAS-1)) ENDIF * Loop over angles and B field. DO 681 J=1,NBANG IF(NBANG.GT.1)THEN BANG(J)=BANGMN+REAL(J-1)*(BANGMX-BANGMN)/ - REAL(NBANG-1) ELSE BANG(J)=(BANGMN+BANGMX)/2 ENDIF DO 682 K=1,NBTAB IF(NBTAB.GT.1)THEN BTAB(K)=BTABMN+REAL(K-1)*(BTABMX-BTABMN)/ - REAL(NBTAB-1) ELSE BTAB(K)=(BTABMN+BTABMX)/2 ENDIF * Evaluate the functions. VAR(1)=EGAS(I) VAR(2)=BOLTZ VAR(3)=ECHARG VAR(4)=180*BANG(J)/PI VAR(5)=BTAB(K)/100 VAR(6)=TGAS VAR(7)=PGAS MODVAR(1)=2 MODVAR(2)=2 MODVAR(3)=2 MODVAR(4)=2 MODVAR(5)=2 MODVAR(6)=2 MODVAR(7)=2 CALL ALGEXE(IENTRY,VAR,MODVAR,7,RES,MODRES,NRES,IFAIL2) IF(IFAIL2.NE.0)THEN PRINT *,' !!!!!! GASINP WARNING : Arithmetic'// - ' error evaluating the function at E/p=', - EGAS(I) IFAIL1=1 ENDIF * Assign the results. DO 670 II=1,IFCN IF(MODRES(II).NE.2)THEN PRINT *,' !!!!!! GASINP WARNING : Function does'// - ' not return a number for E/p=',EGAS(I) IFAIL1=1 RES(II)=0 ENDIF IF(II.EQ.-IDRIFT)THEN VGAS(I)=RES(II) VGAS2(I,J,K)=RES(II) ELSEIF(II.EQ.-IVB)THEN XGAS(I)=RES(II) XGAS2(I,J,K)=RES(II) ELSEIF(II.EQ.-IVEXB)THEN YGAS(I)=RES(II) YGAS2(I,J,K)=RES(II) ELSEIF(II.EQ.-ILOREN)THEN IF(RES(II).LT.0.OR.RES(II).GT.90.0)THEN PRINT *,' !!!!!! GASINP WARNING : Lorentz'// - ' angle outside the range [0,90]'// - ' degrees for E/p=',EGAS(I) IFAIL1=1 WGAS(I)=0 ELSE WGAS(I)=PI*RES(II)/180.0 ENDIF WGAS2(I,J,K)=WGAS(I) ELSEIF(II.EQ.-IDIFF)THEN DGAS(I)=RES(II) DGAS2(I,J,K)=RES(II) ELSEIF(II.EQ.-ITRANS)THEN OGAS(I)=RES(II) OGAS2(I,J,K)=RES(II) ELSEIF(II.EQ.-ITOWN)THEN IF(RES(II).EQ.0)THEN AGAS(I)=-30.0 ELSEIF(RES(II).GT.0)THEN AGAS(I)=MAX(-30.0,LOG(RES(II))) ELSE AGAS(I)=-30.0 PRINT *,' !!!!!! GASINP WARNING : Townsend'// - ' coefficient < 0 for E/p=',EGAS(I) IFAIL1=1 ENDIF AGAS2(I,J,K)=AGAS(I) ELSEIF(II.EQ.-IATT)THEN IF(RES(II).EQ.0)THEN BGAS(I)=-30.0 ELSEIF(RES(II).GT.0)THEN BGAS(I)=MAX(-30.0,LOG(RES(II))) ELSE BGAS(I)=-30.0 PRINT *,' !!!!!! GASINP WARNING :'// - ' Attachment coefficient < 0 for'// - ' E/p=',EGAS(I) IFAIL1=1 ENDIF BGAS2(I,J,K)=BGAS(I) ELSEIF(II.EQ.-IMOBIL)THEN MGAS(I)=RES(II) MGAS2(I,J,K)=RES(II) ENDIF 670 CONTINUE * Next angle and B field. 682 CONTINUE 681 CONTINUE * Check the errors for this E/p. IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! GASINP WARNING : The data'// - ' for E/p=',EGAS(I),' is ignored, see'// - ' preceding message.' NGAS=NGAS-1 OK=.FALSE. ENDIF * Next E/p. 680 CONTINUE ENDIF ** Release the algebra entry point, if used. IF(IENTRY.NE.0)CALL ALGCLR(IENTRY) ** Check whether we have to continue or not. IF(JFAIL.EQ.2.AND..NOT.OK)THEN PRINT *,' ###### GASINP ERROR : TABLE is'// - ' rejected because of the above errors.' NGAS=0 GOTO 10 ELSEIF(JFAIL.EQ.3.AND..NOT.OK)THEN PRINT *,' ###### GASINP ERROR : Program terminated'// - ' because of the above errors.' NGAS=0 CALL QUIT RETURN ENDIF *** If TEMPERATURE is a keyword, find the temperature. ELSEIF(INPCMP(1,'TEMP#ERATURE').NE.0)THEN IF(NWORD.EQ.1)THEN CALL OUTFMT(TGAS,2,STRAUX,NCAUX,'LEFT') WRITE(LUNOUT,'('' The temperature of the gas is '', - A,'' K.'')') STRAUX(1:NCAUX) ELSEIF(NWORD.EQ.2.OR.NWORD.EQ.3)THEN IF(NWORD.EQ.3)THEN CALL INPSTR(3,3,UNIT,NCUNIT) ELSE UNIT='K' NCUNIT=1 ENDIF CALL INPCHK(2,2,IFAIL1) CALL INPRDR(2,TGASRR,300.0) CALL UNITS(TGASRR,UNIT(1:NCUNIT),TGASR,'K',IFAIL2) IF(IFAIL2.NE.0)THEN CALL INPMSG(3,'Not a valid temperature unit.') ELSEIF(TGASR.LE.0.0.AND.IFAIL1.EQ.0)THEN CALL INPMSG(2,'The temperature is not > 0 K. ') IFAIL1=1 ELSE TGAS=TGASR ENDIF CALL INPERR IF(IFAIL1.NE.0)PRINT *,' !!!!!! GASINP WARNING : The', - ' TEMPERATURE statement is ignored.' ELSE PRINT *,' !!!!!! GASINP WARNING : TEMPERATURE takes', - ' a single argument ; statement ignored.' ENDIF *** If USER1 is a keyword call routine USER1 to transfer user gas data. C ELSEIF(INPCMP(1,'US#ER-#GAS').NE.0)THEN C CALL GASUSR abbreviation point in the keyword. *** Call GASWRT to prepare writing the gas dataset. ELSEIF(INPCMP(1,'WR#ITE').NE.0)THEN CALL GASWRT(1) LGASWR=.TRUE. *** If normal intructions are used, it is not possible to get here. ELSE CALL INPSTR(1,1,STRING,NC) PRINT *,' !!!!!! GASINP WARNING : '//STRING(1:NC)//' is'// - ' not a valid instruction ; the line ignored.' ENDIF GOTO 10 END +DECK,GASINT. SUBROUTINE GASINT *----------------------------------------------------------------------- * GASINT - Initialises the gas data. * (Last changed on 9/ 3/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,GASDATA. +SEQ,GASMIXDATA. INTEGER I,J,K *** Overall gas availability. GASSET=.FALSE. *** Gas bits. DO 10 I=1,14 GASOK(I)=.FALSE. 10 CONTINUE *** Heed availability and Heed gas density. HEEDOK=.FALSE. GASDEN=0.0 *** Initialise the tables. TAB2D=.FALSE. NGAS=0 NBANG=1 NBTAB=1 DO 20 I=1,MXLIST EGAS(I)=0.0 VGAS(I)=0.0 XGAS(I)=0.0 YGAS(I)=0.0 DGAS(I)=0.0 OGAS(I)=0.0 AGAS(I)=0.0 BGAS(I)=0.0 MGAS(I)=0.0 WGAS(I)=0.0 CVGAS(I)=0.0 CXGAS(I)=0.0 CYGAS(I)=0.0 CDGAS(I)=0.0 COGAS(I)=0.0 CAGAS(I)=0.0 CBGAS(I)=0.0 CMGAS(I)=0.0 CWGAS(I)=0.0 DO 30 J=1,MXBANG DO 40 K=1,MXBTAB VGAS2(I,J,K)=0.0 XGAS2(I,J,K)=0.0 YGAS2(I,J,K)=0.0 DGAS2(I,J,K)=0.0 OGAS2(I,J,K)=0.0 AGAS2(I,J,K)=0.0 BGAS2(I,J,K)=0.0 MGAS2(I,J,K)=0.0 WGAS2(I,J,K)=0.0 40 CONTINUE 30 CONTINUE 20 CONTINUE *** Lower limits for alpha and eta. IATHR=1 IBTHR=1 *** Ion diffusions. DLION=0 DTION=0 *** Table function. FCNTAB=' ' NFTAB=1 *** Gas identifier. GASID=' ' *** Extrapolation methods for small E/p. JVEXTR=0 JXEXTR=0 JYEXTR=0 JDEXTR=0 JOEXTR=0 JAEXTR=0 JBEXTR=0 JMEXTR=0 JWEXTR=0 *** Extrapolation methods for large E/p. IVEXTR=1 IXEXTR=1 IYEXTR=1 IDEXTR=1 IOEXTR=1 IAEXTR=1 IBEXTR=1 IMEXTR=1 IWEXTR=1 *** Interpolation methods. IVMETH=2 IXMETH=2 IYMETH=2 IDMETH=2 IOMETH=2 IAMETH=2 IBMETH=2 IMMETH=2 IWMETH=2 *** Initialize the Landau data. A=0.0 Z=0.0 EMPROB=0.0 CMEAN=0.0 EPAIR=0.0 RHO=0.0 *** Initialise the cluster size distribution. FCNCLS=' ' NFCLS=1 DO 50 I=1,MXPAIR CLSDIS(I)=0 50 CONTINUE CLSTYP='NOT SET' NCLS=0 *** Initialise the plot types. DO 60 I=1,8 GASOK(I) =.FALSE. GASOPT(I,1)=.TRUE. GASOPT(I,2)=.FALSE. GASOPT(I,3)=.TRUE. GASOPT(I,4)=.FALSE. GASRNG(I,1)=0 GASRNG(I,2)=0 60 CONTINUE GASOPT(4,2)=.TRUE. GASOPT(5,1)=.FALSE. GASOPT(5,2)=.TRUE. *** Pressure and temperature. PGAS=760.0 TGAS=300.0 *** Initial data for the /GMXDAT/ common block. ESTEP=0.5 END +DECK,GASMIX. SUBROUTINE GASMIX *----------------------------------------------------------------------- * GASMIX - Calculates the drift velocity and diffusion coefficient * for various gas mixtures. * REFERENCES: G. Schultz, Thesis, Universite Louis Pasteur, * Strasbourg, No 1015 (1976). * G. Schultz and J. Gresser, NIM 151 (1978) 413-431. * (Last changed on 1/ 2/99.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,GASMIXDATA. +SEQ,GASDATA. +SEQ,CONSTANTS. +SEQ,PRINTPLOT. INTEGER INPCMP,INPTYP,MODVAR(MXVAR),MODRES(1) LOGICAL LDISPL,LOSSPL,LPTHPL,LCSPL,LTABPR,EPLOG,USE(MXVAR) REAL XPL(MXLIST),YPL1(MXLIST),YPL2(MXLIST),YPL3(MXLIST), - VAR(MXVAR),RES(1) DOUBLE PRECISION GASMG1,GASMG2,X(2),F0NORM,F0OK CHARACTER*(MXCHAR) STRMOB,STRTWN,STRATT CHARACTER*10 VARLIS(MXVAR) EXTERNAL INPCMP,INPTYP EXTERNAL FGAS1,FGAS2D,FGAS2N,FGAS2V,GASMG1,GASMG2 +SELF,IF=SAVE. SAVE LDISPL,LOSSPL,LPTHPL,LCSPL,LTABPR,EMIN,EMAX, - FRCRIT,EPMIN,EPMAX,EPLOG +SELF. DATA LDISPL , LOSSPL , LPTHPL , LCSPL , LTABPR - /.TRUE. , .FALSE., .FALSE., .TRUE. , .FALSE./ DATA EMIN,EMAX,FRCRIT,EPMIN,EPMAX - /0.01,25.0,0.01 ,0.5 ,50.0 / DATA EPLOG /.TRUE./ *** Initial values. XLOSCH=2.687E19*(PGAS/760.0)*(273.0/TGAS) EPMIN=100.0/PGAS EPMAX=10000.0/PGAS NGAS=20 DO 110 I=1,MXFRAC FRAC(I)=-1.0 110 CONTINUE VARLIS(1)='EP' NCMOB=0 NCTWN=0 NCATT=0 *** Progress printing. CALL PROINT('MIX',1,6) CALL PROFLD(1,'Reading the command',-1.0) CALL PROSTA(1,0.0) *** Read the command line. CALL INPNUM(NWORD) INEXT=2 DO 100 I=2,NWORD IF(I.LT.INEXT)GOTO 100 *** Fractions, first Argon. IF(INPCMP(I,'AR#GON').NE.0)THEN IF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.OR.I.GE.NWORD)THEN CALL INPMSG(I,'Argument invalid or missing. ') ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,FRAC(1),0.0) ENDIF INEXT=I+2 * Methane ELSEIF(INPCMP(I,'METHA#NE')+INPCMP(I,'CH4').NE.0)THEN IF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.OR.I.GE.NWORD)THEN CALL INPMSG(I,'Argument invalid or missing. ') ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,FRAC(2),0.0) ENDIF INEXT=I+2 * Neon ELSEIF(INPCMP(I,'NE#ON').NE.0)THEN IF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.OR.I.GE.NWORD)THEN CALL INPMSG(I,'Argument invalid or missing. ') ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,FRAC(3),0.0) ENDIF INEXT=I+2 * Isobutane ELSEIF(INPCMP(I,'ISO#BUTANE')+INPCMP(I,'C4H10').NE.0)THEN IF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.OR.I.GE.NWORD)THEN CALL INPMSG(I,'Argument invalid or missing. ') ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,FRAC(4),0.0) ENDIF INEXT=I+2 * CO2 ELSEIF(INPCMP(I,'CO2').NE.0)THEN IF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.OR.I.GE.NWORD)THEN CALL INPMSG(I,'Argument invalid or missing. ') ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,FRAC(5),0.0) ENDIF INEXT=I+2 * Helium ELSEIF(INPCMP(I,'HE#LIUM-#4').NE.0)THEN IF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.OR.I.GE.NWORD)THEN CALL INPMSG(I,'Argument invalid or missing. ') ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,FRAC(6),0.0) ENDIF INEXT=I+2 * Ethane ELSEIF(INPCMP(I,'ETH#ANE')+INPCMP(I,'C2H6').NE.0)THEN IF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.OR.I.GE.NWORD)THEN CALL INPMSG(I,'Argument invalid or missing. ') ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,FRAC(7),0.0) ENDIF INEXT=I+2 * Nitrogen ELSEIF(INPCMP(I,'NITR#OGEN').NE.0)THEN IF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.OR.I.GE.NWORD)THEN CALL INPMSG(I,'Argument invalid or missing. ') ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,FRAC(8),0.0) ENDIF INEXT=I+2 * Xenon ELSEIF(INPCMP(I,'XE#NON').NE.0)THEN IF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.OR.I.GE.NWORD)THEN CALL INPMSG(I,'Argument invalid or missing. ') ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,FRAC(9),0.0) ENDIF INEXT=I+2 * Methylal (dimethoxymethane). ELSEIF(INPCMP(I,'METHYL#AL')+INPCMP(I,'C3H8O2')+ - INPCMP(I,'DMM').NE.0)THEN IF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.OR.I.GE.NWORD)THEN CALL INPMSG(I,'Argument invalid or missing. ') ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,FRAC(10),0.0) ENDIF INEXT=I+2 * Krypton. ELSEIF(INPCMP(I,'KR#YPTON').NE.0)THEN IF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.OR.I.GE.NWORD)THEN CALL INPMSG(I,'Argument invalid or missing. ') ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,FRAC(11),0.0) ENDIF INEXT=I+2 * Ammonia. ELSEIF(INPCMP(I,'AMM#ONIA')+INPCMP(I,'NH3')+ - INPCMP(I,'H3N').NE.0)THEN IF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.OR.I.GE.NWORD)THEN CALL INPMSG(I,'Argument invalid or missing. ') ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,FRAC(12),0.0) ENDIF INEXT=I+2 * Test gas mixture. ELSEIF(INPCMP(I,'TEST').NE.0)THEN IF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.OR.I.GE.NWORD)THEN CALL INPMSG(I,'Argument invalid or missing. ') ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,FRAC(13),0.0) ENDIF INEXT=I+2 * Maximum energy for cross-section calculations and plots. ELSEIF(INPCMP(I,'MAX#IMUM-E#NERGY').NE.0)THEN IF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.OR.I.GE.NWORD)THEN CALL INPMSG(I,'Argument invalid or missing. ') ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,EMAXR,50.0) IF(EMAXR.LE.0.0)THEN CALL INPMSG(I+1,'Maximum energy not > 0. ') ELSE EMAX=EMAXR ENDIF ENDIF INEXT=I+2 * Minimum energy for cross-section plots. ELSEIF(INPCMP(I,'MIN#IMUM-E#NERGY').NE.0)THEN IF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.OR.I.GE.NWORD)THEN CALL INPMSG(I,'Argument invalid or missing. ') ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,EMINR,0.01) IF(EMINR.LE.0.0)THEN CALL INPMSG(I+1,'Minimum energy not > 0. ') ELSE EMIN=EMINR ENDIF ENDIF INEXT=I+2 * Energy step-size for integrations. ELSEIF(INPCMP(I,'STEP#SIZE-#ENERGY').NE.0)THEN IF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.OR.I.GE.NWORD)THEN CALL INPMSG(I,'Argument invalid or missing. ') ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,ESTEPR,10.0) IF(ESTEPR.LE.0.0)THEN CALL INPMSG(I+1,'Stepsize is not larger than 0.') ELSE ESTEP=ESTEPR ENDIF ENDIF INEXT=I+2 * Critical F0 fraction for warnings ELSEIF(INPCMP(I,'CRIT#ICAL-F0-FR#ACTION').NE.0)THEN IF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.OR.I.GE.NWORD)THEN CALL INPMSG(I,'Argument invalid or missing. ') ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,FRCRIR,0.1) IF(FRCRIR.LE.0.0.OR.FRCRIR.GE.1.0)THEN CALL INPMSG(I+1,'Fraction not within <0,1>. ') ELSE FRCRIT=FRCRIR ENDIF ENDIF INEXT=I+2 * Range of E/p. ELSEIF(INPCMP(I,'RAN#GE')+INPCMP(I,'E/P-RAN#GE').NE.0)THEN CALL INPCHK(I+1,2,IFAIL1) CALL INPCHK(I+2,2,IFAIL2) IF(IFAIL1.EQ.0.AND.IFAIL2.EQ.0.AND.NWORD.GE.I+2)THEN CALL INPRDR(I+1,EPMINR,EPMIN) CALL INPRDR(I+2,EPMAXR,EPMAX) IF(EPMINR.NE.EPMAXR.AND.EPMINR.GT.0.0.AND. - EPMAXR.GT.0.0)THEN EPMIN=MIN(EPMINR,EPMAXR) EPMAX=MAX(EPMINR,EPMAXR) ELSE CALL INPMSG(I+1,'Zero range and negative values') CALL INPMSG(I+2,'are not permitted in RANGE. ') ENDIF ELSE CALL INPMSG(I,'Missing or invalid arguments. ') ENDIF INEXT=I+3 * Kind of E/p scale. ELSEIF(INPCMP(I,'LIN#EAR-#E/P-#SCALE').NE.0)THEN EPLOG=.FALSE. ELSEIF(INPCMP(I,'LOG#ARITHMIC-#E/P-#SCALE').NE.0)THEN EPLOG=.TRUE. * Number of points. ELSEIF(INPCMP(I,'N-#E/P').NE.0)THEN IF(INPTYP(I+1).NE.1.OR.I.GE.NWORD)THEN CALL INPMSG(I,'Argument invalid or missing. ') ELSE CALL INPCHK(I+1,1,IFAIL1) CALL INPRDI(I+1,NGASR,20) IF(NGASR.LE.0.OR.NGASR.GT.MXLIST)THEN CALL INPMSG(I+1,'Value is out of range. ') ELSE NGAS=NGASR ENDIF ENDIF INEXT=I+2 * Plotting options. ELSEIF(INPCMP(I,'PL#OT-DIST#RIBUTION-#FUNCTIONS')+ - INPCMP(I,'PL#OT-F0').NE.0)THEN LDISPL=.TRUE. ELSEIF(INPCMP(I,'NOPL#OT-DIST#RIBUTION-#FUNCTIONS')+ - INPCMP(I,'NOPL#OT-F0').NE.0)THEN LDISPL=.FALSE. ELSEIF(INPCMP(I,'PL#OT-E#NERGY-#LOSS').NE.0)THEN LOSSPL=.TRUE. ELSEIF(INPCMP(I,'NOPL#OT-E#NERGY-#LOSS').NE.0)THEN LOSSPL=.FALSE. ELSEIF(INPCMP(I,'PL#OT-CR#OSS-#SECTION').NE.0)THEN LCSPL=.TRUE. ELSEIF(INPCMP(I,'NOPL#OT-CR#OSS-#SECTION').NE.0)THEN LCSPL=.FALSE. ELSEIF(INPCMP(I,'PL#OT-PATH').NE.0)THEN LPTHPL=.TRUE. ELSEIF(INPCMP(I,'NOPL#OT-PATH').NE.0)THEN LPTHPL=.FALSE. ELSEIF(INPCMP(I,'PR#INT-TAB#LES').NE.0)THEN LTABPR=.TRUE. ELSEIF(INPCMP(I,'NOPR#INT-TAB#LES').NE.0)THEN LTABPR=.FALSE. * Mobility. ELSEIF(INPCMP(I,'ION-MOB#ILITY')+ - INPCMP(I,'MOB#ILITY').NE.0)THEN IF(I.GE.NWORD)THEN CALL INPMSG(I,'Argument invalid or missing. ') ELSE CALL INPSTR(I+1,I+1,STRMOB,NCMOB) ENDIF INEXT=I+2 * Townsend coefficient. ELSEIF(INPCMP(I,'TOWN#SEND-#COEFFICIENT').NE.0)THEN IF(I.GE.NWORD)THEN CALL INPMSG(I,'Argument invalid or missing. ') ELSE CALL INPSTR(I+1,I+1,STRTWN,NCTWN) ENDIF INEXT=I+2 * Attachment coefficient. ELSEIF(INPCMP(I,'ATT#ACHMENT-#COEFFICIENT').NE.0)THEN IF(I.GE.NWORD)THEN CALL INPMSG(I,'Argument invalid or missing. ') ELSE CALL INPSTR(I+1,I+1,STRATT,NCATT) ENDIF INEXT=I+2 * Other options not valid. ELSE CALL INPMSG(I,'Not a recognised keyword. ') ENDIF 100 CONTINUE *** Dump error messages. CALL INPERR *** Renormalise the fractions. FRTOT=0.0 DO 120 I=1,MXFRAC IF(FRAC(I).LT.0)FRAC(I)=0.0 FRTOT=FRTOT+FRAC(I) 120 CONTINUE IF(FRTOT.LE.0.0)THEN PRINT *,' !!!!!! GASMIX WARNING : Please have at least'// - ' gas in your mixture; nothing done.' NGAS=0 CALL PROEND RETURN ELSE DO 130 I=1,MXFRAC FRAC(I)=FRAC(I)/FRTOT 130 CONTINUE ENDIF *** Break-point initialisation. CALL PROFLD(1,'Setting breakpoints',-1.0) CALL PROSTA(1,0.0) CALL GASMXB *** Debugging output. IF(LDEBUG)THEN WRITE(LUNOUT,'('' ++++++ GASMIX DEBUG : Mixing the'', - '' following gasses:''// - '' Argon '',F6.3,'' Methane '',F6.3/ - '' Neon '',F6.3,'' Isobutane '',F6.3/ - '' CO2 '',F6.3,'' Helium '',F6.3/ - '' Ethane '',F6.3,'' Nitrogen '',F6.3/ - '' Xenon '',F6.3,'' Methylal '',F6.3/ - '' Krypton '',F6.3,'' Ammonia '',F6.3/)') - (FRAC(I),I=1,12) WRITE(LUNOUT,'('' With the following parameters:''// - '' Lower plotting bound: '',F10.3,'' [eV]''/ - '' Upper integration bound: '',F10.3,'' [eV]''/ - '' Step size limit: '',F10.3,'' [eV]''/ - '' Onset of ionisation: '',F10.3,'' [eV]''/ - '' Warning level: '',F10.3/ - '' E/p range: '',2F10.3, - '' [V/cm.torr]''/ - '' Number of E/p points: '',I6/ - '' Pressure of the gas: '',F10.3,'' [torr]''/ - '' Temperature of the gas: '',F10.3,'' [K]'')') - EMIN,EMAX,ESTEP,ECRIT,FRCRIT,EPMIN,EPMAX,NGAS,PGAS,TGAS IF(NCMOB.GT.0)WRITE(LUNOUT,'('' ++++++ GASMIX DEBUG :'', - '' Mobility = '',A)') STRMOB(1:NCMOB) IF(NCTWN.GT.0)WRITE(LUNOUT,'('' ++++++ GASMIX DEBUG :'', - '' Townsend = '',A)') STRTWN(1:NCTWN) IF(NCATT.GT.0)WRITE(LUNOUT,'('' ++++++ GASMIX DEBUG :'', - '' Attachment = '',A)') STRATT(1:NCATT) ENDIF *** Some preliminary plots. IF(LOSSPL.OR.LCSPL.OR.LPTHPL.OR.LTABPR)THEN CALL PROFLD(1,'Plotting cs and mfp',-1.0) CALL PROSTA(1,0.0) IF(LTABPR)WRITE(LUNOUT,'('' TABLE OF INPUT GAS DATA''//5X, - '' Energy [eV] Free path [cm]'', - '' Energy loss Cross section [cm2]''//)') DO 200 I=1,MXLIST XPL(I)=EMIN*(EMAX/EMIN)**(REAL(I-1)/REAL(MXLIST-1)) CALL GASMXD(XPL(I),YPL1(I),YPL2(I)) YPL3(I)=1/(XLOSCH*YPL1(I)) IF(LTABPR)WRITE(LUNOUT,'(5X,4(5X,E15.8))') - XPL(I),YPL1(I),YPL2(I),YPL3(I) 200 CONTINUE CALL GRAOPT('LOG-X') CALL GRAOPT('LOG-Y') IF(LPTHPL)THEN CALL GRGRPH(XPL,YPL1,MXLIST,'Energy [eV]', - 'Mean path length [cm]','Mean path length') CALL GRCOMM(1,'Gas: '//GASID) CALL GRNEXT CALL GRALOG('Mean free path of electrons in the gas: ') ENDIF IF(LOSSPL)THEN CALL GRGRPH(XPL,YPL2,MXLIST,'Energy [eV]', - 'Fraction','Energy loss per collision') CALL GRCOMM(1,'Gas: '//GASID) CALL GRNEXT CALL GRALOG('Average energy loss per collision: ') ENDIF IF(LCSPL)THEN CALL GRGRPH(XPL,YPL3,MXLIST,'Energy [eV]', - 'Cross section [cm2]','Cross section') CALL GRCOMM(1,'Gas: '//GASID) CALL GRNEXT CALL GRALOG('Elastic cross section of the gas: ') ENDIF CALL GRAOPT('LIN-X') CALL GRAOPT('LIN-Y') ENDIF *** Translate the various functions if they have been specified. IF(NCMOB.GT.0)THEN CALL PROFLD(1,'Setting the mobility',-1.0) CALL PROSTA(1,0.0) * Call editor of specified as @. IF(INDEX(STRMOB(1:NCMOB),'@').NE.0)THEN NRES=1 PRINT *,' ------ GASMIX MESSAGE : Please edit the'// - ' mobility, function of EP (= E/p).' CALL ALGEDT(VARLIS,1,IENMOB,USE,NRES) IFAIL1=0 * Usual function translation if not. ELSE CALL ALGPRE(STRMOB,NCMOB,VARLIS,1,NRES,USE,IENMOB, - IFAIL1) ENDIF * Check return code of translation. IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! GASMIX WARNING : Ion mobility'// - ' function rejected; no ion mobility in table.' CALL ALGCLR(IENMOB) NCMOB=0 ENDIF * Check number of results returned by the function. IF(NRES.NE.1)THEN PRINT *,' !!!!!! GASMIX WARNING : Number of'// - ' results returned by the mobility function'// - ' is not 1; rejected.' CALL ALGCLR(IENMOB) NCMOB=0 ENDIF ENDIF ** Townsend coefficient. IF(NCTWN.GT.0)THEN CALL PROFLD(1,'Setting Townsend',-1.0) CALL PROSTA(1,0.0) * Call editor of specified as @. IF(INDEX(STRTWN(1:NCTWN),'@').NE.0)THEN NRES=1 PRINT *,' ------ GASMIX MESSAGE : Please edit the'// - ' Townsend coefficient, function of EP (=E/p).' CALL ALGEDT(VARLIS,1,IENTWN,USE,NRES) IFAIL1=0 * Usual function translation if not. ELSE CALL ALGPRE(STRTWN,NCTWN,VARLIS,1,NRES,USE,IENTWN, - IFAIL1) ENDIF * Check return code of translation. IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! GASMIX WARNING : Townsend function'// - ' rejected; no Townsend coefficient in table.' CALL ALGCLR(IENTWN) NCTWN=0 ENDIF * Check number of results returned by the function. IF(NRES.NE.1)THEN PRINT *,' !!!!!! GASMIX WARNING : Number of'// - ' results returned by the Townsend function'// - ' is not 1; rejected.' CALL ALGCLR(IENTWN) NCTWN=0 ENDIF ENDIF *** Attachment coefficient. IF(NCATT.GT.0)THEN CALL PROFLD(1,'Setting attachment',-1.0) CALL PROSTA(1,0.0) * Call editor of specified as @. IF(INDEX(STRATT(1:NCATT),'@').NE.0)THEN NRES=1 PRINT *,' ------ GASMIX MESSAGE : Please edit the'// - ' attachment coefficient, function of EP (=E/p).' CALL ALGEDT(VARLIS,1,IENATT,USE,NRES) IFAIL1=0 * Usual function translation if not. ELSE CALL ALGPRE(STRATT,NCATT,VARLIS,1,NRES,USE,IENATT, - IFAIL1) ENDIF * Check return code of translation. IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! GASMIX WARNING : Attachment'// - ' function rejected; no attachment in table.' CALL ALGCLR(IENATT) NCATT=0 ENDIF * Check number of results returned by the function. IF(NRES.NE.1)THEN PRINT *,' !!!!!! GASMIX WARNING : Number of'// - ' results returned by the attachment function'// - ' is not 1; rejected.' CALL ALGCLR(IENATT) NCATT=0 ENDIF ENDIF *** Loop over the electric field. EPCRIT=-1.0 IF(LDISPL)CALL GRAOPT('LOG-X') CALL PROFLD(1,'Electric field',REAL(NGAS)) DO 10 I=1,NGAS CALL PROSTA(1,REAL(I)) *** Logarithmic or linear spacing of the E/p points. IF(EPLOG)THEN EGAS(I)=EPMIN*(EPMAX/EPMIN)**(REAL(I-1)/REAL(MAX(1,NGAS-1))) ELSE EGAS(I)=EPMIN+(EPMAX-EPMIN)*(REAL(I-1)/REAL(MAX(1,NGAS-1))) ENDIF *** Compute the mobility if requested. IF(NCMOB.GT.0)THEN VAR(1)=EGAS(I) MODVAR(1)=2 CALL ALGEXE(IENMOB,VAR,MODVAR,1,RES,MODRES,1,IFAIL1) MGAS(I)=RES(1) ENDIF *** Compute the Townsend coefficient if requested. IF(NCTWN.GT.0)THEN VAR(1)=EGAS(I) MODVAR(1)=2 CALL ALGEXE(IENTWN,VAR,MODVAR,1,RES,MODRES,1,IFAIL1) AGAS(I)=RES(1) ENDIF *** Compute the attachment coefficient if requested. IF(NCATT.GT.0)THEN VAR(1)=EGAS(I) MODVAR(1)=2 CALL ALGEXE(IENATT,VAR,MODVAR,1,RES,MODRES,1,IFAIL1) BGAS(I)=RES(1) ENDIF *** Copy for the gas-mixing common block. EFLD=PGAS*EGAS(I) IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GASMIX DEBUG : E='', - E10.3,'' V/cm'')') EFLD *** Find the maximum relevant energy. EEMAX=EMAX 40 CONTINUE ARG=GASMG1(FGAS1,DBLE(EEMAX),X) IF(ARG.LT.50.0)THEN EEMAX=EEMAX/0.9 GOTO 30 ELSE EEMAX=EEMAX*0.9 GOTO 40 ENDIF 30 CONTINUE IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GASMIX DEBUG : Largest'', - '' relevant electron energy: '',F10.3,'' eV.'')') EEMAX *** Get the F0 normalisation straight. F0NORM=GASMG2(FGAS2N,DBLE(EEMAX),X) *** Monitor electron excitation. F0OK=GASMG2(FGAS2N,DBLE(ECRIT),X)/F0NORM IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GASMIX DEBUG : Fraction'', - '' of F0 above ionisation: '',E10.3,''.'')') 1.0D0-F0OK *** Plot the distribution if requested. IF(LDISPL)THEN F0MAX=0 DO 20 J=1,MXLIST XPL(J)=EMIN*(EMAX/EMIN)**(REAL(J-1)/REAL(MXLIST-1)) YPL1(J)=SQRT(XPL(J))*EXP(MAX(-60.0D0, - -GASMG1(FGAS1,DBLE(XPL(J)),X)))/F0NORM IF(YPL1(J).GT.F0MAX)F0MAX=YPL1(J) 20 CONTINUE IF(I.EQ.1)CALL GRCART(EMIN,0.0,EMAX,1.1*F0MAX, - 'Energy [eV]','F0 [1/eV]','Distribution function') IF(REAL(1.0D0-F0OK).LT.FRCRIT)THEN CALL GRATTS('FUNCTION-1','POLYLINE') ELSE CALL GRATTS('FUNCTION-2','POLYLINE') IF(EPCRIT.LE.0)EPCRIT=EGAS(I) ENDIF CALL GRLINE(MXLIST,XPL,YPL1) ENDIF *** Compute the drift velocity. VGAS(I)=1.0E-4*(2.0/3.0)*SQRT(0.5*ECHARG/EMASS)*EFLD* - GASMG2(FGAS2V,DBLE(EEMAX),X)/F0NORM *** Compute the diffusion coefficient. DGAS(I)=0.01*SQRT(2*PGAS*GASMG2(FGAS2D,DBLE(EEMAX),X)/ - (3*F0NORM*VGAS(I))) 10 CONTINUE *** Close the plot. IF(LDISPL)THEN CALL GRCOMM(1,'Gas: '//GASID) IF(EPCRIT.GT.0)CALL GRCOMM(2, - 'WARNING: F0 for high E/p is affected by ionisation.') CALL GRNEXT CALL GRALOG('Distribution function F0') CALL GRAOPT('LIN-X') ENDIF CALL PROEND *** Clear the mobility etc entry points - no longer needed. IF(NCMOB.GT.0)CALL ALGCLR(IENMOB) IF(NCTWN.GT.0)CALL ALGCLR(IENTWN) IF(NCATT.GT.0)CALL ALGCLR(IENATT) *** Dump algebra error messages. IF(NCMOB.GT.0.OR.NCTWN.GT.0.OR.NCATT.GT.0)CALL ALGERR *** Issue warnings if needed. IF(EPCRIT.GT.0.0)PRINT *,' !!!!!! GASMIX WARNING : Ionisation'// - ' effects play a role for E/p > ',EPCRIT *** Set the gas bits. GASOK(1)=.TRUE. IF(NCMOB.GT.0)GASOK(2)=.TRUE. GASOK(3)=.TRUE. IF(NCTWN.GT.0)GASOK(4)=.TRUE. IF(NCATT.GT.0)GASOK(6)=.TRUE. *** Register the amount of CPU time with TIMLOG. CALL TIMLOG('Computing a gas mixture: ') END +DECK,FGAS1. SUBROUTINE FGAS1(M,U1,F1,X) *----------------------------------------------------------------------- * FGAS2V - Used by GASMIX and auxiliaries to compute F0. * (Last changed on 28/ 9/92.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,GASMIXDATA. +SEQ,GASDATA. +SEQ,CONSTANTS. DOUBLE PRECISION U1(*),F1(*),X(2) *** Loop over the points. DO 10 I=1,M X(1)=U1(I) E=X(1) *** Quick return for zero energy. IF(E.LE.0.0)THEN F1(I)=0.0 ELSE *** Obtain the mean path and fraction of energy lost at this energy. CALL GASMXD(E,PATH,ELOSS) *** Compute the integrand. F1(I)=3*ELOSS*E/((EFLD*PATH)**2+3*ELOSS*E*BOLTZ*TGAS/ECHARG) ENDIF 10 CONTINUE END +DECK,FGAS2D. SUBROUTINE FGAS2D(M,U2,F2,X) *----------------------------------------------------------------------- * FGAS2V - Used by GASMIX to compute the diffusion integral. * (Last changed on 28/ 9/92.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,GASMIXDATA. +SEQ,CONSTANTS. DOUBLE PRECISION U2(*),F2(*),X(2),GASMG1 EXTERNAL GASMG1,FGAS1 *** Loop over the points. DO 10 I=1,M X(2)=U2(I) E=X(2) *** Assign. CALL GASMXD(E,PATH,ELOSS) F2(I)=PATH*SQRT(2*ECHARG*E/EMASS)*SQRT(E)* - EXP(MAX(-60.0D0,-GASMG1(FGAS1,DBLE(E),X))) 10 CONTINUE END +DECK,FGAS2N. SUBROUTINE FGAS2N(M,U2,F2,X) *----------------------------------------------------------------------- * FGAS2V - Used by GASMIX to compute the F0 normalisation. * (Last changed on 28/ 9/92.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,GASMIXDATA. +SEQ,CONSTANTS. DOUBLE PRECISION U2(*),F2(*),X(2),GASMG1 EXTERNAL GASMG1,FGAS1 *** Loop over the points. DO 10 I=1,M X(2)=U2(I) E=X(2) *** Assign. F2(I)=SQRT(E)* - EXP(MAX(-60.0D0,-GASMG1(FGAS1,DBLE(E),X))) 10 CONTINUE END +DECK,FGAS2V. SUBROUTINE FGAS2V(M,U2,F2,X) *----------------------------------------------------------------------- * FGAS2V - Used by GASMIX to compute the drift velocity integral. * (Last changed on 28/ 9/92.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,GASMIXDATA. +SEQ,CONSTANTS. DOUBLE PRECISION U2(*),F2(*),X(2),GASMG1 EXTERNAL GASMG1,FGAS1 *** Loop over the points. DO 10 I=1,M X(2)=U2(I) E=X(2) *** Get derivative of the path. EPS=1.0E-3 CALL GASMXD(E,PATH,ELOSS) IF(E.LE.EPS)THEN CALL GASMXD(EPS,PATH1,ELOSS1) CALL GASMXD(0.0,PATH2,ELOSS2) DLDE=(PATH1-PATH2)/EPS ELSE CALL GASMXD(E*(1+EPS),PATH1,ELOSS1) CALL GASMXD(E*(1-EPS),PATH2,ELOSS2) DLDE=(PATH1-PATH2)/(2*EPS*E) ENDIF *** Assign. F2(I)=(PATH+E*DLDE)* - EXP(MAX(-60.0D0,-GASMG1(FGAS1,DBLE(E),X))) 10 CONTINUE END +DECK,GASMXD. SUBROUTINE GASMXD(E,PATH,ELOSS) *----------------------------------------------------------------------- * GASMXD - Returns literature values for the gas mixtures. * ORIGIN: Data taken from a program written by Fabio Sauli and * Anna Peisert, apparently based on Schultz & Gresser. * Data for Krypton, Argon and ammonia from Wircha. * (Last changed on 16/11/93.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,GASMIXDATA. REAL DIVDIF,ELOSS,SIGMA(MXFRAC),ELVECT(MXFRAC) EXTERNAL DIVDIF *** Gas data. REAL ENEON(31),SNEON(31) REAL EHEL(37),SHEL(37) REAL ENITR(24),SNITR(24) DATA ENEON/ 0.03 , 0.04 , 0.05 , 0.06 , 0.07 , 0.08 , 0.09 , - 0.1 , 0.12 , 0.15 , 0.18 , 0.2 , 0.25 , 0.3 , - 0.4 , 0.5 , 0.6 , 0.7 , 0.8 , 0.9 , 1.0 , - 1.2 , 1.5 , 1.8 , 2.0 , 2.5 , 3.0 , 4.0 , - 5.0 , 6.0 , 7.0 / DATA SNEON/ 0.469, 0.504, 0.536, 0.566, 0.601, 0.636, 0.669, - 0.701, 0.754, 0.828, 0.893, 0.930, 1.018, 1.091, - 1.225, 1.321, 1.402, 1.472, 1.528, 1.580, 1.619, - 1.685, 1.753, 1.793, 1.815, 1.860, 1.906, 1.984, - 2.070, 2.144, 2.213/ DATA EHEL / 0.008, 0.009, 0.01 , 0.013, 0.017, 0.02 , 0.025, - 0.03 , 0.04 , 0.05 , 0.06 , 0.07 , 0.08 , 0.09 , - 0.1 , 0.12 , 0.15 , 0.18 , 0.2 , 0.25 , 0.3 , - 0.4 , 0.5 , 0.6 , 0.7 , 0.8 , 0.9 , 1.0 , - 1.2 , 1.5 , 1.8 , 2.0 , 2.5 , 3.0 , 4.0 , - 5.0 , 6.0 / DATA SHEL / 5.18 , 5.19 , 5.21 , 5.26 , 5.31 , 5.35 , 5.41 , - 5.46 , 5.54 , 5.62 , 5.68 , 5.74 , 5.79 , 5.83 , - 5.86 , 5.94 , 6.04 , 6.12 , 6.16 , 6.27 , 6.35 , - 6.49 , 6.59 , 6.66 , 6.73 , 6.77 , 6.82 , 6.85 , - 6.91 , 6.96 , 6.98 , 6.99 , 6.96 , 6.89 , 6.6 , - 6.26 , 6.01 / DATA ENITR/0.0016,0.0036,0.0064,0.0103,0.0221, 0.040,0.0651, - 0.103, 0.15 , 0.332, 1.0 , 1.2 , 1.4 , 1.6 , - 1.8 , 2.0 , 2.6 , 3.0 , 3.6 , 4.5 ,10.0 , - 20.0 ,35.0 ,40.0 / DATA SNITR/ 1.43 , 1.69 , 1.94 , 2.2 , 2.94 , 3.86 , 4.9 , - 6.04 , 7.12 , 9.34 , 9.98 ,10.51 ,11.45 ,12.9 , - 16.95 ,24.01 ,29.88 ,21.63 ,14.66 ,11.52 , 9.51 , - 12.0 ,10.5 ,10.1 / *** Exceptions. IF(E.LE.0.0)THEN PATH=0.0 ELOSS=0.0 RETURN ENDIF *** Argon. IF(FRAC(1).GT.0.0)THEN IF(E.LT.0.3)THEN SIGMA(1)=1.46E-17+1.24E-12*(0.3-E)**6.5 ELSEIF(E.LT.1.15)THEN SIGMA(1)=1.46E-17+1.9E-16*(E-0.3)**2 ELSEIF(E.LT.11.5)THEN SIGMA(1)=1.52E-15*E/11.5 ELSE SIGMA(1)=1.52E-15/SQRT(E/11.5) ENDIF ELVECT(1)=2.746E-5 ENDIF *** Methane. IF(FRAC(2).GT.0.0)THEN IF(E.LE.0.3)THEN SIGMA(2)=5.77E-17/SQRT(E) ELSEIF(E.LE.2.0)THEN SIGMA(2)=4.468E-16*E**1.2 ELSEIF(E.LE.8.)THEN SIGMA(2)=7.258E-16*SQRT(E) ELSE SIGMA(2)=2.05E-15/SQRT(E/8) ENDIF IF(E.LT.0.36)THEN ELVECT(2)=8.35E-5+5.E-17/SIGMA(2) ELSE ELVECT(2)=8.35E-5+1.8E-17/(E*SIGMA(2)) ENDIF ENDIF *** Neon. IF(FRAC(3).GT.0.0)THEN IF(E.LT.7)THEN SIGMA(3)=1.0E-16*DIVDIF(SNEON,ENEON,31,E,2) ELSE SIGMA(3)=1.0E-16*DIVDIF(SNEON,ENEON,31,E,1) ENDIF ELVECT(3)=5.44E-5 ENDIF *** Isobutane. IF(FRAC(4).GT.0.0)THEN IF(E.LT.0.20)THEN SIGMA(4)=0.72E-15*SQRT(0.20/E) ELSEIF(E.LT.0.60)THEN SIGMA(4)=0.72E-15*(E/0.20)**0.3347 ELSEIF(E.LT.8.00)THEN SIGMA(4)=(1.04E-15*(8-E)+4.8E-15*(E-0.60))/7.4 ELSE SIGMA(4)=4.8E-15/SQRT(E/8) ENDIF IF(E.LT.0.36)THEN ELVECT(4)=8.E-17/SIGMA(4)+1.89E-5 ELSE ELVECT(4)=1.89E-5+2.88E-17/(E*SIGMA(4)) ENDIF ENDIF *** CO2. IF(FRAC(5).GT.0.0)THEN IF(E.LT.0.2)THEN SIGMA(5)=1.7E-15*(1/E)**0.5 ELSEIF(E.LT.1.32)THEN SIGMA(5)=7.6E-16/E ELSEIF(E.LT.3.25)THEN SIGMA(5)=1.E-15-3.66E-16*(3.25-E)**0.222 ELSEIF(E.LT.4.2)THEN SIGMA(5)=1.53E-15-5.9E-16*(4.2-E)**2.09 ELSEIF(E.LT.6.0)THEN SIGMA(5)=1.53E-15-4.84E-16*(E-4.2)**0.528 ELSEIF(E.LT.25.)THEN SIGMA(5)=1.6E-15-1.75E-18*(25-E)**2.05 ELSE SIGMA(5)=1.6E-15-2.94E-18*(E-25)**1.3 ENDIF IF(E.LT.0.2)THEN ELVECT(5)=2.493E-5+4E-16/SIGMA(5) ELSE ELVECT(5)=2.493E-5+0.35E-16/(E**0.25*SIGMA(5)) ENDIF ENDIF *** Helium. IF(FRAC(6).GT.0.0)THEN SIGMA(6)=1.0E-16*DIVDIF(SHEL,EHEL,37,E,2) ELVECT(6)=27.4E-5 ENDIF *** Ethane. IF(FRAC(7).GT.0.0)THEN IF(E.LT.0.025)THEN SIGMA(7)=25.E-16*(0.025/E)**0.7005 ELSEIF(E.LT.0.035)THEN SIGMA(7)=3.5E-16*(0.035/E)**5.844 ELSEIF(E.LT.0.07)THEN SIGMA(7)=1.9E-16*(0.07/E)**0.881 ELSEIF(E.LT.0.09)THEN SIGMA(7)=1.8E-16*(0.09/E)**0.215 ELSEIF(E.LT.0.2)THEN SIGMA(7)=1.8E-16*(E/0.09)**1.147 ELSEIF(E.LT.0.3)THEN SIGMA(7)=4.5E-16*(E/0.2)**0.583 ELSEIF(E.LT.0.6)THEN SIGMA(7)=5.7E-16*(E/0.3)**0.811 ELSEIF(E.LT.1.)THEN SIGMA(7)=10.E-16*(E/0.6)**0.514 ELSE SIGMA(7)=13.E-16 ENDIF IF(E.LT.0.36)THEN ELVECT(7)=3.648E-5+6.E-17/SIGMA(7) ELSE ELVECT(7)=3.648E-5+2.16E-17/(E*SIGMA(7)) ENDIF ENDIF *** Nitrogen. IF(FRAC(8).GT.0.0)THEN SIGMA(8)=1.0E-16*DIVDIF(SNITR,ENITR,24,E,2) IF(E.LT.1.3)THEN ELVECT(8)=3.5E-19/SIGMA(8)+3.90E-5 ELSEIF(E.LT.1.4)THEN ELVECT(8)=2.0E-18/SIGMA(8)+3.90E-5 ELSEIF(E.LT.1.5)THEN ELVECT(8)=4.0E-18/SIGMA(8)+3.90E-5 ELSEIF(E.LT.1.6)THEN ELVECT(8)=8.0E-18/SIGMA(8)+3.90E-5 ELSEIF(E.LT.1.7)THEN ELVECT(8)=1.0E-17/SIGMA(8)+3.90E-5 ELSEIF(E.LT.1.8)THEN ELVECT(8)=1.5E-17/SIGMA(8)+3.90E-5 ELSEIF(E.LT.1.9)THEN ELVECT(8)=2.0E-17/SIGMA(8)+3.90E-5 ELSEIF(E.LT.2.0)THEN ELVECT(8)=7.0E-17/SIGMA(8)+3.90E-5 ELSEIF(E.LT.5.0)THEN ELVECT(8)=2.0E-16/SIGMA(8)+3.90E-5 ELSE ELVECT(8)=1.0E-15/(E*SIGMA(8))+3.90E-5 ENDIF ENDIF *** Xenon. IF(FRAC(9).GT.0.0)THEN IF(E.LT.0.010)THEN SIGMA(9)=100.E-16*(0.01/E)**0.176 ELSEIF(E.LT.0.035)THEN SIGMA(9)=100.E-16*(0.01/E)**0.308 ELSEIF(E.LT.0.1)THEN SIGMA(9)=68.E-16*(0.035/E)**1.166 ELSEIF(E.LT.0.18)THEN SIGMA(9)=20.E-16*(0.1/E)**1.179 ELSEIF(E.LT.0.5)THEN SIGMA(9)=10.E-16*(0.18/E)**1.997 ELSEIF(E.LT.0.7)THEN SIGMA(9)=1.3E-16*(0.5/E)**0.238 ELSEIF(E.LT.2.0)THEN SIGMA(9)=1.2E-16*(E/0.70)**2.019 ELSEIF(E.LT.4.1)THEN SIGMA(9)=10.E-16*(E/2.)**1.823 ELSEIF(E.LT.10.0)THEN SIGMA(9)=37.E-16*(10/E)**0.69 ELSE SIGMA(9)=37.0E-16*(10/E)**0.69 ENDIF ELVECT(9)=8.29E-6 ENDIF *** Methylal. IF(FRAC(10).GT.0.0)THEN IF(E.LE.2.0)THEN SIGMA(10)=1.1E-15*SQRT(2/E) ELSEIF(E.LE.4.0)THEN SIGMA(10)=(1.1E-15*(10-E)+1.8E-15*(E-2))/8 ELSE SIGMA(10)=1.275E-15*(E/4)**0.22 ENDIF IF(E.LE.0.36)THEN ELVECT(10)=1.444E-5+12.E-17/SIGMA(10) ELSE ELVECT(10)=1.444E-5+4.32E-17/(E*SIGMA(10)) ENDIF ENDIF *** Krypton, Wircha typing mistake corrected. IF(FRAC(11).GT.0.0)THEN IF(E.LE.0.01)THEN SIGMA(11)=28.0 ELSEIF(E.LE.0.02)THEN SIGMA(11)=10.0**(0.4763-0.4854*LOG10(E)) ELSEIF(E.LE.0.04)THEN SIGMA(11)=10.0**(0.2451-0.6215*LOG10(E)) ELSEIF(E.LE.0.07)THEN SIGMA(11)=10.0**(0.195-0.6571*LOG10(E)) ELSEIF(E.LE.0.1)THEN SIGMA(11)=10.0**(-0.05-0.8696*LOG10(E)) ELSEIF(E.LE.0.145)THEN SIGMA(11)=10.0**(-0.2112-1.0307*LOG10(E)) ELSEIF(E.LE.0.2)THEN SIGMA(11)=10.0**(-0.679-1.5885*LOG10(E)) ELSEIF(E.LE.0.3)THEN SIGMA(11)=10.0**(-1.2808-2.4497*LOG10(E)) ELSEIF(E.LE.0.4)THEN SIGMA(11)=10.0**(-0.9284-1.7757*LOG10(E)) ELSEIF(E.LE.0.5)THEN SIGMA(11)=10.0**(-0.547-0.8171*LOG10(E)) ELSEIF(E.LE.0.6)THEN SIGMA(11)=10.0**(-0.301) ELSEIF(E.LE.0.8)THEN SIGMA(11)=10.0**(-0.2708+0.1363*LOG10(E)) ELSEIF(E.LE.1.0)THEN SIGMA(11)=10.0**(-0.2007+0.8599*LOG10(E)) ELSEIF(E.LE.2.0)THEN SIGMA(11)=10.0**(-0.2006+1.8041*LOG10(E)) ELSEIF(E.LE.3.0)THEN SIGMA(11)=10.0**(-0.2521+1.975*LOG10(E)) ELSEIF(E.LE.4.0)THEN SIGMA(11)=10.0**(-0.1019+1.6603*LOG10(E)) ELSEIF(E.LE.5.0)THEN SIGMA(11)=10.0**(+0.1299+1.275*LOG10(E)) ELSEIF(E.LE.7.0)THEN SIGMA(11)=10.0**(0.28025+1.06004*LOG10(E)) ELSEIF(E.LE.10.0)THEN SIGMA(11)=10.0**(0.3789+0.9433*LOG10(E)) ELSE SIGMA(11)=21.0 ENDIF SIGMA(11)=SIGMA(11)*1E-16 ELVECT(11)=1.309E-5 ENDIF *** Ammonia (NH3). IF(FRAC(12).GT.0.0)THEN IF(E.LE.0.01)THEN SIGMA(12)=1600. ELSEIF(E.LE.0.02)THEN SIGMA(12)=10.0**(1.5439-0.83007*LOG10(E)) ELSEIF(E.LE.0.04)THEN SIGMA(12)=10.0**(1.4135-0.9069*LOG10(E)) ELSEIF(E.LE.0.1)THEN SIGMA(12)=10.0**(1.0051-1.199*LOG10(E)) ELSEIF(E.LE.0.2)THEN SIGMA(12)=10.0**(0.7891-1.415*LOG10(E)) ELSEIF(E.LE.0.4)THEN SIGMA(12)=10.0**(0.9729-1.152*LOG10(E)) ELSEIF(E.GT.1.0)THEN SIGMA(12)=10.0**(1.0414-0.98*LOG10(E)) ELSEIF(E.GT.2.0)THEN SIGMA(12)=10.0**(1.0414-1.081*LOG10(E)) ELSEIF(E.GT.3.0)THEN SIGMA(12)=10.0**(0.716) ELSEIF(E.GT.5.0)THEN SIGMA(12)=10.0**(0.3615+0.74289*LOG10(E)) ELSEIF(E.GT.7.0)THEN SIGMA(12)=10.0**(0.4839+0.5678*LOG10(E)) ELSEIF(E.GT.10.0)THEN SIGMA(12)=10.0**(0.5404+0.501*LOG10(E)) ELSE SIGMA(12)=11.0 ENDIF SIGMA(12)=SIGMA(12)*1E-16 ELVECT(12)=6.442E-5 ENDIF *** Test gas. IF(FRAC(13).GT.0.0)THEN SIGMA(13)=1E-16 ELVECT(13)=1E-5 ENDIF *** Take the sums. FRTOT=0.0 CSTOT=0.0 PRTOT=0.0 DO 10 I=1,MXFRAC IF(FRAC(I).LE.0.0)GOTO 10 FRTOT=FRTOT+FRAC(I) CSTOT=CSTOT+FRAC(I)*SIGMA(I) PRTOT=PRTOT+FRAC(I)*SIGMA(I)*ELVECT(I) 10 CONTINUE *** Normalise, provided things are not zero. IF(FRTOT.NE.0.AND.CSTOT.NE.0)THEN CSTOT=CSTOT/FRTOT PRTOT=PRTOT/FRTOT ELOSS=PRTOT/CSTOT PATH=1/(XLOSCH*CSTOT) ELSE ELOSS=0.0 PATH=0.0 ENDIF END +DECK,GASMXB. SUBROUTINE GASMXB *----------------------------------------------------------------------- * GASMXB - Sets the break points for the integration routines, find * the lowest ionisation potential and store the gas name. * REFERENCE : Ionisation data from Handbook of Chemistry and Physics, * 72nd edition 1991-1992, CRC press, p 10-211 to 10-219, * Edited by David R. Lide. * (Last changed on 23/ 2/99.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,GASMIXDATA. +SEQ,GASDATA. +SEQ,PRINTPLOT. CHARACTER*169 AUX *** Initial value of the ionisation level. ECRIT=1.0E10 *** Initial value of the break point list. NBREAK=1 BREAK(1)=0.0 *** Blank the gas name string. AUX=' ' GASID=' ' *** Argon (Ar). IF(FRAC(1).GT.0.0)THEN * Break points. BREAK(NBREAK+1)=0.3 BREAK(NBREAK+2)=1.15 BREAK(NBREAK+3)=11.5 NBREAK=NBREAK+3 * Name. WRITE(AUX(1:13),'(''Ar !'',I3,''%,!'')') - NINT(FRAC(1)*100.0) * Ionisation levels. ECRIT=MIN(15.759,ECRIT) ENDIF *** Methane (CH4). IF(FRAC(2).GT.0.0)THEN * Break points. BREAK(NBREAK+1)=0.3 BREAK(NBREAK+2)=0.36 BREAK(NBREAK+3)=2.0 BREAK(NBREAK+4)=8.0 NBREAK=NBREAK+4 * Name. WRITE(AUX(14:26),'(''CH4 !'',I3,''%,!'')') - NINT(FRAC(2)*100.0) * Ionisation levels. ECRIT=MIN(12.6,ECRIT) ENDIF *** Neon (Ne). IF(FRAC(3).GT.0.0)THEN * Break points. BREAK(NBREAK+1)=7 NBREAK=NBREAK+1 * Name. WRITE(AUX(27:39),'(''Ne !'',I3,''%,!'')') - NINT(FRAC(3)*100.0) * Ionisation levels. ECRIT=MIN(21.564,ECRIT) ENDIF *** Isobutane (C4 H10). IF(FRAC(4).GT.0.0)THEN * Break points. BREAK(NBREAK+1)=0.20 BREAK(NBREAK+2)=0.36 BREAK(NBREAK+3)=0.60 BREAK(NBREAK+4)=8.0 NBREAK=NBREAK+4 * Name. WRITE(AUX(40:52),'(''C4H10 !'',I3,''%,!'')') - NINT(FRAC(4)*100.0) * Ionisation levels (n-C4H10: 10.63 eV, iso: 10.57 eV). ECRIT=MIN(10.6,ECRIT) ENDIF *** CO2. IF(FRAC(5).GT.0.0)THEN * Break points. BREAK(NBREAK+1)=0.20 BREAK(NBREAK+2)=1.32 BREAK(NBREAK+3)=3.25 BREAK(NBREAK+4)=4.2 BREAK(NBREAK+5)=6.0 BREAK(NBREAK+6)=25.0 NBREAK=NBREAK+6 * Name. WRITE(AUX(53:65),'(''CO2 !'',I3,''%,!'')') - NINT(FRAC(5)*100.0) * Ionisation levels. ECRIT=MIN(13.769,ECRIT) ENDIF *** Helium (He). IF(FRAC(6).GT.0.0)THEN * Break points. NBREAK=NBREAK * Name. WRITE(AUX(157:169),'(''He !'',I3,''%,!'')') - NINT(FRAC(6)*100.0) * Ionisation levels. ECRIT=MIN(24.587,ECRIT) ENDIF *** Ethane (C2 H6). IF(FRAC(7).GT.0.0)THEN * Break points. BREAK(NBREAK+1)=0.025 BREAK(NBREAK+2)=0.035 BREAK(NBREAK+3)=0.07 BREAK(NBREAK+4)=0.09 BREAK(NBREAK+5)=0.2 BREAK(NBREAK+6)=0.3 BREAK(NBREAK+7)=0.36 BREAK(NBREAK+8)=0.6 BREAK(NBREAK+9)=1.0 NBREAK=NBREAK+9 * Name. WRITE(AUX(66:78),'(''C2H6 !'',I3,''%,!'')') - NINT(FRAC(7)*100.0) * Ionisation levels. ECRIT=MIN(11.5,ECRIT) ENDIF *** Nitrogen (N). IF(FRAC(8).GT.0.0)THEN * Break points. BREAK(NBREAK+1)=1.3 BREAK(NBREAK+2)=1.4 BREAK(NBREAK+3)=1.5 BREAK(NBREAK+4)=1.6 BREAK(NBREAK+5)=1.7 BREAK(NBREAK+6)=1.8 BREAK(NBREAK+7)=1.9 BREAK(NBREAK+8)=2.0 BREAK(NBREAK+9)=5.0 NBREAK=NBREAK+9 * Name. WRITE(AUX(79:91),'(''N !'',I3,''%,!'')') - NINT(FRAC(8)*100.0) * Ionisation levels. ECRIT=MIN(14.534,ECRIT) ENDIF *** Xenon (Xe). IF(FRAC(9).GT.0.0)THEN * Break points. BREAK(NBREAK+1)=0.01 BREAK(NBREAK+2)=0.035 BREAK(NBREAK+3)=0.1 BREAK(NBREAK+4)=0.18 BREAK(NBREAK+5)=0.5 BREAK(NBREAK+6)=0.7 BREAK(NBREAK+7)=2.0 BREAK(NBREAK+8)=4.1 BREAK(NBREAK+9)=10.0 NBREAK=NBREAK+9 * Name. WRITE(AUX(92:104),'(''Xe !'',I3,''%,!'')') - NINT(FRAC(9)*100.0) * Ionisation levels. ECRIT=MIN(12.130,ECRIT) ENDIF *** Methylal (C3 H8 O2). IF(FRAC(10).GT.0.0)THEN * Break points. BREAK(NBREAK+1)=0.36 BREAK(NBREAK+2)=2.0 BREAK(NBREAK+3)=4.0 NBREAK=NBREAK+3 * Name. WRITE(AUX(105:117),'(''C3H8O2!'',I3,''%,!'')') - NINT(FRAC(10)*100.0) * Ionisation levels (n-C3H7OH: 10.1 eV, iso: 10.15 eV). ECRIT=MIN(10.1,ECRIT) ENDIF *** Krypton. IF(FRAC(11).GT.0.0)THEN * Break points. BREAK(NBREAK+1)=0.01 BREAK(NBREAK+2)=0.02 BREAK(NBREAK+3)=0.04 BREAK(NBREAK+4)=0.07 BREAK(NBREAK+5)=0.1 BREAK(NBREAK+6)=0.145 BREAK(NBREAK+7)=0.2 BREAK(NBREAK+8)=0.3 BREAK(NBREAK+9)=0.4 BREAK(NBREAK+10)=0.5 BREAK(NBREAK+11)=0.6 BREAK(NBREAK+12)=0.8 BREAK(NBREAK+13)=1.0 BREAK(NBREAK+14)=2.0 BREAK(NBREAK+15)=3.0 BREAK(NBREAK+16)=4.0 BREAK(NBREAK+17)=5.0 BREAK(NBREAK+18)=7.0 BREAK(NBREAK+19)=10.0 NBREAK=NBREAK+19 * Name. WRITE(AUX(118:130),'(''Kr !'',I3,''%,!'')') - NINT(FRAC(11)*100.0) * Ionisation levels. ECRIT=MIN(13.999961,ECRIT) ENDIF *** Ammonia. IF(FRAC(12).GT.0.0)THEN * Break points. BREAK(NBREAK+1)=0.01 BREAK(NBREAK+2)=0.02 BREAK(NBREAK+3)=0.04 BREAK(NBREAK+4)=0.1 BREAK(NBREAK+5)=0.2 BREAK(NBREAK+6)=0.4 BREAK(NBREAK+7)=1.0 BREAK(NBREAK+8)=2.0 BREAK(NBREAK+9)=3.0 BREAK(NBREAK+10)=5.0 BREAK(NBREAK+11)=7.0 BREAK(NBREAK+12)=10.0 NBREAK=NBREAK+12 * Name. WRITE(AUX(131:143),'(''NH3 !'',I3,''%,!'')') - NINT(FRAC(12)*100.0) * Ionisation levels. ECRIT=MIN(10.16,ECRIT) ENDIF *** Test gas. IF(FRAC(13).GT.0.0)THEN * Break points. NBREAK=NBREAK * Name. WRITE(AUX(144:156),'(''Test !'',I3,''%,!'')') - NINT(FRAC(13)*100.0) * Ionisation levels. ECRIT=ECRIT ENDIF *** Sort the break points upwards. CALL FLPSOR(BREAK,NBREAK) *** List the break points if debugging has been requested. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GASMXB DEBUG : Number of'', - '' integration break points: '',I3/ - (26X,5(F10.3:)/))') NBREAK,(BREAK(I),I=1,NBREAK) *** Get rid of blanks in the gas name. NOUT=0 DO 10 I=1,169 IF(AUX(I:I).NE.' ')THEN NOUT=NOUT+1 IF(NOUT.LE.80.AND.AUX(I:I).EQ.'!')THEN GASID(NOUT:NOUT)=' ' ELSEIF(NOUT.LE.80)THEN GASID(NOUT:NOUT)=AUX(I:I) ENDIF ENDIF 10 CONTINUE IF(NOUT.GT.80)THEN GASID(78:80)='...' NOUT=80 ELSE GASID(NOUT-1:NOUT)='. ' NOUT=NOUT-1 ENDIF IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GASMXB DEBUG : Name: '', - A)') GASID(1:NOUT) *** Lowest ionisation level. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ GASMXB DEBUG : Lowest'', - '' ionisation level at '',F10.3,'' eV.'')') ECRIT END +DECK,GASMG1. DOUBLE PRECISION FUNCTION GASMG1(F,END,X) *----------------------------------------------------------------------- * GASMG2 - Called by the gas mixing routines for integrations. Breaks * the integration up into steps without discontinuitites so * that Gaussian integration by DGMLT works. * (Last changed on 28/ 9/92.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,GASMIXDATA. DOUBLE PRECISION A,B,END,X(*),DGMLT1 INTEGER I,NPOINT EXTERNAL F,DGMLT1 *** Initial value. GASMG1=0.0D0 DO 10 I=1,MAX(1,NBREAK) IF(BREAK(I).GE.END)RETURN A=BREAK(I) IF(I.GE.NBREAK)THEN B=END ELSE B=MIN(END,DBLE(BREAK(I+1))) ENDIF NPOINT=MAX(1,NINT((B-A)/ESTEP)) GASMG1=GASMG1+DGMLT1(F,A,B,NPOINT,6,X) 10 CONTINUE END +DECK,GASMG2. DOUBLE PRECISION FUNCTION GASMG2(F,END,X) *----------------------------------------------------------------------- * GASMG2 - Called by the gas mixing routines for integrations. Breaks * the integration up into steps without discontinuitites so * that Gaussian integration by DGMLT works. * (Last changed on 28/ 9/92.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,GASMIXDATA. EXTERNAL F,DGMLT2 DOUBLE PRECISION A,B,END,X(*),DGMLT2 *** Initial value. GASMG2=0.0D0 DO 10 I=1,MAX(1,NBREAK) IF(BREAK(I).GE.END)RETURN A=BREAK(I) IF(I.GE.NBREAK)THEN B=END ELSE B=MIN(END,DBLE(BREAK(I+1))) ENDIF NPOINT=MAX(1,NINT((B-A)/ESTEP)) GASMG2=GASMG2+DGMLT2(F,A,B,NPOINT,6,X) 10 CONTINUE END +DECK,GASPLT. SUBROUTINE GASPLT *----------------------------------------------------------------------- * GASPLT - Routine plotting the drift velocity, the diffusion coeff * and the cluster size distribution. * VARIABLES : XPL, YPL : Arrays used for plotting. * (Last changed on 20/ 2/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PARAMETERS. +SEQ,GASDATA. +SEQ,PRINTPLOT. +SEQ,BFIELD. +SEQ,CONSTANTS. REAL XPL(MXLIST),YPL(MXLIST),YPL3(0:MXPAIR+1),YPLMIN,YPLMAX, - GASATT,GASTWN,GASDFL,GASDFT,GASMOB,GASLOR,GASVEL,GASVT1, - GASVT2,EMIN,EMAX,AUX1(1),AUX2(1),DY CHARACTER*20 STR1,STR2,STR3 INTEGER I,J,K,NC1,NC2,NC3 EXTERNAL GASATT,GASTWN,GASDFL,GASDFT,GASMOB,GASLOR,GASVEL, - GASVT1,GASVT2 *** Identify the routine. IF(LIDENT)PRINT *,' /// ROUTINE GASPLT ///' *** Check that logarithmic plotting is possible. IF((GASOK(1).OR.GASOK(2).OR.GASOK(3).OR.GASOK(4).OR. - GASOK(6).OR.GASOK(7).OR.GASOK(8).OR.GASOK(9).OR. - GASOK(10)).AND.EGAS(1).LE.0.0) - PRINT *,' !!!!!! GASPLT WARNING : First point in the gas'// - ' table is not > 0 ; logarithmic plotting impossible' *** Broaden the scale a little to show the extrapolation. IF(NGAS.LT.1)THEN PRINT *,' !!!!!! GASPLT WARNING : No gas data points; '// - ' no plots made.' RETURN ENDIF *** Plot the drift velocity. IF(GASOPT(1,3).AND.(GASOK(1).OR.GASOK(9).OR.GASOK(10)))THEN * Set the electric field range. IF(GASOPT(1,1))THEN EMIN=MAX(1.0,PGAS*EGAS(1)/1.5) EMAX=PGAS*EGAS(NGAS)*1.5 DO 101 I=1,MXLIST XPL(I)=EMIN*(EMAX/EMIN)**(REAL(I-1)/REAL(MXLIST-1)) 101 CONTINUE ELSE EMIN=MAX(0.0,PGAS*(EGAS(1)-ABS(EGAS(NGAS)-EGAS(1))/20)) EMAX=PGAS*(EGAS(NGAS)+ABS(EGAS(NGAS)-EGAS(1))/20) DO 102 I=1,MXLIST XPL(I)=EMIN+REAL(I-1)*(EMAX-EMIN)/REAL(MXLIST-1) 102 CONTINUE ENDIF * Determine the scale of the graph. IF(GASOPT(1,4))THEN YPLMIN=GASRNG(1,1) YPLMAX=GASRNG(1,2) ELSEIF(TAB2D)THEN IF(GASOK(1))THEN YPLMIN=VGAS2(1,1,1) YPLMAX=VGAS2(1,1,1) ELSEIF(GASOK(9))THEN YPLMIN=XGAS2(1,1,1) YPLMAX=XGAS2(1,1,1) ELSE YPLMIN=YGAS2(1,1,1) YPLMAX=YGAS2(1,1,1) ENDIF DO 100 K=1,NBTAB DO 110 I=1,NGAS DO 120 J=1,NBANG IF(GASOK(1))THEN YPLMIN=MIN(YPLMIN,VGAS2(I,J,K)) YPLMAX=MAX(YPLMAX,VGAS2(I,J,K)) ENDIF IF(GASOK(9))THEN YPLMIN=MIN(YPLMIN,XGAS2(I,J,K)) YPLMAX=MAX(YPLMAX,XGAS2(I,J,K)) ENDIF IF(GASOK(10))THEN YPLMIN=MIN(YPLMIN,YGAS2(I,J,K)) YPLMAX=MAX(YPLMAX,YGAS2(I,J,K)) ENDIF 120 CONTINUE 110 CONTINUE 100 CONTINUE DY=(YPLMAX-YPLMIN)/20 YPLMAX=YPLMAX+DY YPLMIN=YPLMIN-DY ELSE IF(GASOK(1))THEN YPLMIN=VGAS(1) YPLMAX=VGAS(1) ELSEIF(GASOK(9))THEN YPLMIN=XGAS(1) YPLMAX=XGAS(1) ELSE YPLMIN=YGAS(1) YPLMAX=YGAS(1) ENDIF DO 130 I=1,NGAS IF(GASOK(1))THEN YPLMIN=MIN(YPLMIN,VGAS(I)) YPLMAX=MAX(YPLMAX,VGAS(I)) ENDIF IF(GASOK(9))THEN YPLMIN=MIN(YPLMIN,XGAS(I)) YPLMAX=MAX(YPLMAX,XGAS(I)) ENDIF IF(GASOK(10))THEN YPLMIN=MIN(YPLMIN,YGAS(I)) YPLMAX=MAX(YPLMAX,YGAS(I)) ENDIF 130 CONTINUE DY=(YPLMAX-YPLMIN)/20 YPLMAX=YPLMAX+DY YPLMIN=YPLMIN-DY ENDIF * Can be that the range is still nil or negative and log. IF(YPLMAX.LE.0)THEN PRINT *,' !!!!!! GASPLT WARNING : Drift velocity'// - ' is zero everywhere ; not plotted.' GOTO 199 ENDIF IF(GASOPT(1,2))THEN IF(YPLMIN.LE.0)YPLMIN=1 IF(YPLMAX.LE.YPLMIN)YPLMAX=100 ELSE IF(YPLMIN.GT.0)YPLMIN=0 IF(YPLMAX.LE.YPLMIN)YPLMAX=100 ENDIF * Loop over the B fields. DO 140 K=1,NBTAB * Plot the frame. IF(GASOPT(1,1))THEN CALL GRAOPT('LOG-X') ELSE CALL GRAOPT('LIN-X') ENDIF IF(GASOPT(1,2))THEN CALL GRAOPT('LOG-Y') ELSE CALL GRAOPT('LIN-Y') ENDIF CALL GRCART(EMIN,YPLMIN,EMAX,YPLMAX, - 'E [V/cm]','Drift velocity [cm/microsec]', - 'Drift velocity vs E') IF(GASID.NE.' ')CALL GRCOMM(1,'Gas: '//GASID) IF(TAB2D)THEN CALL OUTFMT(BTAB(K)/100,2,STR1,NC1,'LEFT') CALL GRCOMM(2,'B = '//STR1(1:NC1)//' T') CALL OUTFMT(180*BANG(1)/PI,2,STR1,NC1,'LEFT') CALL OUTFMT(180*BANG(NBANG)/PI,2,STR2,NC2,'LEFT') CALL OUTFMT(REAL(NBANG),2,STR3,NC3,'LEFT') CALL GRCOMM(4,STR1(1:NC1)//' < angle(E,B) < '// - STR2(1:NC2)//' degrees in '//STR3(1:NC3)// - ' steps') ENDIF * Plot and mark the various curves, first the E component. IF(GASOK(1))THEN CALL GRATTS('FUNCTION-1','POLYLINE') IF(TAB2D)THEN DO 150 I=1,NBANG DO 160 J=1,MXLIST YPL(J)=GASVEL(XPL(J),0.0,0.0,BTAB(K)*COS(BANG(I)), - BTAB(K)*SIN(BANG(I)),0.0) 160 CONTINUE CALL GRLINE(MXLIST,XPL,YPL) 150 CONTINUE ELSE DO 170 I=1,MXLIST YPL(I)=GASVEL(XPL(I),0.0,0.0,0.0,0.0,0.0) 170 CONTINUE CALL GRLINE(MXLIST,XPL,YPL) ENDIF CALL GRATTS('FUNCTION-1','POLYMARKER') DO 190 J=1,NGAS AUX1(1)=PGAS*EGAS(J) IF(TAB2D)THEN DO 180 I=1,NBANG AUX2(1)=VGAS2(J,I,K) CALL GRMARK(1,AUX1,AUX2) 180 CONTINUE ELSE AUX2(1)=VGAS(J) CALL GRMARK(1,AUX1,AUX2) ENDIF 190 CONTINUE ENDIF * Next the B component. IF(GASOK(9))THEN CALL GRATTS('FUNCTION-2','POLYLINE') IF(TAB2D)THEN DO 151 I=1,NBANG DO 161 J=1,MXLIST YPL(J)=GASVT1(XPL(J),0.0,0.0,BTAB(K)*COS(BANG(I)), - BTAB(K)*SIN(BANG(I)),0.0) 161 CONTINUE CALL GRLINE(MXLIST,XPL,YPL) 151 CONTINUE ELSE DO 171 I=1,MXLIST YPL(I)=GASVT1(XPL(I),0.0,0.0,0.0,0.0,0.0) 171 CONTINUE CALL GRLINE(MXLIST,XPL,YPL) ENDIF CALL GRATTS('FUNCTION-2','POLYMARKER') DO 191 J=1,NGAS AUX1(1)=PGAS*EGAS(J) IF(TAB2D)THEN DO 181 I=1,NBANG AUX2(1)=XGAS2(J,I,K) CALL GRMARK(1,AUX1,AUX2) 181 CONTINUE ELSE AUX2(1)=XGAS(J) CALL GRMARK(1,AUX1,AUX2) ENDIF 191 CONTINUE ENDIF * And finally the ExB component. IF(GASOK(10))THEN CALL GRATTS('FUNCTION-3','POLYLINE') IF(TAB2D)THEN DO 152 I=1,NBANG DO 162 J=1,MXLIST YPL(J)=GASVT2(XPL(J),0.0,0.0,BTAB(K)*COS(BANG(I)), - BTAB(K)*SIN(BANG(I)),0.0) 162 CONTINUE CALL GRLINE(MXLIST,XPL,YPL) 152 CONTINUE ELSE DO 172 I=1,MXLIST YPL(I)=GASVT2(XPL(I),0.0,0.0,0.0,0.0,0.0) 172 CONTINUE CALL GRLINE(MXLIST,XPL,YPL) ENDIF CALL GRATTS('FUNCTION-3','POLYMARKER') DO 192 J=1,NGAS AUX1(1)=PGAS*EGAS(J) IF(TAB2D)THEN DO 182 I=1,NBANG AUX2(1)=YGAS2(J,I,K) CALL GRMARK(1,AUX1,AUX2) 182 CONTINUE ELSE AUX2(1)=YGAS(J) CALL GRMARK(1,AUX1,AUX2) ENDIF 192 CONTINUE ENDIF CALL GRNEXT CALL GRALOG('Graph of the drift velocity vs E.') * Next B field. 140 CONTINUE ENDIF * Continue here if the plot was skipped. 199 CONTINUE *** Plot the ion mobility. IF(GASOPT(2,3).AND.GASOK(2))THEN * Set the electric field range. IF(GASOPT(2,1))THEN EMIN=MAX(1.0,PGAS*EGAS(1)/1.5) EMAX=PGAS*EGAS(NGAS)*1.5 DO 201 I=1,MXLIST XPL(I)=EMIN*(EMAX/EMIN)**(REAL(I-1)/REAL(MXLIST-1)) 201 CONTINUE ELSE EMIN=MAX(0.0,PGAS*(EGAS(1)-ABS(EGAS(NGAS)-EGAS(1))/20)) EMAX=PGAS*(EGAS(NGAS)+ABS(EGAS(NGAS)-EGAS(1))/20) DO 202 I=1,MXLIST XPL(I)=EMIN+REAL(I-1)*(EMAX-EMIN)/REAL(MXLIST-1) 202 CONTINUE ENDIF * Determine the scale of the graph. IF(GASOPT(2,4))THEN YPLMIN=GASRNG(2,1) YPLMAX=GASRNG(2,2) ELSEIF(TAB2D)THEN YPLMIN=MGAS2(1,1,1) YPLMAX=MGAS2(1,1,1) DO 200 K=1,NBTAB DO 210 I=1,NGAS DO 220 J=1,NBANG YPLMIN=MIN(YPLMIN,MGAS2(I,J,K)) YPLMAX=MAX(YPLMAX,MGAS2(I,J,K)) 220 CONTINUE 210 CONTINUE 200 CONTINUE DY=(YPLMAX-YPLMIN)/20 YPLMAX=YPLMAX+DY YPLMIN=YPLMIN-DY ELSE YPLMIN=MGAS(1) YPLMAX=MGAS(1) DO 230 I=2,NGAS YPLMIN=MIN(YPLMIN,MGAS(I)) YPLMAX=MAX(YPLMAX,MGAS(I)) 230 CONTINUE DY=(YPLMAX-YPLMIN)/20 YPLMAX=YPLMAX+DY YPLMIN=YPLMIN-DY ENDIF * Loop over the B fields. DO 240 K=1,NBTAB * Plot the frame. IF(GASOPT(2,1))THEN CALL GRAOPT('LOG-X') ELSE CALL GRAOPT('LIN-X') ENDIF IF(GASOPT(2,2))THEN CALL GRAOPT('LOG-Y') ELSE CALL GRAOPT('LIN-Y') ENDIF CALL GRCART(EMIN,YPLMIN,EMAX,YPLMAX, - 'E [V/cm]','Ion mobility [cm2/V.microsec]', - 'Ion mobility vs E') IF(GASID.NE.' ')CALL GRCOMM(1,'Gas: '//GASID) IF(TAB2D)THEN CALL OUTFMT(BTAB(K)/100,2,STR1,NC1,'LEFT') CALL GRCOMM(2,'B = '//STR1(1:NC1)//' T') CALL OUTFMT(180*BANG(1)/PI,2,STR1,NC1,'LEFT') CALL OUTFMT(180*BANG(NBANG)/PI,2,STR2,NC2,'LEFT') CALL OUTFMT(REAL(NBANG),2,STR3,NC3,'LEFT') CALL GRCOMM(4,STR1(1:NC1)//' < angle(E,B) < '// - STR2(1:NC2)//' degrees in '//STR3(1:NC3)// - ' steps') ENDIF * Plot the various curves. CALL GRATTS('FUNCTION-1','POLYLINE') IF(TAB2D)THEN DO 250 I=1,NBANG DO 260 J=1,MXLIST YPL(J)=GASMOB(XPL(J),0.0,0.0,BTAB(K)*COS(BANG(I)), - BTAB(K)*SIN(BANG(I)),0.0) 260 CONTINUE CALL GRLINE(MXLIST,XPL,YPL) 250 CONTINUE ELSE DO 270 I=1,MXLIST YPL(I)=GASMOB(XPL(I),0.0,0.0,0.0,0.0,0.0) 270 CONTINUE CALL GRLINE(MXLIST,XPL,YPL) ENDIF * Polymark the data, allowing a check on the interpolation. CALL GRATTS('FUNCTION-1','POLYMARKER') DO 290 J=1,NGAS AUX1(1)=PGAS*EGAS(J) IF(TAB2D)THEN DO 280 I=1,NBANG CALL GRMARK(1,AUX1,MGAS2(J,I,K)) 280 CONTINUE ELSE CALL GRMARK(1,AUX1,MGAS(J)) ENDIF 290 CONTINUE CALL GRNEXT CALL GRALOG('Graph of the ion mobility vs E.') * Next B field. 240 CONTINUE ENDIF *** Plot the diffusion coefficients. IF(GASOPT(3,3).AND.(GASOK(3).OR.GASOK(8)))THEN * Set the electric field range. IF(GASOPT(3,1))THEN EMIN=MAX(1.0,PGAS*EGAS(1)/1.5) EMAX=PGAS*EGAS(NGAS)*1.5 DO 301 I=1,MXLIST XPL(I)=EMIN*(EMAX/EMIN)**(REAL(I-1)/REAL(MXLIST-1)) 301 CONTINUE ELSE EMIN=MAX(0.0,PGAS*(EGAS(1)-ABS(EGAS(NGAS)-EGAS(1))/20)) EMAX=PGAS*(EGAS(NGAS)+ABS(EGAS(NGAS)-EGAS(1))/20) DO 302 I=1,MXLIST XPL(I)=EMIN+REAL(I-1)*(EMAX-EMIN)/REAL(MXLIST-1) 302 CONTINUE ENDIF * Determine the scale of the graph. IF(GASOPT(3,4))THEN YPLMIN=GASRNG(3,1) YPLMAX=GASRNG(3,2) ELSEIF(TAB2D)THEN IF(GASOK(3))THEN YPLMIN=DGAS2(1,1,1)*10000/SQRT(PGAS) YPLMAX=DGAS2(1,1,1)*10000/SQRT(PGAS) ELSE YPLMIN=OGAS2(1,1,1)*10000/SQRT(PGAS) YPLMAX=OGAS2(1,1,1)*10000/SQRT(PGAS) ENDIF DO 300 K=1,NBTAB DO 310 I=1,NGAS DO 320 J=1,NBANG IF(GASOK(3))THEN YPLMIN=MIN(YPLMIN,DGAS2(I,J,K)*10000/SQRT(PGAS)) YPLMAX=MAX(YPLMAX,DGAS2(I,J,K)*10000/SQRT(PGAS)) ENDIF IF(GASOK(8))THEN YPLMIN=MIN(YPLMIN,OGAS2(I,J,K)*10000/SQRT(PGAS)) YPLMAX=MAX(YPLMAX,OGAS2(I,J,K)*10000/SQRT(PGAS)) ENDIF 320 CONTINUE 310 CONTINUE 300 CONTINUE DY=(YPLMAX-YPLMIN)/20 YPLMAX=YPLMAX+DY YPLMIN=YPLMIN-DY ELSE IF(GASOK(3))THEN YPLMIN=DGAS(1)*10000/SQRT(PGAS) YPLMAX=DGAS(1)*10000/SQRT(PGAS) ELSE YPLMIN=OGAS(1) YPLMAX=OGAS(1) ENDIF DO 330 I=1,NGAS IF(GASOK(3))THEN YPLMIN=MIN(YPLMIN,DGAS(I)*10000/SQRT(PGAS)) YPLMAX=MAX(YPLMAX,DGAS(I)*10000/SQRT(PGAS)) ENDIF IF(GASOK(8))THEN YPLMIN=MIN(YPLMIN,OGAS(I)*10000/SQRT(PGAS)) YPLMAX=MAX(YPLMAX,OGAS(I)*10000/SQRT(PGAS)) ENDIF 330 CONTINUE DY=(YPLMAX-YPLMIN)/20 YPLMAX=YPLMAX+DY YPLMIN=YPLMIN-DY ENDIF * Can be that the range is still nil or negative and log. IF(YPLMAX.LE.0)THEN PRINT *,' !!!!!! GASPLT WARNING : Diffusion'// - ' coefficients = 0 ; not plotted.' GOTO 399 ENDIF IF(GASOPT(3,2))THEN IF(YPLMIN.LE.0)YPLMIN=1 IF(YPLMAX.LE.YPLMIN)YPLMAX=1000 ELSE YPLMIN=0 IF(YPLMAX.LE.YPLMIN)YPLMAX=1000 ENDIF * Loop over the B fields. DO 340 K=1,NBTAB * Plot the frame. IF(GASOPT(3,1))THEN CALL GRAOPT('LOG-X') ELSE CALL GRAOPT('LIN-X') ENDIF IF(GASOPT(3,2))THEN CALL GRAOPT('LOG-Y') ELSE CALL GRAOPT('LIN-Y') ENDIF CALL GRCART(EMIN,YPLMIN,EMAX,YPLMAX, - 'E [V/cm]','Diffusion [micron for 1 cm]', - 'Diffusion coefficients vs E') IF(GASID.NE.' ')CALL GRCOMM(1,'Gas: '//GASID) IF(TAB2D)THEN CALL OUTFMT(BTAB(K)/100,2,STR1,NC1,'LEFT') CALL GRCOMM(2,'B = '//STR1(1:NC1)//' T') CALL OUTFMT(180*BANG(1)/PI,2,STR1,NC1,'LEFT') CALL OUTFMT(180*BANG(NBANG)/PI,2,STR2,NC2,'LEFT') CALL OUTFMT(REAL(NBANG),2,STR3,NC3,'LEFT') CALL GRCOMM(4,STR1(1:NC1)//' < angle(E,B) < '// - STR2(1:NC2)//' degrees in '//STR3(1:NC3)// - ' steps') ENDIF * Plot and mark the various curves. IF(GASOK(3))THEN CALL GRATTS('FUNCTION-1','POLYLINE') IF(TAB2D)THEN DO 350 I=1,NBANG DO 360 J=1,MXLIST YPL(J)=10000*GASDFL(XPL(J),0.0,0.0, - BTAB(K)*COS(BANG(I)), - BTAB(K)*SIN(BANG(I)),0.0) 360 CONTINUE CALL GRLINE(MXLIST,XPL,YPL) 350 CONTINUE ELSE DO 370 I=1,MXLIST YPL(I)=10000*GASDFL(XPL(I),0.0,0.0,0.0,0.0,0.0) 370 CONTINUE CALL GRLINE(MXLIST,XPL,YPL) ENDIF CALL GRATTS('FUNCTION-1','POLYMARKER') DO 390 J=1,NGAS AUX1(1)=PGAS*EGAS(J) IF(TAB2D)THEN DO 380 I=1,NBANG AUX2(1)=10000*DGAS2(J,I,K)/SQRT(PGAS) CALL GRMARK(1,AUX1,AUX2) 380 CONTINUE ELSE AUX2(1)=10000*DGAS(J)/SQRT(PGAS) CALL GRMARK(1,AUX1,AUX2) ENDIF 390 CONTINUE ENDIF IF(GASOK(8))THEN CALL GRATTS('FUNCTION-2','POLYLINE') IF(TAB2D)THEN DO 355 I=1,NBANG DO 365 J=1,MXLIST YPL(J)=10000*GASDFT(XPL(J),0.0,0.0, - BTAB(K)*COS(BANG(I)), - BTAB(K)*SIN(BANG(I)),0.0) 365 CONTINUE CALL GRLINE(MXLIST,XPL,YPL) 355 CONTINUE ELSE DO 375 I=1,MXLIST YPL(I)=10000*GASDFT(XPL(I),0.0,0.0,0.0,0.0,0.0) 375 CONTINUE CALL GRLINE(MXLIST,XPL,YPL) ENDIF CALL GRATTS('FUNCTION-2','POLYMARKER') DO 395 J=1,NGAS AUX1(1)=PGAS*EGAS(J) IF(TAB2D)THEN DO 385 I=1,NBANG AUX2(1)=10000*OGAS2(J,I,K)/SQRT(PGAS) CALL GRMARK(1,AUX1,AUX2) 385 CONTINUE ELSE AUX2(1)=10000*OGAS(J)/SQRT(PGAS) CALL GRMARK(1,AUX1,AUX2) ENDIF 395 CONTINUE ENDIF CALL GRNEXT CALL GRALOG('Graph of the diffusion coefficients vs E.') * Next B field. 340 CONTINUE ENDIF * Continue here if the plot was skipped. 399 CONTINUE *** Plot the Townsend and attachment coefficients. IF(GASOPT(4,3).AND.(GASOK(4).OR.GASOK(6)))THEN * Set the electric field range. IF(GASOPT(4,1))THEN EMIN=MAX(1.0,PGAS*EGAS(1)/1.5) EMAX=PGAS*EGAS(NGAS)*1.5 DO 401 I=1,MXLIST XPL(I)=EMIN*(EMAX/EMIN)**(REAL(I-1)/REAL(MXLIST-1)) 401 CONTINUE ELSE EMIN=MAX(0.0,PGAS*(EGAS(1)-ABS(EGAS(NGAS)-EGAS(1))/20)) EMAX=PGAS*(EGAS(NGAS)+ABS(EGAS(NGAS)-EGAS(1))/20) DO 402 I=1,MXLIST XPL(I)=EMIN+REAL(I-1)*(EMAX-EMIN)/REAL(MXLIST-1) 402 CONTINUE ENDIF * Determine the scale of the graph. IF(GASOPT(4,4))THEN YPLMIN=GASRNG(4,1) YPLMAX=GASRNG(4,2) ELSEIF(TAB2D)THEN IF(GASOK(4))THEN YPLMIN=EXP(AGAS2(1,1,1))*PGAS YPLMAX=EXP(AGAS2(1,1,1))*PGAS ELSE YPLMIN=EXP(BGAS2(1,1,1))*PGAS YPLMAX=EXP(BGAS2(1,1,1))*PGAS ENDIF DO 400 K=1,NBTAB DO 410 I=1,NGAS DO 420 J=1,NBANG IF(GASOK(4))THEN YPLMIN=MIN(YPLMIN,EXP(AGAS2(I,J,K))*PGAS) YPLMAX=MAX(YPLMAX,EXP(AGAS2(I,J,K))*PGAS) ENDIF IF(GASOK(6))THEN YPLMIN=MIN(YPLMIN,EXP(BGAS2(I,J,K))*PGAS) YPLMAX=MAX(YPLMAX,EXP(BGAS2(I,J,K))*PGAS) ENDIF 420 CONTINUE 410 CONTINUE 400 CONTINUE DY=(YPLMAX-YPLMIN)/20 YPLMAX=YPLMAX+DY YPLMIN=YPLMIN-DY ELSE IF(GASOK(4))THEN YPLMIN=EXP(AGAS(1))*PGAS YPLMAX=EXP(AGAS(1))*PGAS ELSE YPLMIN=EXP(BGAS(1))*PGAS YPLMAX=EXP(BGAS(1))*PGAS ENDIF DO 430 I=1,NGAS IF(GASOK(4))THEN YPLMIN=MIN(YPLMIN,EXP(AGAS(I))*PGAS) YPLMAX=MAX(YPLMAX,EXP(AGAS(I))*PGAS) ENDIF IF(GASOK(6))THEN YPLMIN=MIN(YPLMIN,EXP(BGAS(I))*PGAS) YPLMAX=MAX(YPLMAX,EXP(BGAS(I))*PGAS) ENDIF 430 CONTINUE DY=(YPLMAX-YPLMIN)/20 YPLMAX=YPLMAX+DY YPLMIN=YPLMIN-DY ENDIF * Can be that the range is still nil or negative and log. IF(YPLMAX.LE.-20)THEN PRINT *,' !!!!!! GASPLT WARNING : Townsend and'// - ' attachment coefficients = 0 ; not plotted.' GOTO 499 ENDIF IF(GASOPT(4,2))THEN IF(YPLMIN.LE.0.01)YPLMIN=0.01 IF(YPLMAX.LE.YPLMIN)YPLMAX=YPLMIN*2 ELSE YPLMIN=0 IF(YPLMAX.LE.YPLMIN)YPLMAX=1000 ENDIF * Loop over the B fields. DO 440 K=1,NBTAB * Plot the frame. IF(GASOPT(4,1))THEN CALL GRAOPT('LOG-X') ELSE CALL GRAOPT('LIN-X') ENDIF IF(GASOPT(4,2))THEN CALL GRAOPT('LOG-Y') ELSE CALL GRAOPT('LIN-Y') ENDIF CALL GRCART(EMIN,YPLMIN,EMAX,YPLMAX, - 'E [V/cm]','Townsend and attachment coeff. [1/cm]', - 'Townsend and attachment coeff. vs E') IF(GASID.NE.' ')CALL GRCOMM(1,'Gas: '//GASID) IF(TAB2D)THEN CALL OUTFMT(BTAB(K)/100,2,STR1,NC1,'LEFT') CALL GRCOMM(2,'B = '//STR1(1:NC1)//' T') CALL OUTFMT(180*BANG(1)/PI,2,STR1,NC1,'LEFT') CALL OUTFMT(180*BANG(NBANG)/PI,2,STR2,NC2,'LEFT') CALL OUTFMT(REAL(NBANG),2,STR3,NC3,'LEFT') CALL GRCOMM(4,STR1(1:NC1)//' < angle(E,B) < '// - STR2(1:NC2)//' degrees in '//STR3(1:NC3)// - ' steps') ENDIF * Plot and mark the various curves. IF(GASOK(4))THEN CALL GRATTS('FUNCTION-1','POLYLINE') IF(TAB2D)THEN DO 450 I=1,NBANG DO 460 J=1,MXLIST YPL(J)=GASTWN(XPL(J),0.0,0.0, - BTAB(K)*COS(BANG(I)), - BTAB(K)*SIN(BANG(I)),0.0) 460 CONTINUE CALL GRLINE(MXLIST,XPL,YPL) 450 CONTINUE ELSE DO 470 I=1,MXLIST YPL(I)=GASTWN(XPL(I),0.0,0.0,0.0,0.0,0.0) 470 CONTINUE CALL GRLINE(MXLIST,XPL,YPL) ENDIF CALL GRATTS('FUNCTION-1','POLYMARKER') DO 490 J=1,NGAS AUX1(1)=PGAS*EGAS(J) IF(TAB2D)THEN DO 480 I=1,NBANG AUX2(1)=EXP(AGAS2(J,I,K))*PGAS CALL GRMARK(1,AUX1,AUX2) 480 CONTINUE ELSE AUX2(1)=EXP(AGAS(J))*PGAS CALL GRMARK(1,AUX1,AUX2) ENDIF 490 CONTINUE ENDIF IF(GASOK(6))THEN CALL GRATTS('FUNCTION-2','POLYLINE') IF(TAB2D)THEN DO 455 I=1,NBANG DO 465 J=1,MXLIST YPL(J)=GASATT(XPL(J),0.0,0.0, - BTAB(K)*COS(BANG(I)), - BTAB(K)*SIN(BANG(I)),0.0) 465 CONTINUE CALL GRLINE(MXLIST,XPL,YPL) 455 CONTINUE ELSE DO 475 I=1,MXLIST YPL(I)=GASATT(XPL(I),0.0,0.0,0.0,0.0,0.0) 475 CONTINUE CALL GRLINE(MXLIST,XPL,YPL) ENDIF CALL GRATTS('FUNCTION-2','POLYMARKER') DO 495 J=1,NGAS AUX1(1)=PGAS*EGAS(J) IF(TAB2D)THEN DO 485 I=1,NBANG AUX2(1)=EXP(BGAS2(J,I,K))*PGAS CALL GRMARK(1,AUX1,AUX2) 485 CONTINUE ELSE AUX2(1)=EXP(BGAS(J))*PGAS CALL GRMARK(1,AUX1,AUX2) ENDIF 495 CONTINUE ENDIF CALL GRNEXT CALL GRALOG('Graph of the Townsend and att. coeff.') * Next B field. 440 CONTINUE ENDIF * Continue here if the plot was skipped. 499 CONTINUE *** Plot the Lorentz angle. IF(GASOPT(7,3).AND.GASOK(7))THEN * Set the electric field range. IF(GASOPT(7,1))THEN EMIN=MAX(1.0,PGAS*EGAS(1)/1.5) EMAX=PGAS*EGAS(NGAS)*1.5 DO 501 I=1,MXLIST XPL(I)=EMIN*(EMAX/EMIN)**(REAL(I-1)/REAL(MXLIST-1)) 501 CONTINUE ELSE EMIN=MAX(0.0,PGAS*(EGAS(1)-ABS(EGAS(NGAS)-EGAS(1))/20)) EMAX=PGAS*(EGAS(NGAS)+ABS(EGAS(NGAS)-EGAS(1))/20) DO 502 I=1,MXLIST XPL(I)=EMIN+REAL(I-1)*(EMAX-EMIN)/REAL(MXLIST-1) 502 CONTINUE ENDIF * Determine the scale of the graph. IF(GASOPT(7,4))THEN YPLMIN=180*GASRNG(7,1)/PI YPLMAX=180*GASRNG(7,2)/PI ELSEIF(TAB2D)THEN YPLMIN=180*WGAS2(1,1,1)/PI YPLMAX=180*WGAS2(1,1,1)/PI DO 500 K=1,NBTAB DO 510 I=1,NGAS DO 520 J=1,NBANG YPLMIN=MIN(YPLMIN,180*WGAS2(I,J,K)/PI) YPLMAX=MAX(YPLMAX,180*WGAS2(I,J,K)/PI) 520 CONTINUE 510 CONTINUE 500 CONTINUE DY=(YPLMAX-YPLMIN)/20 YPLMAX=YPLMAX+DY YPLMIN=YPLMIN-DY ELSE YPLMIN=180*WGAS(1)/PI YPLMAX=180*WGAS(1)/PI DO 530 I=2,NGAS YPLMIN=MIN(YPLMIN,180*WGAS(I)/PI) YPLMAX=MAX(YPLMAX,180*WGAS(I)/PI) 530 CONTINUE DY=(YPLMAX-YPLMIN)/20 YPLMAX=YPLMAX+DY YPLMIN=YPLMIN-DY ENDIF * Loop over the B fields. DO 540 K=1,NBTAB * Plot the frame. IF(GASOPT(7,1))THEN CALL GRAOPT('LOG-X') ELSE CALL GRAOPT('LIN-X') ENDIF IF(GASOPT(7,2))THEN CALL GRAOPT('LOG-Y') ELSE CALL GRAOPT('LIN-Y') ENDIF CALL GRCART(EMIN,YPLMIN,EMAX,YPLMAX, - 'E [V/cm]','Angle between v and E [degrees]', - 'Angle between v and E vs E') IF(GASID.NE.' ')CALL GRCOMM(1,'Gas: '//GASID) IF(TAB2D)THEN CALL OUTFMT(BTAB(K)/100,2,STR1,NC1,'LEFT') CALL GRCOMM(2,'B = '//STR1(1:NC1)//' T') CALL OUTFMT(180*BANG(1)/PI,2,STR1,NC1,'LEFT') CALL OUTFMT(180*BANG(NBANG)/PI,2,STR2,NC2,'LEFT') CALL OUTFMT(REAL(NBANG),2,STR3,NC3,'LEFT') CALL GRCOMM(4,STR1(1:NC1)//' < angle(E,B) < '// - STR2(1:NC2)//' degress in '//STR3(1:NC3)// - ' steps') ENDIF * Plot the various curves. CALL GRATTS('FUNCTION-1','POLYLINE') IF(TAB2D)THEN DO 550 I=1,NBANG DO 560 J=1,MXLIST YPL(J)=180*GASLOR(XPL(J),0.0,0.0,BTAB(K)*COS(BANG(I)), - BTAB(K)*SIN(BANG(I)),0.0)/PI 560 CONTINUE CALL GRLINE(MXLIST,XPL,YPL) 550 CONTINUE ELSE DO 570 I=1,MXLIST YPL(I)=180*GASLOR(XPL(I),0.0,0.0,0.0,0.0,0.0)/PI 570 CONTINUE CALL GRLINE(MXLIST,XPL,YPL) ENDIF * Polymark the data, allowing a check on the interpolation. CALL GRATTS('FUNCTION-1','POLYMARKER') DO 590 J=1,NGAS AUX1(1)=PGAS*EGAS(J) IF(TAB2D)THEN DO 580 I=1,NBANG AUX2(1)=180*WGAS2(J,I,K)/PI CALL GRMARK(1,AUX1,AUX2) 580 CONTINUE ELSE AUX2(1)=180*WGAS(J)/PI CALL GRMARK(1,AUX1,AUX2) ENDIF 590 CONTINUE CALL GRNEXT CALL GRALOG('Graph of the (v,E) angle vs E.') * Next B field. 540 CONTINUE ENDIF *** Cluster size distribution. IF(GASOPT(5,3).AND.GASOK(5))THEN * Set log or linear axes, as requested. IF(GASOPT(5,1))THEN CALL GRAOPT('LOG-X') ELSE CALL GRAOPT('LIN-X') ENDIF IF(GASOPT(5,2))THEN CALL GRAOPT('LOG-Y') ELSE CALL GRAOPT('LIN-Y') ENDIF * Recover the cluster size distribution. YPL3(0)=0 DO 60 I=1,MIN(MXPAIR,NCLS) IF(I.EQ.1)THEN YPL3(I)=CLSDIS(I) ELSE YPL3(I)=CLSDIS(I)-CLSDIS(I-1) ENDIF 60 CONTINUE YPL3(MIN(NCLS,MXPAIR)+1)=0 * Plot the histogram. CALL GRHIST(YPL3,MIN(MXPAIR,NCLS), - 0.0,REAL(MIN(MXPAIR,NCLS)), - 'Number of pairs in a cluster', - 'Cluster size distribution',.TRUE.) * Add a bit of information to the plot. IF(GASID.NE.' ')CALL GRCOMM(1,'Gas: '//GASID) CALL GRCOMM(2,'Origin: '//CLSTYP) CALL GRALOG('Graph of the cluster size distribution ') CALL GRNEXT ENDIF *** Restore the axes. CALL GRAOPT('LINEAR-X') CALL GRAOPT('LINEAR-Y') *** Call TIMLOG to register the amount of CPU time used. CALL TIMLOG('Making various gas plots: ') END +DECK,GASPRE. SUBROUTINE GASPRE(IFAIL) *----------------------------------------------------------------------- * GASPRE - Prepares the gas data for further use by other routines. * VARIABLES : IFAIL : 1 if routine failed 0 if succesful * (Last changed on 17/ 2/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,GASDATA. +SEQ,PRINTPLOT. DOUBLE PRECISION CLSSUM REAL DENLAN CHARACTER*20 AUX1 INTEGER I,J,K,N,IFAIL,NFAIL,NC1 LOGICAL OK EXTERNAL DENLAN *** Identify the routine if requested. IF(LIDENT)PRINT *,' /// ROUTINE GASPRE ///' *** For the time being assume this will work. IFAIL=0 OK=.TRUE. *** Drift velocity preparation, start with a table of 1 point. IF(GASOK(1).AND.NGAS.LE.1.AND..NOT.TAB2D)THEN IF(IVEXTR.NE.0.OR.JVEXTR.NE.0)THEN PRINT *,' !!!!!! GASPRE WARNING : For a 1-point'// - ' table, only constant extrapolation is valid.' IVEXTR=0 JVEXTR=0 OK=.FALSE. ENDIF * Calculate the spline coefficients for the drift speed, ELSEIF(GASOK(1).AND..NOT.TAB2D)THEN CALL SPLINE(EGAS,VGAS,CVGAS,NGAS,IFAIL) IF(IFAIL.EQ.1)THEN PRINT *,' !!!!!! GASPRE WARNING : The drift velocity'// - ' data can not be interpolated; data deleted.' GASOK(1)=.FALSE. OK=.FALSE. ENDIF * Calculate the H extrapolation parameters, using the last 2 points. IF(VGAS(NGAS).LE.0.OR.(IVEXTR.NE.1.AND.IVEXTR.NE.2))THEN VEXTR1=0.0 VEXTR2=0.0 ELSEIF(EGAS(NGAS).LE.EGAS(NGAS-1))THEN PRINT *,' !!!!!! GASPRE WARNING : Last 2 E/p values'// - ' coincide; no v extrapolation to higher E/p.' IVEXTR=0 OK=.FALSE. ELSEIF(IVEXTR.EQ.1)THEN VEXTR2=(VGAS(NGAS)-VGAS(NGAS-1))/ - (EGAS(NGAS)-EGAS(NGAS-1)) VEXTR1=VGAS(NGAS)-VEXTR2*EGAS(NGAS) IF(VEXTR2.LT.0.0)THEN CALL OUTFMT(-PGAS*VEXTR1/VEXTR2,2,AUX1,NC1,'LEFT') PRINT *,' ------ GASPRE MESSAGE : The linear'// - ' extrapolation of the drift velocity is'// - ' negative for E > '//AUX1(1:NC1)//' V/cm.' ENDIF ELSEIF(IVEXTR.EQ.2)THEN VEXTR2=LOG(VGAS(NGAS)/VGAS(NGAS-1))/ - (EGAS(NGAS)-EGAS(NGAS-1)) VEXTR1=LOG(VGAS(NGAS))-VEXTR2*EGAS(NGAS) ENDIF * Calculate the L extrapolation parameters, using the last 2 points. IF(VGAS(1).LE.0.OR.(JVEXTR.NE.1.AND.JVEXTR.NE.2))THEN VEXTR3=0.0 VEXTR4=0.0 ELSEIF(EGAS(2).LE.EGAS(1))THEN PRINT *,' !!!!!! GASPRE WARNING : First 2 E/p values'// - ' coincide; no v extrapolation to lower E/p.' JVEXTR=0 OK=.FALSE. ELSEIF(JVEXTR.EQ.1)THEN VEXTR4=(VGAS(2)-VGAS(1))/(EGAS(2)-EGAS(1)) VEXTR3=VGAS(1)-VEXTR4*EGAS(1) IF(VEXTR4.GT.0.0.AND.VEXTR3.LT.0)THEN CALL OUTFMT(-PGAS*VEXTR3/VEXTR4,2,AUX1,NC1,'LEFT') PRINT *,' ------ GASPRE MESSAGE : The linear'// - ' extrapolation of the drift velocity is'// - ' negative for E < '//AUX1(1:NC1)//' V/cm.' ENDIF ELSEIF(JVEXTR.EQ.2)THEN VEXTR4=LOG(VGAS(2)/VGAS(1))/(EGAS(2)-EGAS(1)) VEXTR3=LOG(VGAS(1))-VEXTR4*EGAS(1) ENDIF * 2D interpolation. ELSEIF(GASOK(1).AND.(IVMETH.NE.1.AND.IVMETH.NE.2))THEN PRINT *,' !!!!!! GASPRE WARNING : Interpolation in'// - ' 2D tables can only be linear or quadratic;' PRINT *,' will use parabolic'// - ' interpolation for the drift velocity.' IVMETH=2 OK=.FALSE. ENDIF *** Drift velocity B preparation, start with a table of 1 point. IF(GASOK(9).AND.NGAS.LE.1.AND..NOT.TAB2D)THEN IF(IXEXTR.NE.0.OR.JXEXTR.NE.0)THEN PRINT *,' !!!!!! GASPRE WARNING : For a 1-point'// - ' table, only constant extrapolation is valid.' IXEXTR=0 JXEXTR=0 OK=.FALSE. ENDIF * Calculate the spline coefficients for the drift speed, ELSEIF(GASOK(9).AND..NOT.TAB2D)THEN CALL SPLINE(EGAS,XGAS,CXGAS,NGAS,IFAIL) IF(IFAIL.EQ.1)THEN PRINT *,' !!!!!! GASPRE WARNING : v || Btrans'// - ' can not be interpolated; data deleted.' GASOK(9)=.FALSE. OK=.FALSE. ENDIF * Calculate the H extrapolation parameters, using the last 2 points. IF(XGAS(NGAS).LE.0.OR.(IXEXTR.NE.1.AND.IXEXTR.NE.2))THEN XEXTR1=0.0 XEXTR2=0.0 ELSEIF(EGAS(NGAS).LE.EGAS(NGAS-1))THEN PRINT *,' !!!!!! GASPRE WARNING : Last 2 E/p values'// - ' coincide; no v || Btrans extrapolation to'// - ' high E/p.' IXEXTR=0 OK=.FALSE. ELSEIF(IXEXTR.EQ.1)THEN XEXTR2=(XGAS(NGAS)-XGAS(NGAS-1))/ - (EGAS(NGAS)-EGAS(NGAS-1)) XEXTR1=XGAS(NGAS)-XEXTR2*EGAS(NGAS) IF(XEXTR2.LT.0.0)THEN CALL OUTFMT(-PGAS*XEXTR1/XEXTR2,2,AUX1,NC1,'LEFT') PRINT *,' ------ GASPRE MESSAGE : The linear'// - ' extrapolation of v || Btrans is'// - ' negative for E > '//AUX1(1:NC1)//' V/cm.' ENDIF ELSEIF(IXEXTR.EQ.2)THEN XEXTR2=LOG(XGAS(NGAS)/XGAS(NGAS-1))/ - (EGAS(NGAS)-EGAS(NGAS-1)) XEXTR1=LOG(XGAS(NGAS))-XEXTR2*EGAS(NGAS) ENDIF * Calculate the L extrapolation parameters, using the last 2 points. IF(XGAS(1).LE.0.OR.(JXEXTR.NE.1.AND.JXEXTR.NE.2))THEN XEXTR3=0.0 XEXTR4=0.0 ELSEIF(EGAS(2).LE.EGAS(1))THEN PRINT *,' !!!!!! GASPRE WARNING : First 2 E/p values'// - ' coincide; no v || Btrans extrapolation to'// - ' low E/p.' JXEXTR=0 OK=.FALSE. ELSEIF(JXEXTR.EQ.1)THEN XEXTR4=(XGAS(2)-XGAS(1))/(EGAS(2)-EGAS(1)) XEXTR3=XGAS(1)-XEXTR4*EGAS(1) IF(XEXTR4.GT.0.0.AND.XEXTR3.LT.0)THEN CALL OUTFMT(-PGAS*XEXTR3/XEXTR4,2,AUX1,NC1,'LEFT') PRINT *,' ------ GASPRE MESSAGE : The linear'// - ' extrapolation of v || Btrans is'// - ' negative for E < '//AUX1(1:NC1)//' V/cm.' ENDIF ELSEIF(JXEXTR.EQ.2)THEN XEXTR4=LOG(XGAS(2)/XGAS(1))/(EGAS(2)-EGAS(1)) XEXTR3=LOG(XGAS(1))-XEXTR4*EGAS(1) ENDIF * 2D interpolation. ELSEIF(GASOK(9).AND.(IXMETH.NE.1.AND.IXMETH.NE.2))THEN PRINT *,' !!!!!! GASPRE WARNING : Interpolation in'// - ' 2D tables can only be linear or quadratic;' PRINT *,' will use parabolic'// - ' interpolation for v || Btrans.' IXMETH=2 OK=.FALSE. ENDIF *** Drift velocity ExB preparation, start with a table of 1 point. IF(GASOK(10).AND.NGAS.LE.1.AND..NOT.TAB2D)THEN IF(IYEXTR.NE.0.OR.JYEXTR.NE.0)THEN PRINT *,' !!!!!! GASPRE WARNING : For a 1-point'// - ' table, only constant extrapolation is valid.' IYEXTR=0 JYEXTR=0 OK=.FALSE. ENDIF * Calculate the spline coefficients for the drift speed, ELSEIF(GASOK(10).AND..NOT.TAB2D)THEN CALL SPLINE(EGAS,YGAS,CYGAS,NGAS,IFAIL) IF(IFAIL.EQ.1)THEN PRINT *,' !!!!!! GASPRE WARNING : v || ExB'// - ' data can not be interpolated; data deleted.' GASOK(10)=.FALSE. OK=.FALSE. ENDIF * Calculate the H extrapolation parameters, using the last 2 points. IF(YGAS(NGAS).LE.0.OR.(IYEXTR.NE.1.AND.IYEXTR.NE.2))THEN YEXTR1=0.0 YEXTR2=0.0 ELSEIF(EGAS(NGAS).LE.EGAS(NGAS-1))THEN PRINT *,' !!!!!! GASPRE WARNING : Last 2 E/p values'// - ' coincide; no v || ExB extrapolation to high'// - ' E/p.' IYEXTR=0 OK=.FALSE. ELSEIF(IYEXTR.EQ.1)THEN YEXTR2=(YGAS(NGAS)-YGAS(NGAS-1))/ - (EGAS(NGAS)-EGAS(NGAS-1)) YEXTR1=YGAS(NGAS)-YEXTR2*EGAS(NGAS) IF(YEXTR2.LT.0.0)THEN CALL OUTFMT(-PGAS*YEXTR1/YEXTR2,2,AUX1,NC1,'LEFT') PRINT *,' ------ GASPRE MESSAGE : The linear'// - ' extrapolation of v || ExB is'// - ' negative for E > '//AUX1(1:NC1)//' V/cm.' ENDIF ELSEIF(IYEXTR.EQ.2)THEN YEXTR2=LOG(YGAS(NGAS)/YGAS(NGAS-1))/ - (EGAS(NGAS)-EGAS(NGAS-1)) YEXTR1=LOG(YGAS(NGAS))-YEXTR2*EGAS(NGAS) ENDIF * Calculate the L extrapolation parameters, using the last 2 points. IF(YGAS(1).LE.0.OR.(JYEXTR.NE.1.AND.JYEXTR.NE.2))THEN YEXTR3=0.0 YEXTR4=0.0 ELSEIF(EGAS(2).LE.EGAS(1))THEN PRINT *,' !!!!!! GASPRE WARNING : First 2 E/p values'// - ' coincide; no v || ExB extrapolation to low'// - ' E/p.' JYEXTR=0 OK=.FALSE. ELSEIF(JYEXTR.EQ.1)THEN YEXTR4=(YGAS(2)-YGAS(1))/(EGAS(2)-EGAS(1)) YEXTR3=YGAS(1)-YEXTR4*EGAS(1) IF(YEXTR4.GT.0.0.AND.YEXTR3.LT.0)THEN CALL OUTFMT(-PGAS*YEXTR3/YEXTR4,2,AUX1,NC1,'LEFT') PRINT *,' ------ GASPRE MESSAGE : The linear'// - ' extrapolation of v || ExB is'// - ' negative for E < '//AUX1(1:NC1)//' V/cm.' ENDIF ELSEIF(JYEXTR.EQ.2)THEN YEXTR4=LOG(YGAS(2)/YGAS(1))/(EGAS(2)-EGAS(1)) YEXTR3=LOG(YGAS(1))-YEXTR4*EGAS(1) ENDIF * 2D interpolation. ELSEIF(GASOK(10).AND.(IYMETH.NE.1.AND.IYMETH.NE.2))THEN PRINT *,' !!!!!! GASPRE WARNING : Interpolation in'// - ' 2D tables can only be linear or quadratic;' PRINT *,' will use parabolic'// - ' interpolation for v || ExB.' IYMETH=2 OK=.FALSE. ENDIF *** Calculate the spline coefficients for the ion mobility. IF(GASOK(2).AND.NGAS.LE.1.AND..NOT.TAB2D)THEN IF(IMEXTR.NE.0.OR.JMEXTR.NE.0)THEN PRINT *,' !!!!!! GASPRE WARNING : For a 1-point'// - ' table, only constant extrapolation is valid.' IMEXTR=0 JMEXTR=0 OK=.FALSE. ENDIF ELSEIF(GASOK(2).AND..NOT.TAB2D)THEN CALL SPLINE(EGAS,MGAS,CMGAS,NGAS,IFAIL) IF(IFAIL.EQ.1)THEN PRINT *,' !!!!!! GASPRE WARNING : The ion mobility'// - ' data can not be interpolated; data deleted.' GASOK(2)=.FALSE. OK=.FALSE. ENDIF * Calculate the H extrapolation parameters, using the last 2 points. IF(MGAS(NGAS).LE.0.OR.(IMEXTR.NE.1.AND.IMEXTR.NE.2))THEN MEXTR1=0.0 MEXTR2=0.0 ELSEIF(EGAS(NGAS).LE.EGAS(NGAS-1))THEN PRINT *,' !!!!!! GASPRE WARNING : Last 2 E/p values'// - ' coincide; no mu extrapolation to higher E/p.' IMEXTR=0 OK=.FALSE. ELSEIF(IMEXTR.EQ.1)THEN MEXTR2=(MGAS(NGAS)-MGAS(NGAS-1))/ - (EGAS(NGAS)-EGAS(NGAS-1)) MEXTR1=MGAS(NGAS)-MEXTR2*EGAS(NGAS) IF(MEXTR2.LT.0.0)THEN CALL OUTFMT(-PGAS*MEXTR1/MEXTR2,2,AUX1,NC1,'LEFT') PRINT *,' ------ GASPRE MESSAGE : The linear'// - ' extrapolation of the ion mobility is'// - ' negative for E > '//AUX1(1:NC1)//' V/cm.' ENDIF ELSEIF(IMEXTR.EQ.2)THEN MEXTR2=LOG(MGAS(NGAS)/MGAS(NGAS-1))/ - (EGAS(NGAS)-EGAS(NGAS-1)) MEXTR1=LOG(MGAS(NGAS))-MEXTR2*EGAS(NGAS) ENDIF * Calculate the L extrapolation parameters, using the last 2 points. IF(MGAS(1).LE.0.OR.(JMEXTR.NE.1.AND.JMEXTR.NE.2))THEN MEXTR3=0.0 MEXTR4=0.0 ELSEIF(EGAS(2).LE.EGAS(1))THEN PRINT *,' !!!!!! GASPRE WARNING : First 2 E/p values'// - ' coincide; no mu extrapolation to lower E/p.' JMEXTR=0 OK=.FALSE. ELSEIF(JMEXTR.EQ.1)THEN MEXTR4=(MGAS(2)-MGAS(1))/(EGAS(2)-EGAS(1)) MEXTR3=MGAS(1)-MEXTR4*EGAS(1) IF(MEXTR4.GT.0.0.AND.MEXTR3.LT.0)THEN CALL OUTFMT(-PGAS*MEXTR3/MEXTR4,2,AUX1,NC1,'LEFT') PRINT *,' ------ GASPRE MESSAGE : The linear'// - ' extrapolation of the ion mobility is'// - ' negative for E < '//AUX1(1:NC1)//' V/cm.' ENDIF ELSEIF(JMEXTR.EQ.2)THEN MEXTR4=LOG(MGAS(2)/MGAS(1))/(EGAS(2)-EGAS(1)) MEXTR3=LOG(MGAS(1))-MEXTR4*EGAS(1) ENDIF * 2D interpolation. ELSEIF(GASOK(2).AND.(IMMETH.NE.1.AND.IMMETH.NE.2))THEN PRINT *,' !!!!!! GASPRE WARNING : Interpolation in'// - ' 2D tables can only be linear or quadratic;' PRINT *,' will use parabolic'// - ' interpolation for the ion mobility.' IMMETH=2 OK=.FALSE. ENDIF *** Calculate the spline coefficients for sigma L. IF(GASOK(3).AND.NGAS.LE.1.AND..NOT.TAB2D)THEN IF(IDEXTR.NE.0.OR.JDEXTR.NE.0)THEN PRINT *,' !!!!!! GASPRE WARNING : For a 1-point'// - ' table, only constant extrapolation is valid.' IDEXTR=0 JDEXTR=0 OK=.FALSE. ENDIF ELSEIF(GASOK(3).AND..NOT.TAB2D)THEN CALL SPLINE(EGAS,DGAS,CDGAS,NGAS,IFAIL) IF(IFAIL.EQ.1)THEN PRINT *,' !!!!!! GASPRE WARNING : The long. diff.'// - ' data can not be interpolated; data deleted.' GASOK(3)=.FALSE. OK=.FALSE. ENDIF * Calculate the H extrapolation parameters, using the last 2 points. IF(DGAS(NGAS).LE.0.OR.(IDEXTR.NE.1.AND.IDEXTR.NE.2))THEN DEXTR1=0.0 DEXTR2=0.0 ELSEIF(EGAS(NGAS).LE.EGAS(NGAS-1))THEN PRINT *,' !!!!!! GASPRE WARNING : Last 2 E/p values'// - ' coincide; no DL extrapolation to higher E/p.' IDEXTR=0 OK=.FALSE. ELSEIF(IDEXTR.EQ.1)THEN DEXTR2=(DGAS(NGAS)-DGAS(NGAS-1))/ - (EGAS(NGAS)-EGAS(NGAS-1)) DEXTR1=DGAS(NGAS)-DEXTR2*EGAS(NGAS) IF(DEXTR2.LT.0.0)THEN CALL OUTFMT(-PGAS*DEXTR1/DEXTR2,2,AUX1,NC1,'LEFT') PRINT *,' ------ GASPRE MESSAGE : The linear'// - ' extrapolation of the long. diff. is'// - ' negative for E > '//AUX1(1:NC1)//' V/cm.' ENDIF ELSEIF(IDEXTR.EQ.2)THEN DEXTR2=LOG(DGAS(NGAS)/DGAS(NGAS-1))/ - (EGAS(NGAS)-EGAS(NGAS-1)) DEXTR1=LOG(DGAS(NGAS))-DEXTR2*EGAS(NGAS) ENDIF * Calculate the L extrapolation parameters, using the last 2 points. IF(DGAS(1).LE.0.OR.(JDEXTR.NE.1.AND.JDEXTR.NE.2))THEN DEXTR3=0.0 DEXTR4=0.0 ELSEIF(EGAS(2).LE.EGAS(1))THEN PRINT *,' !!!!!! GASPRE WARNING : First 2 E/p values'// - ' coincide; no DL extrapolation to lower E/p.' JDEXTR=0 OK=.FALSE. ELSEIF(JDEXTR.EQ.1)THEN DEXTR4=(DGAS(2)-DGAS(1))/(EGAS(2)-EGAS(1)) DEXTR3=DGAS(1)-DEXTR4*EGAS(1) IF(DEXTR4.GT.0.0.AND.DEXTR3.LT.0)THEN CALL OUTFMT(-PGAS*DEXTR3/DEXTR4,2,AUX1,NC1,'LEFT') PRINT *,' ------ GASPRE MESSAGE : The linear'// - ' extrapolation of the long. diff. is'// - ' negative for E < '//AUX1(1:NC1)//' V/cm.' ENDIF ELSEIF(JDEXTR.EQ.2)THEN DEXTR4=LOG(DGAS(2)/DGAS(1))/(EGAS(2)-EGAS(1)) DEXTR3=LOG(DGAS(1))-DEXTR4*EGAS(1) ENDIF * 2D interpolation. ELSEIF(GASOK(3).AND.(IDMETH.NE.1.AND.IDMETH.NE.2))THEN PRINT *,' !!!!!! GASPRE WARNING : Interpolation in'// - ' 2D tables can only be linear or quadratic;' PRINT *,' will use parabolic'// - ' interpolation for the long. diff.' IDMETH=2 OK=.FALSE. ENDIF *** Calculate the spline coefficients for the Townsend coefficient. IF(GASOK(4).AND.NGAS.LE.1.AND..NOT.TAB2D)THEN IF(IAEXTR.NE.0.OR.JAEXTR.NE.0)THEN PRINT *,' !!!!!! GASPRE WARNING : For a 1-point'// - ' table, only constant extrapolation is valid.' IAEXTR=0 JAEXTR=0 OK=.FALSE. ENDIF IATHR=1 ELSEIF(GASOK(4).AND..NOT.TAB2D)THEN * Set threshold. DO 100 I=1,NGAS IF(AGAS(I).LE.-20)GOTO 100 IATHR=MIN(NGAS,I+1) GOTO 110 100 CONTINUE IATHR=1 110 CONTINUE * Prepare spline coefficients. CALL SPLINE(EGAS,AGAS,CAGAS,NGAS,IFAIL) IF(IFAIL.EQ.1)THEN PRINT *,' !!!!!! GASPRE WARNING : The Townsend'// - ' data can not be interpolated; data deleted.' GASOK(4)=.FALSE. OK=.FALSE. ENDIF * Calculate the H extrapolation parameters, using the last 2 points. IF(IAEXTR.NE.1.AND.IAEXTR.NE.2)THEN AEXTR1=0.0 AEXTR2=0.0 ELSEIF(EGAS(NGAS).LE.EGAS(NGAS-1))THEN PRINT *,' !!!!!! GASPRE WARNING : Last 2 E/p values'// - ' coincide; no alpha extrapolation to higher E/p.' IAEXTR=0 OK=.FALSE. ELSEIF(IAEXTR.EQ.1)THEN AEXTR2=(AGAS(NGAS)-AGAS(NGAS-1))/ - (EGAS(NGAS)-EGAS(NGAS-1)) AEXTR1=AGAS(NGAS)-AEXTR2*EGAS(NGAS) ELSEIF(IAEXTR.EQ.2)THEN AEXTR2=LOG(AGAS(NGAS)/AGAS(NGAS-1))/ - (EGAS(NGAS)-EGAS(NGAS-1)) AEXTR1=LOG(AGAS(NGAS))-AEXTR2*EGAS(NGAS) ENDIF * Calculate the L extrapolation parameters, using the last 2 points. IF(JAEXTR.NE.1.AND.JAEXTR.NE.2)THEN AEXTR3=0.0 AEXTR4=0.0 ELSEIF(EGAS(2).LE.EGAS(1))THEN PRINT *,' !!!!!! GASPRE WARNING : First 2 E/p values'// - ' coincide; no alpha extrapolation to lower E/p.' JAEXTR=0 OK=.FALSE. ELSEIF(JAEXTR.EQ.1)THEN AEXTR4=(AGAS(2)-AGAS(1))/(EGAS(2)-EGAS(1)) AEXTR3=AGAS(1)-AEXTR4*EGAS(1) ELSEIF(JAEXTR.EQ.2)THEN AEXTR4=LOG(AGAS(2)/AGAS(1))/(EGAS(2)-EGAS(1)) AEXTR3=LOG(AGAS(1))-AEXTR4*EGAS(1) ENDIF * 2D interpolation. ELSEIF(GASOK(4))THEN * Set threshold. DO 120 I=1,NGAS DO 130 J=1,NBANG DO 140 K=1,NBTAB IF(AGAS2(I,J,K).LT.-20)GOTO 120 140 CONTINUE 130 CONTINUE IATHR=MIN(NGAS,I+1) GOTO 150 120 CONTINUE IATHR=1 150 CONTINUE * Check interpolation method. IF(IAMETH.NE.1.AND.IAMETH.NE.2)THEN PRINT *,' !!!!!! GASPRE WARNING : Interpolation in'// - ' 2D tables can only be linear or quadratic;' PRINT *,' will use parabolic'// - ' interpolation for the Townsend coeff.' IAMETH=2 OK=.FALSE. ENDIF ENDIF *** Calculate the spline coefficients for the attachment. IF(GASOK(6).AND.NGAS.LE.1.AND..NOT.TAB2D)THEN IF(IBEXTR.NE.0.OR.JBEXTR.NE.0)THEN PRINT *,' !!!!!! GASPRE WARNING : For a 1-point'// - ' table, only constant extrapolation is valid.' IBEXTR=0 JBEXTR=0 OK=.FALSE. ENDIF IBTHR=1 ELSEIF(GASOK(6).AND..NOT.TAB2D)THEN * Set threshold. DO 200 I=1,NGAS IF(BGAS(I).LE.-20)GOTO 200 IBTHR=MIN(NGAS,I+1) GOTO 210 200 CONTINUE IBTHR=1 210 CONTINUE * Prepare spline coefficients. CALL SPLINE(EGAS,BGAS,CBGAS,NGAS,IFAIL) IF(IFAIL.EQ.1)THEN PRINT *,' !!!!!! GASPRE WARNING : The attachment'// - ' data can not be interpolated; data deleted.' GASOK(6)=.FALSE. OK=.FALSE. ENDIF * Calculate the H extrapolation parameters, using the last 2 points. IF(IBEXTR.NE.1.AND.IBEXTR.NE.2)THEN BEXTR1=0.0 BEXTR2=0.0 ELSEIF(EGAS(NGAS).LE.EGAS(NGAS-1))THEN PRINT *,' !!!!!! GASPRE WARNING : Last 2 E/p values'// - ' coincide; no eta extrapolation to higher E/p.' IBEXTR=0 OK=.FALSE. ELSEIF(IBEXTR.EQ.1)THEN BEXTR2=(BGAS(NGAS)-BGAS(NGAS-1))/ - (EGAS(NGAS)-EGAS(NGAS-1)) BEXTR1=BGAS(NGAS)-BEXTR2*EGAS(NGAS) ELSEIF(IBEXTR.EQ.2)THEN BEXTR2=LOG(BGAS(NGAS)/BGAS(NGAS-1))/ - (EGAS(NGAS)-EGAS(NGAS-1)) BEXTR1=LOG(BGAS(NGAS))-BEXTR2*EGAS(NGAS) ENDIF * Calculate the L extrapolation parameters, using the last 2 points. IF(JBEXTR.NE.1.AND.JBEXTR.NE.2)THEN BEXTR3=0.0 BEXTR4=0.0 ELSEIF(EGAS(2).LE.EGAS(1))THEN PRINT *,' !!!!!! GASPRE WARNING : First 2 E/p values'// - ' coincide; no eta extrapolation to lower E/p.' JBEXTR=0 OK=.FALSE. ELSEIF(JBEXTR.EQ.1)THEN BEXTR4=(BGAS(2)-BGAS(1))/(EGAS(2)-EGAS(1)) BEXTR3=BGAS(1)-BEXTR4*EGAS(1) ELSEIF(JBEXTR.EQ.2)THEN BEXTR4=LOG(BGAS(2)/BGAS(1))/(EGAS(2)-EGAS(1)) BEXTR3=LOG(BGAS(1))-BEXTR4*EGAS(1) ENDIF * 2D interpolation. ELSEIF(GASOK(6))THEN * Set threshold. DO 220 I=1,NGAS DO 230 J=1,NBANG DO 240 K=1,NBTAB IF(BGAS2(I,J,K).LE.-20)GOTO 220 240 CONTINUE 230 CONTINUE IBTHR=MIN(NGAS,I+1) GOTO 250 220 CONTINUE IBTHR=1 250 CONTINUE * Check interpolation method. IF(IBMETH.NE.1.AND.IBMETH.NE.2)THEN PRINT *,' !!!!!! GASPRE WARNING : Interpolation in'// - ' 2D tables can only be linear or quadratic;' PRINT *,' will use parabolic'// - ' interpolation for the attachment.' IBMETH=2 OK=.FALSE. ENDIF ENDIF *** Calculate the spline coefficients for the Lorentz angle. IF(GASOK(7).AND.NGAS.LE.1.AND..NOT.TAB2D)THEN IF(IWEXTR.NE.0.OR.JWEXTR.NE.0)THEN PRINT *,' !!!!!! GASPRE WARNING : For a 1-point'// - ' table, only constant extrapolation is valid.' IWEXTR=0 JWEXTR=0 OK=.FALSE. ENDIF ELSEIF(GASOK(7).AND..NOT.TAB2D)THEN CALL SPLINE(EGAS,WGAS,CWGAS,NGAS,IFAIL) IF(IFAIL.EQ.1)THEN PRINT *,' !!!!!! GASPRE WARNING : The (v,E) angle'// - ' data can not be interpolated; data deleted.' GASOK(7)=.FALSE. OK=.FALSE. ENDIF * Calculate the H extrapolation parameters, using the last 2 points. IF(WGAS(NGAS).LE.0.OR.(IWEXTR.NE.1.AND.IWEXTR.NE.2))THEN WEXTR1=0.0 WEXTR2=0.0 ELSEIF(EGAS(NGAS).LE.EGAS(NGAS-1))THEN PRINT *,' !!!!!! GASPRE WARNING : Last 2 E/p values'// - ' coincide; no Lorentz extrapolation to higher'// - ' E/p.' IWEXTR=0 OK=.FALSE. ELSEIF(IWEXTR.EQ.1)THEN WEXTR2=(WGAS(NGAS)-WGAS(NGAS-1))/ - (EGAS(NGAS)-EGAS(NGAS-1)) WEXTR1=WGAS(NGAS)-WEXTR2*EGAS(NGAS) IF(WEXTR2.LT.0.0)THEN CALL OUTFMT(-PGAS*WEXTR1/WEXTR2,2,AUX1,NC1,'LEFT') PRINT *,' ------ GASPRE MESSAGE : The linear'// - ' extrapolation of the (v,E) angle is'// - ' negative for E > '//AUX1(1:NC1)//' V/cm.' ENDIF ELSEIF(IWEXTR.EQ.2)THEN WEXTR2=LOG(WGAS(NGAS)/WGAS(NGAS-1))/ - (EGAS(NGAS)-EGAS(NGAS-1)) WEXTR1=LOG(WGAS(NGAS))-WEXTR2*EGAS(NGAS) ENDIF * Calculate the L extrapolation parameters, using the last 2 points. IF(WGAS(1).LE.0.OR.(JWEXTR.NE.1.AND.JWEXTR.NE.2))THEN WEXTR3=0.0 WEXTR4=0.0 ELSEIF(EGAS(2).LE.EGAS(1))THEN PRINT *,' !!!!!! GASPRE WARNING : First 2 E/p values'// - ' coincide; no Lorentz extrapolation to higher'// - ' E/p.' JWEXTR=0 OK=.FALSE. ELSEIF(JWEXTR.EQ.1)THEN WEXTR4=(WGAS(2)-WGAS(1))/(EGAS(2)-EGAS(1)) WEXTR3=WGAS(1)-WEXTR4*EGAS(1) IF(WEXTR4.GT.0.0.AND.WEXTR3.LT.0)THEN CALL OUTFMT(-PGAS*WEXTR3/WEXTR4,2,AUX1,NC1,'LEFT') PRINT *,' ------ GASPRE MESSAGE : The linear'// - ' extrapolation of the (v,E) angle is'// - ' negative for E < '//AUX1(1:NC1)//' V/cm.' ENDIF ELSEIF(JWEXTR.EQ.2)THEN WEXTR4=LOG(WGAS(2)/WGAS(1))/(EGAS(2)-EGAS(1)) WEXTR3=LOG(WGAS(1))-WEXTR4*EGAS(1) ENDIF * 2D interpolation. ELSEIF(GASOK(7).AND.(IWMETH.NE.1.AND.IWMETH.NE.2))THEN PRINT *,' !!!!!! GASPRE WARNING : Interpolation in'// - ' 2D tables can only be linear or quadratic;' PRINT *,' will use parabolic'// - ' interpolation for the (v,E) angle.' IWMETH=2 OK=.FALSE. ENDIF *** Calculate the spline coefficients for sigma T. IF(GASOK(8).AND.NGAS.LE.1.AND..NOT.TAB2D)THEN IF(IOEXTR.NE.0.OR.JOEXTR.NE.0)THEN PRINT *,' !!!!!! GASPRE WARNING : For a 1-point'// - ' table, only constant extrapolation is valid.' IOEXTR=0 JOEXTR=0 OK=.FALSE. ENDIF ELSEIF(GASOK(8).AND..NOT.TAB2D)THEN CALL SPLINE(EGAS,OGAS,COGAS,NGAS,IFAIL) IF(IFAIL.EQ.1)THEN PRINT *,' !!!!!! GASPRE WARNING : The trans. diff.'// - ' data can not be interpolated; data deleted.' GASOK(8)=.FALSE. OK=.FALSE. ENDIF * Calculate the H extrapolation parameters, using the last 2 points. IF(OGAS(NGAS).LE.0.OR.(IOEXTR.NE.1.AND.IOEXTR.NE.2))THEN OEXTR1=0.0 OEXTR2=0.0 ELSEIF(EGAS(NGAS).LE.EGAS(NGAS-1))THEN PRINT *,' !!!!!! GASPRE WARNING : Last 2 E/p values'// - ' coincide; no DT extrapolation to higher E/p.' IOEXTR=0 OK=.FALSE. ELSEIF(IOEXTR.EQ.1)THEN OEXTR2=(OGAS(NGAS)-OGAS(NGAS-1))/ - (EGAS(NGAS)-EGAS(NGAS-1)) OEXTR1=OGAS(NGAS)-OEXTR2*EGAS(NGAS) IF(OEXTR2.LT.0.0)THEN CALL OUTFMT(-PGAS*OEXTR1/OEXTR2,2,AUX1,NC1,'LEFT') PRINT *,' ------ GASPRE MESSAGE : The linear'// - ' extrapolation of the trans. diff. is'// - ' negative for E > '//AUX1(1:NC1)//' V/cm.' ENDIF ELSEIF(IOEXTR.EQ.2)THEN OEXTR2=LOG(OGAS(NGAS)/OGAS(NGAS-1))/ - (EGAS(NGAS)-EGAS(NGAS-1)) OEXTR1=LOG(OGAS(NGAS))-OEXTR2*EGAS(NGAS) ENDIF * Calculate the L extrapolation parameters, using the last 2 points. IF(OGAS(1).LE.0.OR.(JOEXTR.NE.1.AND.JOEXTR.NE.2))THEN OEXTR3=0.0 OEXTR4=0.0 ELSEIF(EGAS(2).LE.EGAS(1))THEN PRINT *,' !!!!!! GASPRE WARNING : First 2 E/p values'// - ' coincide; no DT extrapolation to lower E/p.' JOEXTR=0 OK=.FALSE. ELSEIF(JOEXTR.EQ.1)THEN OEXTR4=(OGAS(2)-OGAS(1))/(EGAS(2)-EGAS(1)) OEXTR3=OGAS(1)-OEXTR4*EGAS(1) IF(OEXTR4.GT.0.0.AND.OEXTR3.LT.0)THEN CALL OUTFMT(-PGAS*OEXTR3/OEXTR4,2,AUX1,NC1,'LEFT') PRINT *,' ------ GASPRE MESSAGE : The linear'// - ' extrapolation of the trans. diff. is'// - ' negative for E < '//AUX1(1:NC1)//' V/cm.' ENDIF ELSEIF(JOEXTR.EQ.2)THEN OEXTR4=LOG(OGAS(2)/OGAS(1))/(EGAS(2)-EGAS(1)) OEXTR3=LOG(OGAS(1))-OEXTR4*EGAS(1) ENDIF * 2D interpolation. ELSEIF(GASOK(8).AND.(IOMETH.NE.1.AND.IOMETH.NE.2))THEN PRINT *,' !!!!!! GASPRE WARNING : Interpolation in'// - ' 2D tables can only be linear or quadratic;' PRINT *,' will use parabolic'// - ' interpolation for the trans. diff.' IOMETH=2 OK=.FALSE. ENDIF *** Reset the IFAIL's from the splines (they are now stored in GASOK). IFAIL=0 *** Calculate the cluster size distr hist from parameters, call HISPRD. IF(CLSTYP.EQ.'LANDAU'.AND.GASOK(5))THEN IF(LDEBUG)PRINT *,' ++++++ GASPRE DEBUG : First order', - ' energy loss according to Bethe-Bloch: ', - (1.54E5*(Z/A)*RHO)-LOG(CMEAN) * Fix the maximum number of clusters. NCLS=MXPAIR NFAIL=0 DO 10 N=1,NCLS * If the argument of DENLAN is smaller than -6, error 208 occurs. IF((CMEAN*(N-1.0)*EPAIR-EMPROB)/(1.54E5*(Z/A)*RHO)- - LOG(CMEAN).LT.-5.0)THEN CLSDIS(N)=0 NFAIL=NFAIL+1 * Otherwise, use the library function. ELSE CLSDIS(N)=(DENLAN((CMEAN*REAL(N-1)*EPAIR-EMPROB)/ - (1.54E5*(Z/A)*RHO)-LOG(CMEAN))+4* - DENLAN((CMEAN*(N-0.5)*EPAIR-EMPROB)/ - (1.54E5*(Z/A)*RHO)-LOG(CMEAN))+ - DENLAN((CMEAN*REAL(N)*EPAIR-EMPROB)/ - (1.54E5*(Z/A)*RHO)-LOG(CMEAN)))/6 ENDIF 10 CONTINUE * Check there are some non-zero elements. IF(NFAIL.EQ.NCLS)THEN PRINT *,' !!!!!! GASPRE WARNING : Your parameters'// - ' are such that all cluster sizes up to ',NCLS PRINT *,' have probability'// - ' zero; cluster size distribution deleted.' GASOK(5)=.FALSE. ENDIF ENDIF *** Call HISPRD to prepare random number extraction. IF(GASOK(5).AND.(CLSTYP.EQ.'LANDAU'.OR.CLSTYP.EQ.'FUNCTION'.OR. - CLSTYP.EQ.'TABLE'.OR.CLSTYP.EQ.'OVERLAP'))THEN * Debugging output. IF(LDEBUG)THEN PRINT *,' ++++++ GASPRE DEBUG : HISPRD to be called', - ' for ',CLSTYP,', NCLS=',NCLS,', distribution:' PRINT *,(CLSDIS(I),I=1,NCLS) ENDIF * Compute average number of pairs per cluster. CLSAVE=0 CLSSUM=0 DO 20 I=1,NCLS CLSAVE=CLSAVE+I*CLSDIS(I) CLSSUM=CLSSUM+CLSDIS(I) 20 CONTINUE CLSAVE=CLSAVE/CLSSUM * Prepare the histogram for random number generation. CALL HISPRD(CLSDIS,NCLS) ENDIF *** Call TIMLOG to register the amount of CPU time used. CALL TIMLOG('Reading and preparing gas data: ') END +DECK,GASPRT. SUBROUTINE GASPRT *----------------------------------------------------------------------- * GASPRT - Routine printing an overview of the gas information. * VARIABLES : none * (Last changed on 17/ 2/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,GASDATA. +SEQ,BFIELD. +SEQ,PRINTPLOT. +SEQ,CONSTANTS. CHARACTER*120 STRING,SYMBOL,UNIT CHARACTER*20 STR1,STR2,STR3,STR4,STR5,STR6,STR7,STR8 INTEGER I,J,K,NC1,NC2,NC3,NC4,NC5,NC6,NC7,NC8, - IGASOK,IMETH,IEXTR,JEXTR, - NCSYMB,NCUNIT,ITEM,NC REAL EXTR1,EXTR2,EXTR3,EXTR4,VAL1,VALN *** Identify the routine, if requested. IF(LIDENT)PRINT *,' /// ROUTINE GASPRT ///' *** Print a suitable heading for the gas tables. WRITE(LUNOUT,'(''1 SUMMARY OF THE GAS DATA''/ - '' =======================''/)') IF(GASID.NE.' ')WRITE(LUNOUT,'('' Identification: '',A)') - GASID *** Check for transport tables. IF(.NOT.(GASOK(1).OR.GASOK(2).OR.GASOK(3).OR. - GASOK(4).OR.GASOK(6).OR.GASOK(7).OR.GASOK(8).OR. - GASOK(9).OR.GASOK(10)))THEN WRITE(LUNOUT,'('' Transport properties have not been''/ - '' entered.'')') GOTO 100 ENDIF *** 2D tables. IF(TAB2D)THEN * Loop over angles and B fields. DO 10 J=1,NBANG DO 40 K=1,NBTAB * Print the header for this combination. STRING(1:25)='Transport properties for ' NC=25 CALL OUTFMT(180*BANG(J)/PI,2,STR1,NC1,'LEFT') STRING(NC+1:NC+26+NC1)='angle(E,B) = '//STR1(1:NC1)// - ' degrees and ' NC=NC+26+NC1 CALL OUTFMT(BTAB(K)/100,2,STR1,NC1,'LEFT') STRING(NC+1:NC+7+NC1)='B = '//STR1(1:NC1)//' T:' NC=NC+7+NC1 WRITE(LUNOUT,'(/2X,A/)') STRING(1:NC) * Print the items to be shown in part 1. WRITE(LUNOUT,'('' E v || E'', - '' v || Btrans v || ExB angle(v,E)'', - '' Ion mobility Townsend Attachment'')') WRITE(LUNOUT,'('' [V/cm] [cm/microsec]'', - '' [cm/microsec] [cm/microsec] [degrees]'', - '' [cm2/V.musec] [1/cm] [1/cm]'')') DO 20 I=1,NGAS CALL OUTFMT(EGAS(I)*PGAS,2,STR1,NC1,'RIGHT') IF(GASOK(1))THEN CALL OUTFMT(VGAS2(I,J,K),2,STR2,NC2,'RIGHT') ELSE STR2=' not available' ENDIF IF(GASOK(9))THEN CALL OUTFMT(XGAS2(I,J,K),2,STR3,NC3,'RIGHT') ELSE STR3=' not available' ENDIF IF(GASOK(10))THEN CALL OUTFMT(YGAS2(I,J,K),2,STR4,NC4,'RIGHT') ELSE STR4=' not available' ENDIF IF(GASOK(7))THEN CALL OUTFMT(180*WGAS2(I,J,K)/PI,2,STR5,NC5,'RIGHT') ELSE STR5=' not available' ENDIF IF(GASOK(2))THEN CALL OUTFMT(MGAS2(I,J,K),2,STR6,NC6,'RIGHT') ELSE STR6=' not available' ENDIF IF(GASOK(4).AND.AGAS2(I,J,K).GT.-20)THEN CALL OUTFMT(EXP(AGAS2(I,J,K))*PGAS,2,STR7,NC7,'RIGHT') ELSEIF(GASOK(4))THEN STR7=' 0' ELSE STR7=' not available' ENDIF IF(GASOK(6).AND.BGAS2(I,J,K).GT.-20)THEN CALL OUTFMT(EXP(BGAS2(I,J,K))*PGAS,2,STR8,NC8,'RIGHT') ELSEIF(GASOK(6))THEN STR8=' 0' ELSE STR8=' not available' ENDIF WRITE(LUNOUT,'(8A)') STR1(11:20),STR2(7:20),STR3(7:20), - STR4(7:20),STR5(7:20),STR6(7:20),STR7(7:20),STR8(7:20) 20 CONTINUE * Print the items to be shown in part 2. WRITE(LUNOUT,'(/'' E'', - '' sigma || E sigma || Btr sigma || ExB'', - '' rho(E,B) rho(E,ExB) rho(B,ExB)'')') WRITE(LUNOUT,'('' [V/cm]'', - '' [micron for 1 cm]'', - '' [-]'')') DO 60 I=1,NGAS CALL OUTFMT(EGAS(I)*PGAS,2,STR1,NC1,'RIGHT') IF(GASOK(3))THEN CALL OUTFMT(10000*DGAS2(I,J,K)/SQRT(PGAS),2, - STR2,NC2,'RIGHT') ELSE STR2=' not available' ENDIF IF(GASOK(8))THEN CALL OUTFMT(10000*OGAS2(I,J,K)/SQRT(PGAS),2, - STR3,NC3,'RIGHT') ELSE STR3=' not available' ENDIF STR4=' ' STR5=' ' STR6=' ' STR7=' ' WRITE(LUNOUT,'(8A)') STR1(11:20),STR2(7:20),STR3(7:20), - STR4(7:20),STR5(7:20),STR6(7:20),STR7(7:20) 60 CONTINUE 40 CONTINUE 10 CONTINUE *** 1D tables. ELSE * Print the header for this combination. IF(MAGOK)THEN STRING(1:25)='Transport properties for ' NC=25 CALL OUTFMT(180*BANG(1)/PI,2,STR1,NC1,'LEFT') STRING(NC+1:NC+26+NC1)='angle(E,B) = '//STR1(1:NC1)// - ' degrees and ' NC=NC+26+NC1 CALL OUTFMT(BTAB(1)/100,2,STR1,NC1,'LEFT') STRING(NC+1:NC+7+NC1)='B = '//STR1(1:NC1)//' T:' NC=NC+7+NC1 WRITE(LUNOUT,'(/2X,A/)') STRING(1:NC) ELSE WRITE(LUNOUT,'(/2X,''Transport properties:''/)') ENDIF * Print the table. WRITE(LUNOUT,'('' E Vdrift'', - '' Ion mobility Diffusion (long, trans)'', - '' Townsend Attachment Lorentz angle'')') WRITE(LUNOUT,'('' [V/cm] [cm/microsec]'', - '' [cm2/V.musec] [micron for 1 cm]'', - '' [1/cm] [1/cm] [degrees]'')') DO 30 I=1,NGAS CALL OUTFMT(EGAS(I)*PGAS,2,STR1,NC1,'RIGHT') IF(GASOK(1))THEN CALL OUTFMT(VGAS(I),2,STR2,NC2,'RIGHT') ELSE STR2=' not available' ENDIF IF(GASOK(2))THEN CALL OUTFMT(MGAS(I),2,STR3,NC3,'RIGHT') ELSE STR3=' not available' ENDIF IF(GASOK(3))THEN CALL OUTFMT(10000*DGAS(I)/SQRT(PGAS),2, - STR4,NC4,'RIGHT') ELSE STR4=' not available' ENDIF IF(GASOK(8))THEN CALL OUTFMT(10000*OGAS(I)/SQRT(PGAS),2, - STR5,NC5,'RIGHT') ELSE STR5=' not available' ENDIF IF(GASOK(4).AND.AGAS(I).GT.-20)THEN CALL OUTFMT(EXP(AGAS(I))*PGAS,2,STR6,NC6,'RIGHT') ELSEIF(GASOK(4))THEN STR6=' 0' ELSE STR6=' not available' ENDIF IF(GASOK(6).AND.BGAS(I).GT.-20)THEN CALL OUTFMT(EXP(BGAS(I))*PGAS,2,STR7,NC7,'RIGHT') ELSEIF(GASOK(6))THEN STR7=' 0' ELSE STR7=' not available' ENDIF IF(GASOK(7))THEN CALL OUTFMT(180*WGAS(I)/PI,2,STR8,NC8,'RIGHT') ELSE STR8=' not available' ENDIF WRITE(LUNOUT,'(8A)') STR1(11:20),STR2(7:20),STR3(7:20), - STR4(7:20),STR5(7:20),STR6(7:20),STR7(7:20),STR8(7:20) 30 CONTINUE ENDIF *** Print the extrapolation formulae. WRITE(LUNOUT,'(/'' Interpolations and extrapolations:''/)') * Loop over the items. DO 50 ITEM=1,9 * Print a header. IF(ITEM.EQ.1)THEN WRITE(LUNOUT,'('' Drift velocity along E:'')') IGASOK=1 IMETH=IVMETH IEXTR=IVEXTR JEXTR=JVEXTR EXTR1=VEXTR1 EXTR2=VEXTR2 EXTR3=VEXTR3 EXTR4=VEXTR4 VAL1=VGAS(1) VALN=VGAS(NGAS) SYMBOL='v' NCSYMB=1 UNIT='[cm/microsec]' NCUNIT=13 ELSEIF(ITEM.EQ.2)THEN WRITE(LUNOUT,'(/'' Drift velocity along Btrans:'')') IGASOK=9 IMETH=IXMETH IEXTR=IXEXTR JEXTR=JXEXTR EXTR1=XEXTR1 EXTR2=XEXTR2 EXTR3=XEXTR3 EXTR4=XEXTR4 VAL1=XGAS(1) VALN=XGAS(NGAS) SYMBOL='v' NCSYMB=1 UNIT='[cm/microsec]' NCUNIT=13 ELSEIF(ITEM.EQ.3)THEN WRITE(LUNOUT,'(/'' Drift velocity along ExB:'')') IGASOK=10 IMETH=IYMETH IEXTR=IYEXTR JEXTR=JYEXTR EXTR1=YEXTR1 EXTR2=YEXTR2 EXTR3=YEXTR3 EXTR4=YEXTR4 VAL1=YGAS(1) VALN=YGAS(NGAS) SYMBOL='v' NCSYMB=1 UNIT='[cm/microsec]' NCUNIT=13 ELSEIF(ITEM.EQ.4)THEN WRITE(LUNOUT,'(/'' Angle between v and E:'')') IGASOK=7 IMETH=IWMETH IEXTR=IWEXTR JEXTR=JWEXTR EXTR1=WEXTR1 EXTR2=WEXTR2 EXTR3=WEXTR3 EXTR4=WEXTR4 VAL1=WGAS(1) VALN=WGAS(NGAS) SYMBOL='angle(v,E)' NCSYMB=10 UNIT='[radian]' NCUNIT=13 ELSEIF(ITEM.EQ.5)THEN WRITE(LUNOUT,'(/'' Ion mobility:'')') IGASOK=2 IMETH=IMMETH IEXTR=IMEXTR JEXTR=JMEXTR EXTR1=MEXTR1 EXTR2=MEXTR2 EXTR3=MEXTR3 EXTR4=MEXTR4 VAL1=MGAS(1) VALN=MGAS(NGAS) SYMBOL='mu ion' NCSYMB=6 UNIT='[cm^2/(microsec.V)]' NCUNIT=19 ELSEIF(ITEM.EQ.6)THEN WRITE(LUNOUT,'(/'' Longitudinal diffusion:'')') IGASOK=3 IMETH=IDMETH IEXTR=IDEXTR JEXTR=JDEXTR EXTR1=DEXTR1 EXTR2=DEXTR2 EXTR3=DEXTR3 EXTR4=DEXTR4 VAL1=DGAS(1) VALN=DGAS(NGAS) SYMBOL='sigma_L.sqrt(p)' NCSYMB=15 UNIT='[cm.sqrt(Torr) for 1 cm]' NCUNIT=24 ELSEIF(ITEM.EQ.7)THEN WRITE(LUNOUT,'(/'' Transverse diffusion:'')') IGASOK=8 IMETH=IOMETH IEXTR=IOEXTR JEXTR=JOEXTR EXTR1=OEXTR1 EXTR2=OEXTR2 EXTR3=OEXTR3 EXTR4=OEXTR4 VAL1=OGAS(1) VALN=OGAS(NGAS) SYMBOL='sigma_T.sqrt(p)' NCSYMB=15 UNIT='[cm.sqrt(Torr) for 1 cm]' NCUNIT=24 ELSEIF(ITEM.EQ.8)THEN WRITE(LUNOUT,'(/'' Townsend coefficient:'')') IGASOK=4 IMETH=IAMETH IEXTR=IAEXTR JEXTR=JAEXTR EXTR1=AEXTR1 EXTR2=AEXTR2 EXTR3=AEXTR3 EXTR4=AEXTR4 VAL1=AGAS(1) VALN=AGAS(NGAS) SYMBOL='log(alpha/p)' NCSYMB=12 UNIT='[-log(cm.Torr)]' NCUNIT=15 ELSEIF(ITEM.EQ.9)THEN WRITE(LUNOUT,'(/'' Attachment coefficient:'')') IGASOK=6 IMETH=IBMETH IEXTR=IBEXTR JEXTR=JBEXTR EXTR1=BEXTR1 EXTR2=BEXTR2 EXTR3=BEXTR3 EXTR4=BEXTR4 VAL1=BGAS(1) VALN=BGAS(NGAS) SYMBOL='log(eta/p)' NCSYMB=10 UNIT='[-log(cm.Torr)]' NCUNIT=15 ENDIF ** Quickly done if there is no such data. IF(.NOT.GASOK(IGASOK))THEN WRITE(LUNOUT,'('' Not applicable.'')') ** Data on a (E,angle,B) grid. ELSEIF(TAB2D)THEN * Interpolation method. IF(IMETH.EQ.1)THEN WRITE(LUNOUT,'(7X,''Linear interpolation for:'')') ELSEIF(IMETH.EQ.2)THEN WRITE(LUNOUT,'(7X,''Quadratic interpolation for:'')') ELSEIF(IMETH.EQ.3)THEN WRITE(LUNOUT,'(7X,''Cubic interpolation for:'')') ELSE WRITE(LUNOUT,'(7X,''# Inapplicable'', - '' interpolation method for:'')') ENDIF * Range of applicability. CALL OUTFMT(EGAS(1)*PGAS,2,STR1,NC1,'LEFT') CALL OUTFMT(EGAS(NGAS)*PGAS,2,STR2,NC2,'LEFT') WRITE(LUNOUT,'(11X,A,'' < E < '',A,'' V/cm,'')') - STR1(1:NC1),STR2(1:NC2) IF(NBANG.EQ.1)THEN WRITE(LUNOUT,'(11X,''all angles between E and B,'')') ELSE CALL OUTFMT(180*BANG(1)/PI,2,STR1,NC1,'LEFT') CALL OUTFMT(180*BANG(NBANG)/PI,2,STR2,NC2, - 'LEFT') WRITE(LUNOUT,'(11X,A,'' < angle(E,B) < '', - A,'' degrees,'')') STR1(1:NC1),STR2(1:NC2) ENDIF IF(NBANG.EQ.1)THEN WRITE(LUNOUT,'(11X,''all magnetic field strengths.'')') ELSE CALL OUTFMT(BTAB(1)/100,2,STR1,NC1,'LEFT') CALL OUTFMT(BTAB(NBTAB)/100,2,STR2,NC2,'LEFT') WRITE(LUNOUT,'(11X,A,'' < B < '',A,'' T.'')') - STR1(1:NC1),STR2(1:NC2) ENDIF * Special case of alpha and eta. IF((ITEM.EQ.8.AND.IATHR.GT.1).OR. - (ITEM.EQ.9.AND.IBTHR.GT.1))THEN CALL OUTFMT(EGAS(1)*PGAS,2,STR1,NC1,'LEFT') IF(ITEM.EQ.8)THEN CALL OUTFMT(EGAS(IATHR)*PGAS,2,STR2,NC2,'LEFT') ELSE CALL OUTFMT(EGAS(IBTHR)*PGAS,2,STR2,NC2,'LEFT') ENDIF WRITE(LUNOUT,'(7X,''For numeric stability, linear'', - '' interpolation is used in the subrange:''/ - 11X,A,'' < E < '',A,'' V/cm,'')') - STR1(1:NC1),STR2(1:NC2) ENDIF * Extrapolation method. WRITE(LUNOUT,'(7X,''Constant extrapolation for:''/ - 11X,''values outside this range.'')') ** Data only having E dependence. ELSE * Range limits. CALL OUTFMT(EGAS(1)*PGAS,2,STR1,NC1,'LEFT') CALL OUTFMT(EGAS(NGAS)*PGAS,2,STR2,NC2,'LEFT') * Extrapolation towards lower E/p. IF(JEXTR.EQ.0)THEN CALL OUTFMT(VAL1,2,STR5,NC5,'LEFT') WRITE(LUNOUT,'('' for E < '',A,'' V/cm: '', - A,'' = '',A,'' '',A,'','')') STR1(1:NC1), - SYMBOL(1:NCSYMB),STR5(1:NC5),UNIT(1:NCUNIT) ELSEIF(JEXTR.EQ.1)THEN CALL OUTFMT(EXTR3,2,STR3,NC3,'LEFT') CALL OUTFMT(ABS(EXTR4/PGAS),2,STR4,NC4,'LEFT') IF(EXTR4.LT.0)THEN WRITE(LUNOUT,'('' for E < '',A, - '' V/cm: '',A,'' = '',A,'' - '',A, - '' * E '',A,'','')') - STR1(1:NC1),SYMBOL(1:NCSYMB), - STR3(1:NC3),STR4(1:NC4),UNIT(1:NCUNIT) ELSE WRITE(LUNOUT,'('' for E < '',A, - '' V/cm: '',A,'' = '',A,'' + '',A, - '' * E '',A,'','')') - STR1(1:NC1),SYMBOL(1:NCSYMB), - STR3(1:NC3),STR4(1:NC4),UNIT(1:NCUNIT) ENDIF ELSEIF(JEXTR.EQ.2)THEN CALL OUTFMT(EXTR3,2,STR3,NC3,'LEFT') CALL OUTFMT(ABS(EXTR4/PGAS),2,STR4,NC4,'LEFT') IF(EXTR4.LT.0)THEN WRITE(LUNOUT,'('' for E < '',A, - '' V/cm: '',A,'' = exp('',A,'' - '',A, - '' * E) '',A,'','')') - STR1(1:NC1),SYMBOL(1:NCSYMB), - STR3(1:NC3),STR4(1:NC4),UNIT(1:NCUNIT) ELSE WRITE(LUNOUT,'('' for E < '',A, - '' V/cm: '',A,'' = exp('',A,'' + '',A, - '' * E) '',A,'','')') - STR1(1:NC1),SYMBOL(1:NCSYMB), - STR3(1:NC3),STR4(1:NC4),UNIT(1:NCUNIT) ENDIF ELSE PRINT *,' !!!!!! GASPRT WARNING : Unknown'// - ' extrapolation method seen.' ENDIF * Interpolation. IF(IMETH.EQ.0)THEN WRITE(LUNOUT,'('' for '',A,'' < E < '',A, - '' V/cm: '',A,'' is interpolated with cubic'', - '' splines,'')') STR1(1:NC1),STR2(1:NC2), - SYMBOL(1:NCSYMB) ELSEIF(IMETH.EQ.1)THEN WRITE(LUNOUT,'('' for '',A,'' < E < '',A, - '' V/cm: '',A,'' is linearly interpolated,'')') - STR1(1:NC1),STR2(1:NC2),SYMBOL(1:NCSYMB) ELSEIF(IMETH.EQ.2)THEN WRITE(LUNOUT,'('' for '',A,'' < E < '',A, - '' V/cm: '',A,'' is quadratically'', - '' interpolated,'')') - STR1(1:NC1),STR2(1:NC2),SYMBOL(1:NCSYMB) ELSEIF(IMETH.EQ.3)THEN WRITE(LUNOUT,'('' for '',A,'' < E < '',A, - '' V/cm: '',A,'' is cubicly interpolated,'')') - STR1(1:NC1),STR2(1:NC2),SYMBOL(1:NCSYMB) ELSE CALL OUTFMT(REAL(IMETH),2,STR6,NC6,'LEFT') WRITE(LUNOUT,'('' for '',A,'' < E < '',A, - '' V/cm: '',A,'' is interpolated with Newton'', - '' polynomials of order '',A)') - STR1(1:NC1),STR2(1:NC2),SYMBOL(1:NCSYMB), - STR6(1:NC6) ENDIF * Special case of alpha and eta. IF((ITEM.EQ.8.AND.IATHR.GT.1).OR. - (ITEM.EQ.9.AND.IBTHR.GT.1))THEN CALL OUTFMT(EGAS(1)*PGAS,2,STR3,NC3,'LEFT') IF(ITEM.EQ.8)THEN CALL OUTFMT(EGAS(IATHR)*PGAS,2,STR4,NC4,'LEFT') ELSE CALL OUTFMT(EGAS(IBTHR)*PGAS,2,STR4,NC4,'LEFT') ENDIF WRITE(LUNOUT,'(7X,''but for '',A,'' < E < '',A, - '' V/cm, linear interpolation is used for'', - '' better numeric stability,'')') - STR3(1:NC3),STR4(1:NC4) ENDIF * Extrapolation towards higher E/p. IF(IEXTR.EQ.0)THEN CALL OUTFMT(VALN,2,STR5,NC5,'LEFT') WRITE(LUNOUT,'('' for E > '',A,'' V/cm: '', - A,'' = '',A,'' '',A,''.'')') STR2(1:NC2), - SYMBOL(1:NCSYMB),STR5(1:NC5),UNIT(1:NCUNIT) ELSEIF(IEXTR.EQ.1)THEN CALL OUTFMT(EXTR1,2,STR3,NC3,'LEFT') CALL OUTFMT(ABS(EXTR2/PGAS),2,STR4,NC4,'LEFT') IF(EXTR2.LT.0)THEN WRITE(LUNOUT,'('' for E > '',A, - '' V/cm: '',A,'' = '',A,'' - '',A, - '' * E '',A,''.'')') - STR1(1:NC1),SYMBOL(1:NCSYMB), - STR3(1:NC3),STR4(1:NC4),UNIT(1:NCUNIT) ELSE WRITE(LUNOUT,'('' for E > '',A, - '' V/cm: '',A,'' = '',A,'' + '',A, - '' * E '',A,''.'')') - STR1(1:NC1),SYMBOL(1:NCSYMB), - STR3(1:NC3),STR4(1:NC4),UNIT(1:NCUNIT) ENDIF ELSEIF(IEXTR.EQ.2)THEN CALL OUTFMT(EXTR1,2,STR3,NC3,'LEFT') CALL OUTFMT(ABS(EXTR2/PGAS),2,STR4,NC4,'LEFT') IF(EXTR2.LT.0)THEN WRITE(LUNOUT,'('' for E > '',A, - '' V/cm: '',A,'' = exp('',A,'' - '',A, - '' * E) '',A,''.'')') - STR1(1:NC1),SYMBOL(1:NCSYMB), - STR3(1:NC3),STR4(1:NC4),UNIT(1:NCUNIT) ELSE WRITE(LUNOUT,'('' for E > '',A, - '' V/cm: '',A,'' = exp('',A,'' + '',A, - '' * E) '',A,''.'')') - STR1(1:NC1),SYMBOL(1:NCSYMB), - STR3(1:NC3),STR4(1:NC4),UNIT(1:NCUNIT) ENDIF ELSE PRINT *,' !!!!!! GASPRT WARNING : Unknown'// - ' extrapolation method seen.' ENDIF ENDIF ** Next item. 50 CONTINUE *** Print some information about the clustersize information. 100 CONTINUE CALL OUTFMT(PGAS,2,STR1,NC1,'LEFT') CALL OUTFMT(TGAS,2,STR2,NC2,'LEFT') WRITE(LUNOUT,'(// - '' Other data:''// - '' Pressure of the gas : '',A,'' Torr''/ - '' Temperature of the gas : '',A,'' K''/)') - STR1(1:NC1),STR2(1:NC2) IF(CLSTYP.EQ.'LANDAU'.AND.GASOK(5))THEN CALL OUTFMT(Z,2,STR1,NC1,'LEFT') CALL OUTFMT(A,2,STR2,NC2,'LEFT') CALL OUTFMT(RHO,2,STR3,NC3,'LEFT') CALL OUTFMT(EMPROB,2,STR4,NC4,'LEFT') CALL OUTFMT(EPAIR,2,STR5,NC5,'LEFT') WRITE(LUNOUT,'( - '' Number of protons in one molecule : '',A/ - '' Atomic number of the gas : '',A/ - '' Density : '',A, - '' g/cm3''/ - '' Most probable energy loss per cm : '',A, - '' eV/cm''/ - '' Energy needed for one ion pair : '',A, - '' eV'')') STR1(1:NC1),STR2(1:NC2), - STR3(1:NC3),STR4(1:NC4),STR5(1:NC5) ENDIF IF(GASOK(5))THEN CALL OUTFMT(CMEAN,2,STR1,NC1,'LEFT') WRITE(LUNOUT,'( - '' Average number of clusters : '',A, - '' per cm'')') STR1(1:NC1) ENDIF CALL OUTFMT(10000*DLION,2,STR1,NC1,'LEFT') CALL OUTFMT(10000*DTION,2,STR2,NC2,'LEFT') WRITE(LUNOUT,'( - '' Longitudinal ion diffusion : '',A, - '' micron for 1 cm of drift''/ - '' Transverse ion diffusion : '',A, - '' micron for 1 cm of drift'')') STR1(1:NC1),STR2(1:NC2) *** Register the amount of CPU time used for printing, CALL TIMLOG('Printing of the gas data: ') END +DECK,GASWRT. SUBROUTINE GASWRT(IMODE) *----------------------------------------------------------------------- * GASWRT - This routine writes all gas information on an external * dataset. * VARIABLES : IMODE : If 1 : find name, if 2 write gas data * IACC : If 0 no name specified, no write * If 1 name OK, write will be executed * (Last changed on 12/ 2/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,GASDATA. +SEQ,BFIELD. +SEQ,PRINTPLOT. CHARACTER*(MXCHAR) STRING CHARACTER*29 REMARK CHARACTER*8 TIME,DATE,MEMBER CHARACTER*(MXNAME) FILE LOGICAL EXMEMB INTEGER IACC,IMODE,NCFILE,NCMEMB,NCREM,INPCMP,NWORD,INEXT,I,J,K, - II,IOS,IFAIL EXTERNAL INPCMP +SELF,IF=SAVE. SAVE IACC,FILE,NCFILE,MEMBER,NCMEMB,REMARK,NCREM +SELF. DATA IACC/0/ *** Identify the routine, if requested. IF(LIDENT)PRINT *,' /// ROUTINE GASWRT ///' *** Goto 200 if a write is requested. IF(IMODE.EQ.2)GOTO 200 * Set the file name etc. IACC=0 FILE=' ' NCFILE=1 MEMBER='< none >' NCMEMB=8 REMARK='none' NCREM=4 * First decode the argument string. CALL INPNUM(NWORD) * Make sure there is at least one argument. IF(NWORD.EQ.1)THEN PRINT *,' !!!!!! GASWRT WARNING : WRITE takes at least one', - ' argument (a dataset name); data will not be written.' RETURN * Check whether keywords have been used. ELSEIF(INPCMP(2,'D#ATASET')+INPCMP(2,'R#EMARK').NE.0)THEN INEXT=2 DO 10 I=2,NWORD IF(I.LT.INEXT)GOTO 10 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 10 CONTINUE * Otherwise the string is interpreted as a file name (+ member name). ELSE CALL INPSTR(2,2,STRING,NCFILE) FILE=STRING IF(NWORD.GE.3)THEN CALL INPSTR(3,3,STRING,NCMEMB) MEMBER=STRING ENDIF IF(NWORD.GE.4)THEN CALL INPSTR(4,NWORD,STRING,NCREM) REMARK=STRING ENDIF ENDIF * Print error messages. CALL INPERR IF(NCFILE.GT.MXNAME)PRINT *,' !!!!!! GASWRT WARNING : The file', - ' name is truncated to MXNAME (=',MXNAME,') characters.' IF(NCMEMB.GT.8)PRINT *,' !!!!!! GASWRT WARNING : The member', - ' name is shortened to ',MEMBER,', first 8 characters.' IF(NCREM.GT.29)PRINT *,' !!!!!! GASWRT 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),'GAS',EXMEMB) IF(JEXMEM.EQ.2.AND.EXMEMB)THEN PRINT *,' ------ GASWRT MESSAGE : A copy of the member'// - ' exists; new member will be appended.' ELSEIF(JEXMEM.EQ.3.AND.EXMEMB)THEN PRINT *,' !!!!!! GASWRT WARNING : A copy of the member'// - ' exists already; member will not be written.' RETURN ENDIF * Everything seems to be OK, the accept flag can be set to 'accept'. IACC=1 * Print some debugging output if requested. IF(LDEBUG)THEN PRINT *,' ++++++ GASWRT DEBUG : File= ',FILE(1:NCFILE), - ', member= ',MEMBER(1:NCMEMB),' IACC=',IACC PRINT *,' Remark= ',REMARK(1:NCREM) ENDIF RETURN *** Execute write operation if a valid name is available. 200 CONTINUE IF(IACC.EQ.0)RETURN IACC=0 * Open a dataset and inform DSNLOG. CALL DSNOPN(FILE,NCFILE,12,'WRITE-LIBRARY',IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! GASWRT WARNING : Opening ',FILE(1:NCFILE), - ' failed ; gas data will not be written' RETURN ENDIF CALL DSNLOG(FILE,'Gas data ','Sequential','Write ') IF(LDEBUG)PRINT *,' ++++++ GASWRT 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,'' GAS '', - 1X,''"'',A29,''"'')') DATE,TIME,MEMBER,REMARK WRITE(12,'(A80)',IOSTAT=IOS,ERR=2010) STRING * Write a version number. WRITE(12,'('' Version : 3'')') * Write the gas to the dataset. WRITE(12,'('' GASOK bits: '',10L1)',IOSTAT=IOS,ERR=2010) - (GASOK(I),I=1,10) WRITE(12,'('' Identifier: '',A)',IOSTAT=IOS,ERR=2010) GASID WRITE(12,'('' Clusters : '',A80)',IOSTAT=IOS,ERR=2010) FCNTAB WRITE(12,'('' Dimension : '',L1,3I10)',IOSTAT=IOS,ERR=2010) - TAB2D,NGAS,NBANG,NBTAB WRITE(12,'('' The gas tables follow:'')',IOSTAT=IOS,ERR=2010) IF(TAB2D)THEN WRITE(12,'('' E-B angles ''/(5E15.8))',IOSTAT=IOS,ERR=2010) - (BANG(I),I=1,NBANG) WRITE(12,'('' B fields ''/(5E15.8))',IOSTAT=IOS,ERR=2010) - (BTAB(I),I=1,NBTAB) DO 210 I=1,NGAS DO 220 J=1,NBANG DO 230 K=1,NBTAB WRITE(12,'(8E15.8/2E15.8)',IOSTAT=IOS,ERR=2010) - EGAS(I),VGAS2(I,J,K),XGAS2(I,J,K),YGAS2(I,J,K), - DGAS2(I,J,K),OGAS2(I,J,K), - AGAS2(I,J,K),BGAS2(I,J,K),MGAS2(I,J,K),WGAS2(I,J,K) 230 CONTINUE 220 CONTINUE 210 CONTINUE ELSE DO 240 I=1,NGAS WRITE(12,'(8E15.8/15X,7E15.8/15X,4E15.8)',IOSTAT=IOS, - ERR=2010) - EGAS(I), - VGAS(I),CVGAS(I),XGAS(I),CXGAS(I),YGAS(I),CYGAS(I), - DGAS(I),CDGAS(I),OGAS(I),COGAS(I), - AGAS(I),CAGAS(I),BGAS(I),CBGAS(I),MGAS(I),CMGAS(I), - WGAS(I),CWGAS(I) 240 CONTINUE WRITE(12,'('' H Extr: '',9(/I2,2E15.8))',IOSTAT=IOS, - ERR=2010) - IVEXTR,VEXTR1,VEXTR2, - IXEXTR,XEXTR1,XEXTR2,IYEXTR,YEXTR1,YEXTR2, - IDEXTR,DEXTR1,DEXTR2, - IAEXTR,AEXTR1,AEXTR2,IBEXTR,BEXTR1,BEXTR2, - IMEXTR,MEXTR1,MEXTR2,IWEXTR,WEXTR1,WEXTR2, - IOEXTR,OEXTR1,OEXTR2 WRITE(12,'('' L Extr: '',9(/I2,2E15.8))',IOSTAT=IOS, - ERR=2010) - JVEXTR,VEXTR3,VEXTR4, - JXEXTR,XEXTR3,XEXTR4,JYEXTR,YEXTR3,YEXTR4, - JDEXTR,DEXTR3,DEXTR4, - JAEXTR,AEXTR3,AEXTR4,JBEXTR,BEXTR3,BEXTR4, - JMEXTR,MEXTR3,MEXTR4,JWEXTR,WEXTR3,WEXTR4, - JOEXTR,OEXTR3,OEXTR4 ENDIF WRITE(12,'('' Thresholds: '',2I10)') IATHR,IBTHR WRITE(12,'('' Interp: '',9I10)',IOSTAT=IOS,ERR=2010) - IVMETH,IXMETH,IYMETH,IDMETH,IAMETH,IBMETH,IMMETH, - IWMETH,IOMETH WRITE(12,'('' A ='',E15.8,'', Z ='',E15.8, - '', EMPROB='',E15.8,'', EPAIR ='',E15.8)',IOSTAT=IOS, - ERR=2010) A,Z,EMPROB,EPAIR WRITE(12,'('' Ion diffusion: '',2E15.8)') DLION,DTION WRITE(12,'('' CMEAN ='',E15.8,'', RHO ='',E15.8, - '', PGAS ='',E15.8,'', TGAS ='',E15.8)',IOSTAT=IOS, - ERR=2010) CMEAN,RHO,PGAS,TGAS WRITE(12,'('' CLSTYP : '',A10)',IOSTAT=IOS,ERR=2010) CLSTYP WRITE(12,'('' FCNCLS : '',A80)',IOSTAT=IOS,ERR=2010) FCNCLS WRITE(12,'('' NCLS : '',2I10)',IOSTAT=IOS,ERR=2010) NCLS WRITE(12,'('' Average : '',D25.18)',IOSTAT=IOS,ERR=2010) CLSAVE DO 250 II=1,NCLS,5 WRITE(12,'(5D25.18)',IOSTAT=IOS,ERR=2010) - (CLSDIS(I),I=II,MIN(II+4,NCLS)) 250 CONTINUE * Write the Heed data to the file. CALL GASHWR(IFAIL) IF(IFAIL.NE.0)PRINT *,' !!!!!! GASWRT WARNING : Writing the'// - ' Heed data failed ; gas data unuseable.' * Close the file after the operation. CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) IACC=0 CALL TIMLOG('Writing the gas data to a dataset: ') RETURN *** Handle the I/O error conditions. 2010 CONTINUE PRINT *,' ###### GASWRT ERROR : Error while writing'// - ' to '//FILE(1:NCFILE)//' via unit 12 ; gas data unuseable.' CALL INPIOS(IOS) CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) RETURN 2030 CONTINUE PRINT *,' ###### GASWRT ERROR : Dataset '//FILE(1:NCFILE)// - ' on unit 12 cannot be closed ; results not predictable' CALL INPIOS(IOS) END +DECK,GASVEL. REAL FUNCTION GASVEL(EX,EY,EZ,BX,BY,BZ) *----------------------------------------------------------------------- * GASVEL - Function calculating the drift speed along E. * VARIABLES : SPEED : The actual speed (=GASVEL) * (Last changed on 13/ 2/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,GASDATA. +SEQ,BFIELD. REAL EX,EY,EZ,E,BX,BY,BZ,B,EBANG,DIVDIF,SPEED INTEGER IFAIL EXTERNAL DIVDIF *** Obtain the magnitude of the electric field. E=SQRT(EX**2+EY**2+EZ**2) IF(E.LE.0.0)THEN GASVEL=0.0 RETURN ENDIF *** Treat the case that the table is 2-dimensional. IF(TAB2D)THEN * B field magnitude. B=SQRT(BX**2+BY**2+BZ**2) * Obtain the angle between B field and E field. IF(E*B.EQ.0)THEN EBANG=BANG(1) ELSEIF(ABS(EX*BX+EY*BY+EZ*BZ).GT.0.2*E*B)THEN EBANG=ASIN(MIN(1.0,SQRT((EX*BY-EY*BX)**2+ - (EX*BZ-EZ*BX)**2+(EZ*BY-EY*BZ)**2)/(E*B))) ELSE EBANG=ACOS(MIN(1.0,ABS((EX*BX+EY*BY+EZ*BZ)/(E*B)))) ENDIF * Interpolate. CALL BOXIN3(VGAS2,EGAS,BANG,BTAB,MXLIST,MXBANG,MXBTAB, - NGAS,NBANG,NBTAB,E/PGAS,EBANG,B,SPEED,IVMETH,IFAIL) GASVEL=SPEED * Verify error. IF(IFAIL.NE.0)GASVEL=0 *** Treat the case that the table is 1-dimensional. ELSE * Extrapolation towards small E/p. IF(E/PGAS.LT.EGAS(1))THEN GASVEL=VGAS(1) IF(JVEXTR.EQ.1)GASVEL=VEXTR3+VEXTR4*E/PGAS IF(JVEXTR.EQ.2)GASVEL=EXP(MIN(50.0, - VEXTR3+VEXTR4*E/PGAS)) * Extrapolation towards large E/p. ELSEIF(E/PGAS.GT.EGAS(NGAS))THEN GASVEL=VGAS(NGAS) IF(IVEXTR.EQ.1)GASVEL=VEXTR1+VEXTR2*E/PGAS IF(IVEXTR.EQ.2)GASVEL=EXP(MIN(50.0, - VEXTR1+VEXTR2*E/PGAS)) * Only one point. ELSEIF(NGAS.LE.1)THEN GASVEL=VGAS(1) * Intermediate points, spline interpolation. ELSEIF(IVMETH.EQ.0)THEN CALL INTERP(EGAS,VGAS,CVGAS,NGAS,E/PGAS,SPEED,IFAIL) GASVEL=SPEED * Intermediate points, Newton interpolation. ELSE GASVEL=DIVDIF(VGAS,EGAS,NGAS,E/PGAS,IVMETH) ENDIF ENDIF END +DECK,GASVT1. REAL FUNCTION GASVT1(EX,EY,EZ,BX,BY,BZ) *----------------------------------------------------------------------- * GASVT1 - Function calculating the drift speed along Btrans. * VARIABLES : SPEED : The actual speed (=GASVT1) * (Last changed on 18/ 2/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,GASDATA. +SEQ,BFIELD. REAL EX,EY,EZ,E,BX,BY,BZ,B,EBANG,DIVDIF,SPEED INTEGER IFAIL EXTERNAL DIVDIF *** Obtain the magnitude of the electric field. E=SQRT(EX**2+EY**2+EZ**2) IF(E.LE.0.0)THEN GASVT1=0.0 RETURN ENDIF *** Treat the case that the table is 2-dimensional. IF(TAB2D)THEN * B field magnitude. B=SQRT(BX**2+BY**2+BZ**2) * Obtain the angle between B field and E field. IF(E*B.EQ.0)THEN EBANG=BANG(1) ELSEIF(ABS(EX*BX+EY*BY+EZ*BZ).GT.0.2*E*B)THEN EBANG=ASIN(MIN(1.0,SQRT((EX*BY-EY*BX)**2+ - (EX*BZ-EZ*BX)**2+(EZ*BY-EY*BZ)**2)/(E*B))) ELSE EBANG=ACOS(MIN(1.0,ABS((EX*BX+EY*BY+EZ*BZ)/(E*B)))) ENDIF * Interpolate. CALL BOXIN3(XGAS2,EGAS,BANG,BTAB,MXLIST,MXBANG,MXBTAB, - NGAS,NBANG,NBTAB,E/PGAS,EBANG,B,SPEED,IXMETH,IFAIL) GASVT1=SPEED * Verify error. IF(IFAIL.NE.0)GASVT1=0 *** Treat the case that the table is 1-dimensional. ELSE * Extrapolation towards small E/p. IF(E/PGAS.LT.EGAS(1))THEN GASVT1=XGAS(1) IF(JXEXTR.EQ.1)GASVT1=XEXTR3+XEXTR4*E/PGAS IF(JXEXTR.EQ.2)GASVT1=EXP(MIN(50.0, - XEXTR3+XEXTR4*E/PGAS)) * Extrapolation towards large E/p. ELSEIF(E/PGAS.GT.EGAS(NGAS))THEN GASVT1=XGAS(NGAS) IF(IXEXTR.EQ.1)GASVT1=XEXTR1+XEXTR2*E/PGAS IF(IXEXTR.EQ.2)GASVT1=EXP(MIN(50.0, - XEXTR1+XEXTR2*E/PGAS)) * Only one point. ELSEIF(NGAS.LE.1)THEN GASVT1=XGAS(1) * Intermediate points, spline interpolation. ELSEIF(IXMETH.EQ.0)THEN CALL INTERP(EGAS,XGAS,CXGAS,NGAS,E/PGAS,SPEED,IFAIL) GASVT1=SPEED * Intermediate points, Newton interpolation. ELSE GASVT1=DIVDIF(XGAS,EGAS,NGAS,E/PGAS,IXMETH) ENDIF ENDIF *** Get the sign right. IF(EX*BX+EY*BY+EZ*BZ.GT.0)THEN GASVT1=ABS(GASVT1) ELSE GASVT1=-ABS(GASVT1) ENDIF END +DECK,GASVT2. REAL FUNCTION GASVT2(EX,EY,EZ,BX,BY,BZ) *----------------------------------------------------------------------- * GASVT2 - Function calculating the drift speed along ExB. * VARIABLES : SPEED : The actual speed (=GASVT2) * (Last changed on 13/ 2/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,GASDATA. +SEQ,BFIELD. REAL EX,EY,EZ,E,BX,BY,BZ,B,EBANG,DIVDIF,SPEED INTEGER IFAIL EXTERNAL DIVDIF *** Obtain the magnitude of the electric field. E=SQRT(EX**2+EY**2+EZ**2) IF(E.LE.0.0)THEN GASVT2=0.0 RETURN ENDIF *** Treat the case that the table is 2-dimensional. IF(TAB2D)THEN * B field magnitude. B=SQRT(BX**2+BY**2+BZ**2) * Obtain the angle between B field and E field. IF(E*B.EQ.0)THEN EBANG=BANG(1) ELSEIF(ABS(EX*BX+EY*BY+EZ*BZ).GT.0.2*E*B)THEN EBANG=ASIN(MIN(1.0,SQRT((EX*BY-EY*BX)**2+ - (EX*BZ-EZ*BX)**2+(EZ*BY-EY*BZ)**2)/(E*B))) ELSE EBANG=ACOS(MIN(1.0,ABS((EX*BX+EY*BY+EZ*BZ)/(E*B)))) ENDIF * Interpolate. CALL BOXIN3(YGAS2,EGAS,BANG,BTAB,MXLIST,MXBANG,MXBTAB, - NGAS,NBANG,NBTAB,E/PGAS,EBANG,B,SPEED,IYMETH,IFAIL) GASVT2=SPEED * Verify error. IF(IFAIL.NE.0)GASVT2=0 *** Treat the case that the table is 1-dimensional. ELSE * Extrapolation towards small E/p. IF(E/PGAS.LT.EGAS(1))THEN GASVT2=YGAS(1) IF(JYEXTR.EQ.1)GASVT2=YEXTR3+YEXTR4*E/PGAS IF(JYEXTR.EQ.2)GASVT2=EXP(MIN(50.0, - YEXTR3+YEXTR4*E/PGAS)) * Extrapolation towards large E/p. ELSEIF(E/PGAS.GT.EGAS(NGAS))THEN GASVT2=YGAS(NGAS) IF(IYEXTR.EQ.1)GASVT2=YEXTR1+YEXTR2*E/PGAS IF(IYEXTR.EQ.2)GASVT2=EXP(MIN(50.0, - YEXTR1+YEXTR2*E/PGAS)) * Only one point. ELSEIF(NGAS.LE.1)THEN GASVT2=YGAS(1) * Intermediate points, spline interpolation. ELSEIF(IYMETH.EQ.0)THEN CALL INTERP(EGAS,YGAS,CYGAS,NGAS,E/PGAS,SPEED,IFAIL) GASVT2=SPEED * Intermediate points, Newton interpolation. ELSE GASVT2=DIVDIF(YGAS,EGAS,NGAS,E/PGAS,IYMETH) ENDIF ENDIF END +DECK,GASLOR. REAL FUNCTION GASLOR(EX,EY,EZ,BX,BY,BZ) *----------------------------------------------------------------------- * GASLOR - Function calculating the Lorentz angle in a gas. * (Last changed on 13/ 2/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,GASDATA. +SEQ,BFIELD. REAL EX,EY,EZ,BX,BY,BZ,B,E,EBANG,DIVDIF,AUXLOR INTEGER IFAIL EXTERNAL DIVDIF *** Obtain the magnitude of the electric field. E=SQRT(EX**2+EY**2+EZ**2) IF(E.LE.0.0)THEN GASLOR=0.0 RETURN ENDIF *** Treat the case that the table is 2-dimensional. IF(TAB2D)THEN * B field magnitude. B=SQRT(BX**2+BY**2+BZ**2) * Obtain the angle between B field and E field. IF(E*B.EQ.0)THEN EBANG=BANG(1) ELSEIF(ABS(EX*BX+EY*BY+EZ*BZ).GT.0.2*E*B)THEN EBANG=ASIN(MIN(1.0,SQRT((EX*BY-EY*BX)**2+ - (EX*BZ-EZ*BX)**2+(EZ*BY-EY*BZ)**2)/(E*B))) ELSE EBANG=ACOS(MIN(1.0,ABS((EX*BX+EY*BY+EZ*BZ)/(E*B)))) ENDIF * Interpolate. CALL BOXIN3(WGAS2,EGAS,BANG,BTAB,MXLIST,MXBANG,MXBTAB, - NGAS,NBANG,NBTAB,E/PGAS,EBANG,B,AUXLOR,IWMETH,IFAIL) GASLOR=AUXLOR * Verify error. IF(IFAIL.NE.0)GASLOR=0 *** Treat the case that the table is 1-dimensional. ELSE * Extrapolation towards small E/p. IF(E/PGAS.LT.EGAS(1))THEN GASLOR=WGAS(1) IF(JWEXTR.EQ.1)GASLOR=WEXTR3+WEXTR4*E/PGAS IF(JWEXTR.EQ.2)GASLOR=EXP(MIN(50.0, - WEXTR3+WEXTR4*E/PGAS)) * Extrapolation towards large E/p. ELSEIF(E/PGAS.GT.EGAS(NGAS))THEN GASLOR=WGAS(NGAS) IF(IWEXTR.EQ.1)GASLOR=WEXTR1+WEXTR2*E/PGAS IF(IWEXTR.EQ.2)GASLOR=EXP(MIN(50.0, - WEXTR1+WEXTR2*E/PGAS)) * Only one point. ELSEIF(NGAS.LE.1)THEN GASLOR=WGAS(1) * Intermediate points, spline interpolation. ELSEIF(IWMETH.EQ.0)THEN CALL INTERP(EGAS,WGAS,CWGAS,NGAS,E/PGAS,AUXLOR,IFAIL) GASLOR=AUXLOR * Intermediate points, Newton interpolation. ELSE GASLOR=DIVDIF(WGAS,EGAS,NGAS,E/PGAS,IWMETH) ENDIF ENDIF END +DECK,GASMOB. REAL FUNCTION GASMOB(EX,EY,EZ,BX,BY,BZ) *----------------------------------------------------------------------- * GASMOB - Function calculating the ion mobility in a gas. * (Last changed on 13/ 2/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,GASDATA. +SEQ,BFIELD. REAL EX,EY,EZ,BX,BY,BZ,B,E,DIVDIF,EBANG,AUXMOB INTEGER IFAIL EXTERNAL DIVDIF *** Obtain the magnitude of the electric field. E=SQRT(EX**2+EY**2+EZ**2) IF(E.LE.0.0)THEN GASMOB=0.0 RETURN ENDIF *** Treat the case that the table is 2-dimensional. IF(TAB2D)THEN * B field magnitude. B=SQRT(BX**2+BY**2+BZ**2) * Obtain the angle between B field and E field. IF(E*B.EQ.0)THEN EBANG=BANG(1) ELSEIF(ABS(EX*BX+EY*BY+EZ*BZ).GT.0.2*E*B)THEN EBANG=ASIN(MIN(1.0,SQRT((EX*BY-EY*BX)**2+ - (EX*BZ-EZ*BX)**2+(EZ*BY-EY*BZ)**2)/(E*B))) ELSE EBANG=ACOS(MIN(1.0,ABS((EX*BX+EY*BY+EZ*BZ)/(E*B)))) ENDIF * Interpolate. CALL BOXIN3(MGAS2,EGAS,BANG,BTAB,MXLIST,MXBANG,MXBTAB, - NGAS,NBANG,NBTAB,E/PGAS,EBANG,B,AUXMOB,IMMETH,IFAIL) GASMOB=AUXMOB * Verify error. IF(IFAIL.NE.0)GASMOB=0 *** Treat the case that the table is 1-dimensional. ELSE * Extrapolation towards small E/p. IF(E/PGAS.LT.EGAS(1))THEN GASMOB=MGAS(1) IF(JMEXTR.EQ.1)GASMOB=MEXTR3+MEXTR4*E/PGAS IF(JMEXTR.EQ.2)GASMOB=EXP(MIN(50.0, - MEXTR3+MEXTR4*E/PGAS)) * Extrapolation towards large E/p. ELSEIF(E/PGAS.GT.EGAS(NGAS))THEN GASMOB=MGAS(NGAS) IF(IMEXTR.EQ.1)GASMOB=MEXTR1+MEXTR2*E/PGAS IF(IMEXTR.EQ.2)GASMOB=EXP(MIN(50.0, - MEXTR1+MEXTR2*E/PGAS)) * Only one point. ELSEIF(NGAS.LE.1)THEN GASMOB=MGAS(1) * Intermediate points, spline interpolation. ELSEIF(IMMETH.EQ.0)THEN CALL INTERP(EGAS,MGAS,CMGAS,NGAS,E/PGAS,AUXMOB,IFAIL) GASMOB=AUXMOB * Intermediate points, Newton interpolation. ELSE GASMOB=DIVDIF(MGAS,EGAS,NGAS,E/PGAS,IMMETH) ENDIF ENDIF END +DECK,GASDFT. REAL FUNCTION GASDFT(EX,EY,EZ,BX,BY,BZ) *----------------------------------------------------------------------- * GASDFT - Function calculating the transverse diffusion. * VARIABLES : none * (Last changed on 13/ 2/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,GASDATA. +SEQ,BFIELD. REAL EX,EY,EZ,BX,BY,BZ,B,E,EBANG,DIVDIF,DIFF INTEGER IFAIL EXTERNAL DIVDIF *** Obtain the magnitude of the electric field. E=SQRT(EX**2+EY**2+EZ**2) IF(E.LE.0.0)THEN GASDFT=0.0 RETURN ENDIF *** Treat the case that the table is 2-dimensional. IF(TAB2D)THEN * B field magnitude. B=SQRT(BX**2+BY**2+BZ**2) * Obtain the angle between B field and E field. IF(E*B.EQ.0)THEN EBANG=BANG(1) ELSEIF(ABS(EX*BX+EY*BY+EZ*BZ).GT.0.2*E*B)THEN EBANG=ASIN(MIN(1.0,SQRT((EX*BY-EY*BX)**2+ - (EX*BZ-EZ*BX)**2+(EZ*BY-EY*BZ)**2)/(E*B))) ELSE EBANG=ACOS(MIN(1.0,ABS((EX*BX+EY*BY+EZ*BZ)/(E*B)))) ENDIF * Interpolate. CALL BOXIN3(OGAS2,EGAS,BANG,BTAB,MXLIST,MXBANG,MXBTAB, - NGAS,NBANG,NBTAB,E/PGAS,EBANG,B,DIFF,IOMETH,IFAIL) GASDFT=DIFF * Verify error. IF(IFAIL.NE.0)GASDFT=0 *** Treat the case that the table is 1-dimensional. ELSE * Extrapolation towards small E/p. IF(E/PGAS.LT.EGAS(1))THEN GASDFT=OGAS(1) IF(JOEXTR.EQ.1)GASDFT=OEXTR3+OEXTR4*E/PGAS IF(JOEXTR.EQ.2)GASDFT=EXP(MIN(50.0, - OEXTR3+OEXTR4*E/PGAS)) * Extrapolation towards large E/p. ELSEIF(E/PGAS.GT.EGAS(NGAS))THEN GASDFT=OGAS(NGAS) IF(IOEXTR.EQ.1)GASDFT=OEXTR1+OEXTR2*E/PGAS IF(IOEXTR.EQ.2)GASDFT=EXP(MIN(50.0, - OEXTR1+OEXTR2*E/PGAS)) * Only one point. ELSEIF(NGAS.LE.1)THEN GASDFT=OGAS(1) * Intermediate points, spline interpolation. ELSEIF(IOMETH.EQ.0)THEN CALL INTERP(EGAS,OGAS,COGAS,NGAS,E/PGAS,DIFF,IFAIL) GASDFT=DIFF * Intermediate points, Newton interpolation. ELSE GASDFT=DIVDIF(OGAS,EGAS,NGAS,E/PGAS,IOMETH) ENDIF ENDIF *** Verify value and scale by pressure. IF(GASDFT.LT.0.0)GASDFT=0.0 GASDFT=GASDFT/SQRT(PGAS) END +DECK,GASDFL. REAL FUNCTION GASDFL(EX,EY,EZ,BX,BY,BZ) *----------------------------------------------------------------------- * GASDFL - Function calculating the longitudinal diffusion. * VARIABLES : none * (Last changed on 13/ 2/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,GASDATA. +SEQ,BFIELD. REAL EX,EY,EZ,BX,BY,BZ,B,E,EBANG,DIVDIF,DIFF INTEGER IFAIL EXTERNAL DIVDIF *** Obtain the magnitude of the electric field. E=SQRT(EX**2+EY**2+EZ**2) IF(E.LE.0.0)THEN GASDFL=0.0 RETURN ENDIF *** Treat the case that the table is 2-dimensional. IF(TAB2D)THEN * B field magnitude. B=SQRT(BX**2+BY**2+BZ**2) * Obtain the angle between B field and E field. IF(E*B.EQ.0)THEN EBANG=BANG(1) ELSEIF(ABS(EX*BX+EY*BY+EZ*BZ).GT.0.2*E*B)THEN EBANG=ASIN(MIN(1.0,SQRT((EX*BY-EY*BX)**2+ - (EX*BZ-EZ*BX)**2+(EZ*BY-EY*BZ)**2)/(E*B))) ELSE EBANG=ACOS(MIN(1.0,ABS((EX*BX+EY*BY+EZ*BZ)/(E*B)))) ENDIF * Interpolate. CALL BOXIN3(DGAS2,EGAS,BANG,BTAB,MXLIST,MXBANG,MXBTAB, - NGAS,NBANG,NBTAB,E/PGAS,EBANG,B,DIFF,IDMETH,IFAIL) GASDFL=DIFF * Verify error. IF(IFAIL.NE.0)GASDFL=0 *** Treat the case that the table is 1-dimensional. ELSE * Extrapolation towards small E/p. IF(E/PGAS.LT.EGAS(1))THEN GASDFL=DGAS(1) IF(JDEXTR.EQ.1)GASDFL=DEXTR3+DEXTR4*E/PGAS IF(JDEXTR.EQ.2)GASDFL=EXP(MIN(50.0, - DEXTR3+DEXTR4*E/PGAS)) * Extrapolation towards large E/p. ELSEIF(E/PGAS.GT.EGAS(NGAS))THEN GASDFL=DGAS(NGAS) IF(IDEXTR.EQ.1)GASDFL=DEXTR1+DEXTR2*E/PGAS IF(IDEXTR.EQ.2)GASDFL=EXP(MIN(50.0, - DEXTR1+DEXTR2*E/PGAS)) * Only one point. ELSEIF(NGAS.LE.1)THEN GASDFL=DGAS(1) * Intermediate points, spline interpolation. ELSEIF(IDMETH.EQ.0)THEN CALL INTERP(EGAS,DGAS,CDGAS,NGAS,E/PGAS,DIFF,IFAIL) GASDFL=DIFF * Intermediate points, Newton interpolation. ELSE GASDFL=DIVDIF(DGAS,EGAS,NGAS,E/PGAS,IDMETH) ENDIF ENDIF *** Verify value and scale by pressure. IF(GASDFL.LT.0.0)GASDFL=0.0 GASDFL=GASDFL/SQRT(PGAS) END +DECK,GASTWN. REAL FUNCTION GASTWN(EX,EY,EZ,BX,BY,BZ) *----------------------------------------------------------------------- * GASTWN - Function calculating the Townsend coefficient for a field E * using a spline interpolation. * VARIABLES : AUX : The Townsend constant (=GASTWN). * (Last changed on 13/ 2/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,GASDATA. +SEQ,BFIELD. REAL EX,EY,EZ,BX,BY,BZ,B,E,EBANG,DIVDIF,AUXTWN INTEGER IFAIL EXTERNAL DIVDIF *** Obtain the magnitude of the electric field. E=SQRT(EX**2+EY**2+EZ**2) IF(E.LE.0.0)THEN GASTWN=0.0 RETURN ENDIF *** Treat the case that the table is 2-dimensional. IF(TAB2D)THEN * B field magnitude. B=SQRT(BX**2+BY**2+BZ**2) * Obtain the angle between B field and E field. IF(E*B.EQ.0)THEN EBANG=BANG(1) ELSEIF(ABS(EX*BX+EY*BY+EZ*BZ).GT.0.2*E*B)THEN EBANG=ASIN(MIN(1.0,SQRT((EX*BY-EY*BX)**2+ - (EX*BZ-EZ*BX)**2+(EZ*BY-EY*BZ)**2)/(E*B))) ELSE EBANG=ACOS(MIN(1.0,ABS((EX*BX+EY*BY+EZ*BZ)/(E*B)))) ENDIF * Interpolate. IF(E/PGAS.LE.EGAS(IATHR))THEN CALL BOXIN3(AGAS2,EGAS,BANG,BTAB,MXLIST,MXBANG,MXBTAB, - NGAS,NBANG,NBTAB,E/PGAS,EBANG,B,AUXTWN,1,IFAIL) ELSE CALL BOXIN3(AGAS2,EGAS,BANG,BTAB,MXLIST,MXBANG,MXBTAB, - NGAS,NBANG,NBTAB,E/PGAS,EBANG,B,AUXTWN,IAMETH, - IFAIL) ENDIF GASTWN=AUXTWN * Verify error. IF(IFAIL.NE.0)GASTWN=0 *** Treat the case that the table is 1-dimensional. ELSE * Extrapolation towards small E/p. IF(E/PGAS.LT.EGAS(1))THEN GASTWN=AGAS(1) IF(JAEXTR.EQ.1)GASTWN=AEXTR3+AEXTR4*E/PGAS IF(JAEXTR.EQ.2)GASTWN=EXP(MIN(50.0, - AEXTR3+AEXTR4*E/PGAS)) * Extrapolation towards large E/p. ELSEIF(E/PGAS.GT.EGAS(NGAS))THEN GASTWN=AGAS(NGAS) IF(IAEXTR.EQ.1)GASTWN=AEXTR1+AEXTR2*E/PGAS IF(IAEXTR.EQ.2)GASTWN=EXP(MIN(50.0, - AEXTR1+AEXTR2*E/PGAS)) * Interpolation below threshold. ELSEIF(E/PGAS.LE.EGAS(IATHR))THEN GASTWN=DIVDIF(AGAS,EGAS,NGAS,E/PGAS,1) * Only one point. ELSEIF(NGAS.LE.1)THEN GASTWN=AGAS(1) * Intermediate points, spline interpolation. ELSEIF(IAMETH.EQ.0)THEN CALL INTERP(EGAS,AGAS,CAGAS,NGAS,E/PGAS,AUXTWN,IFAIL) GASTWN=AUXTWN * Intermediate points, Newton interpolation. ELSE GASTWN=DIVDIF(AGAS,EGAS,NGAS,E/PGAS,IAMETH) ENDIF ENDIF *** Verify value and scale by pressure. IF(GASTWN.LT.-20)THEN GASTWN=0 ELSE GASTWN=EXP(GASTWN) ENDIF GASTWN=PGAS*GASTWN END +DECK,GASATT. REAL FUNCTION GASATT(EX,EY,EZ,BX,BY,BZ) *----------------------------------------------------------------------- * GASATT - Function calculating the attachment coefficient for a field * E using a Newton or spline interpolation. * VARIABLES : AUX : The attachment coefficient * (Last changed on 13/ 2/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,GASDATA. +SEQ,BFIELD. REAL EX,EY,EZ,BX,BY,BZ,B,E,EBANG,DIVDIF,AUXATT INTEGER IFAIL EXTERNAL DIVDIF *** Obtain the magnitude of the electric field. E=SQRT(EX**2+EY**2+EZ**2) IF(E.LE.0.0)THEN GASATT=0.0 RETURN ENDIF *** Treat the case that the table is 2-dimensional. IF(TAB2D)THEN * B field magnitude. B=SQRT(BX**2+BY**2+BZ**2) * Obtain the angle between B field and E field. IF(E*B.EQ.0)THEN EBANG=BANG(1) ELSEIF(ABS(EX*BX+EY*BY+EZ*BZ).GT.0.2*E*B)THEN EBANG=ASIN(MIN(1.0,SQRT((EX*BY-EY*BX)**2+ - (EX*BZ-EZ*BX)**2+(EZ*BY-EY*BZ)**2)/(E*B))) ELSE EBANG=ACOS(MIN(1.0,ABS((EX*BX+EY*BY+EZ*BZ)/(E*B)))) ENDIF * Interpolate. IF(E/PGAS.LE.EGAS(IBTHR))THEN CALL BOXIN3(BGAS2,EGAS,BANG,BTAB,MXLIST,MXBANG,MXBTAB, - NGAS,NBANG,NBTAB,E/PGAS,EBANG,B,AUXATT,1,IFAIL) ELSE CALL BOXIN3(BGAS2,EGAS,BANG,BTAB,MXLIST,MXBANG,MXBTAB, - NGAS,NBANG,NBTAB,E/PGAS,EBANG,B,AUXATT,IBMETH, - IFAIL) ENDIF GASATT=AUXATT * Verify error. IF(IFAIL.NE.0)GASATT=0 *** Treat the case that the table is 1-dimensional. ELSE * Below the first table point. IF(E/PGAS.LT.EGAS(1))THEN GASATT=BGAS(1) IF(JBEXTR.EQ.1)GASATT=BEXTR3+BEXTR4*E/PGAS IF(JBEXTR.EQ.2)GASATT=EXP(MIN(50.0, - BEXTR3+BEXTR4*E/PGAS)) * Above the highest table point. ELSEIF(E/PGAS.GT.EGAS(NGAS))THEN GASATT=BGAS(NGAS) IF(IBEXTR.EQ.1)GASATT=BEXTR1+BEXTR2*E/PGAS IF(IBEXTR.EQ.2)GASATT=EXP(MIN(50.0, - BEXTR1+BEXTR2*E/PGAS)) * Interpolation below threshold. ELSEIF(E/PGAS.LE.EGAS(IBTHR))THEN GASATT=DIVDIF(BGAS,EGAS,NGAS,E/PGAS,1) * Only one point. ELSEIF(NGAS.LE.1)THEN GASATT=BGAS(1) * Intermediate points, spline interpolation. ELSEIF(IBMETH.EQ.0)THEN CALL INTERP(EGAS,BGAS,CBGAS,NGAS,E/PGAS,AUXATT,IFAIL) GASATT=AUXATT * Intermediate points, Newton interpolation. ELSE GASATT=DIVDIF(BGAS,EGAS,NGAS,E/PGAS,IBMETH) ENDIF ENDIF *** Verify value and apply pressure scaling. IF(GASATT.LT.-20)THEN GASATT=0.0 ELSE GASATT=EXP(GASATT) ENDIF GASATT=PGAS*GASATT END +DECK,A20E80. SUBROUTINE A20E80 *----------------------------------------------------------------------- * A20E80 - Loads data for the gas mixture 20% Argon 80% Ethane. * Drift velocities taken from Jean-Marie et. al. (1979), * diffusion from Ramanantsizehena (1979). * Mobilitiy and most probable energy loss are questionable. * * AUTHOR: Matthias Grosse Perdekamp (Freiburg, Germany) * (Last changed on 17/ 5/94.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,GASDATA. +SEQ,PRINTPLOT. REAL EDAT(14),VDAT(14),DDAT(14),ADAT(14) +SELF,IF=SAVE. SAVE EDAT,VDAT,DDAT,ADAT +SELF. *** Tables. DATA EDAT/0.190 ,0.312 ,0.512 ,0.794 ,1.160 ,1.603 , - 1.979 ,2.417 ,2.826 ,3.285 ,3.699 ,4.176 , - 4.737 ,5.312 / DATA VDAT/2.559 ,3.630 ,4.523 ,4.988 ,5.268 ,5.392 , - 5.408 ,5.408 ,5.392 ,5.338 ,5.283 ,5.229 , - 5.136 ,5.066 / DATA DDAT/0.0224,0.0215,0.0209,0.0206,0.0199,0.0192, - 0.0188,0.0185,0.0184,0.0183,0.0182,0.0181, - 0.0179,0.0177/ DATA ADAT/0.0 ,0.0 ,0.0 ,0.0 ,0.0 ,0.0 , - 0.0 ,0.0 ,0.0 ,0.0 ,0.0 ,0.0 , - 0.0 ,0.0 / *** Identify the routine if requested. IF(LIDENT)PRINT *,' /// ROUTINE A20E80 ///' *** Copy them to the common block. NGAS=14 DO 10 I=1,NGAS EGAS(I)=EDAT(I) VGAS(I)=VDAT(I) DGAS(I)=DDAT(I)*SQRT(760.0) AGAS(I)=ADAT(I) MGAS(I)=0.21E-05 WGAS(I)=0.0 10 CONTINUE *** Next set the other gas data. A =32.05 Z =18.0 RHO =0.0014 CMEAN =23.6 EMPROB=1741 EPAIR =25.2 GASID='Argon 20% Ethane 80%' *** Set the GASOK bits. GASOK(1)=.TRUE. GASOK(2)=.TRUE. GASOK(3)=.TRUE. GASOK(4)=.FALSE. GASOK(5)=.TRUE. GASOK(6)=.FALSE. GASOK(7)=.FALSE. GASOK(8)=.FALSE. CLSTYP='LANDAU' *** Set the extrapolation method. IVEXTR=0 IDEXTR=0 IOEXTR=0 IAEXTR=0 JVEXTR=0 JDEXTR=0 JOEXTR=0 JAEXTR=0 *** Call the timing routine TIMLOG to register the amount of CPU time. CALL TIMLOG('Loading argon 20% ethane 80%: ') END +DECK,A50E50. SUBROUTINE A50E50 *----------------------------------------------------------------------- * A50E50 - Stores the gas data for the mixture argon 50% ethane 50% * in the common /GASDAT/. The data were stolen from Manfred * Guckes (table part) and provided by Giorgio Sartori and * Michela Giavedoni (parameters part). * (Last changed on 17/ 5/94.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,GASDATA. +SEQ,PRINTPLOT. REAL EDAT(16),VDAT(16),DDAT(16) +SELF,IF=SAVE. SAVE EDAT,VDAT,DDAT +SELF. *** Store the drift velocity and diffusion in temporary storage arrays. DATA EDAT/0.039 ,0.066 ,0.132 ,0.197 ,0.263 ,0.395 ,0.526 , - 0.829 ,1.07 ,1.32 ,1.83 ,2.58 ,3.32 ,4.13 , - 4.83 ,5.47 / DATA VDAT/0.61 ,1.08 ,2.25 ,3.14 ,3.75 ,4.39 ,4.75 , - 5.17 ,5.30 ,5.30 ,5.26 ,5.06 ,4.90 ,4.77 , - 4.69 ,4.63 / DATA DDAT/0.050 ,0.040 ,0.030 ,0.026 ,0.024 ,0.021 ,0.019 , - 0.017 ,0.0155,0.0152,0.0140,0.0131,0.0127,0.0122, - 0.0120,0.0120/ *** Identify the routine if requested. IF(LIDENT)PRINT *,' /// ROUTINE A50E50 ///' *** Copy them to the common block. NGAS=16 DO 10 I=1,NGAS EGAS(I)=EDAT(I) VGAS(I)=VDAT(I) DGAS(I)=DDAT(I)*SQRT(760.0) MGAS(I)=0.18E-5 WGAS(I)=0.0 10 CONTINUE *** Next set the other gas data. A =34.9 Z =18.0 RHO =0.00131 CMEAN =31.0 EMPROB=2175.0 EPAIR =27.5 GASID='Argon 50% Ethane 50%' *** Set the GASOK bits. GASOK(1)=.TRUE. GASOK(2)=.TRUE. GASOK(3)=.TRUE. GASOK(4)=.FALSE. GASOK(5)=.TRUE. GASOK(6)=.FALSE. GASOK(7)=.FALSE. GASOK(8)=.FALSE. CLSTYP='LANDAU' *** Set the extrapolation method. IVEXTR=0 IDEXTR=0 IOEXTR=0 IAEXTR=0 IBEXTR=0 IWEXTR=0 JVEXTR=0 JDEXTR=0 J0EXTR=0 JAEXTR=0 JBEXTR=0 JWEXTR=0 IVMETH=0 IDMETH=0 IOMETH=0 IBMETH=0 IWMETH=0 *** Call the timing routine TIMLOG to register the amount of CPU time. CALL TIMLOG('Loading argon 50% ethane 50%: ') END +DECK,A80E20. SUBROUTINE A80E20 *----------------------------------------------------------------------- * A80E20 - Loads data for the gas mixture 80% Argon 20% Ethane. * Drift velocities taken from Jean-Marie et.al. (1979), * diffusion from Ramanantsizehena (1979). * Mobility and most probable energy loss are questionable. * * AUTHOR: Matthias Grosse Perdekamp (Freiburg, Germany) * (Last changed on 17/ 5/94.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,GASDATA. +SEQ,PRINTPLOT. REAL EDAT(14),VDAT(14),DDAT(14),ADAT(14) +SELF,IF=SAVE. SAVE EDAT,VDAT,DDAT,ADAT +SELF. *** Tables. DATA EDAT/0.195 ,0.336 ,0.502 ,0.658 ,0.941 ,1.316 , - 1.574 ,1.974 ,2.300 ,2.632 ,3.289 ,3.947 , - 4.605 ,5.263 / DATA VDAT/3.925 ,4.624 ,4.895 ,4.895 ,4.647 ,4.414 , - 4.290 ,4.127 ,4.018 ,3.894 ,3.793 ,3.746 , - 3.692 ,3.684 / DATA DDAT/0.0336,0.0335,0.0335,0.0335,0.0337,0.0345, - 0.0348,0.0351,0.0354,0.0359,0.0365,0.0369, - 0.0372,0.0377/ DATA ADAT/0.0 ,0.0 ,0.0 ,0.0 ,0.0 ,0.0 , - 0.0 ,0.0 ,0.0 ,0.0 ,0.0 ,0.0 , - 0.0 ,0.0 / *** Identify the routine if requested. IF(LIDENT)PRINT *,' /// ROUTINE A80E20 ///' *** Copy them to the common block. NGAS=14 DO 10 I=1,NGAS EGAS(I)=EDAT(I) VGAS(I)=VDAT(I) DGAS(I)=DDAT(I)*SQRT(760.0) MGAS(I)=0.19E-05 WGAS(I)=0.0 AGAS(I)=ADAT(I) 10 CONTINUE *** Next set the other gas data. A =37.97 Z =18.0 RHO =0.0016 CMEAN =28 EMPROB=2268 EPAIR =25.8 GASID='Argon 80% Ethane 20%' *** Set the GASOK bits. GASOK(1)=.TRUE. GASOK(2)=.TRUE. GASOK(3)=.TRUE. GASOK(4)=.FALSE. GASOK(5)=.TRUE. GASOK(6)=.FALSE. GASOK(7)=.FALSE. GASOK(8)=.FALSE. CLSTYP='LANDAU' *** Set the extrapolation method. IVEXTR=0 IDEXTR=0 IAEXTR=0 JVEXTR=0 JDEXTR=0 JAEXTR=0 *** Call the timing routine TIMLOG to register the amount of CPU time. CALL TIMLOG('Loading argon 80% ethane 20%: ') END +DECK,A73M20. SUBROUTINE A73M20 *----------------------------------------------------------------------- * A73M20P7 - Loads data for the gas mixture 73% Argon 20% Methane * 7% (CH3O)2CH2 (propanol). * Drift velocities and diffusion from F. Piuz Cern-EF 82-11 * and Fehlmann et. al. (1983) * emprob, epair, cmean with big (unkown) errors. * AUTHOR: Matthias Grosse Perdekamp (Freiburg). * (Last changed on 17/ 5/94.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,GASDATA. +SEQ,PRINTPLOT. REAL EDAT(8),VDAT(8),DDAT(8),ADAT(8) +SELF,IF=SAVE. SAVE EDAT,VDAT,DDAT,ADAT +SELF. *** Tables. DATA EDAT/0.047,0.066,0.105,0.132, - 0.158,0.211,0.263,0.329/ DATA VDAT/0.295,0.469,0.797,1.031, - 1.266,1.852,2.367,3.070/ DATA DDAT/0.042,0.032,0.025,0.026, - 0.027,0.026,0.027,0.027/ DATA ADAT/0.0 ,0.0 ,0.0 ,0.0 , - 0.0 ,0.0 ,0.0 ,0.0 / *** Identify the routine if requested. IF(LIDENT)PRINT *,' /// ROUTINE A73M20 ///' *** Copy them to the common block. NGAS=8 DO 10 I=1,NGAS EGAS(I)=EDAT(I) VGAS(I)=VDAT(I) DGAS(I)=DDAT(I)*SQRT(760.0) MGAS(I)=0.183E-05 WGAS(I)=0.0 AGAS(I)=ADAT(I) 10 CONTINUE *** Next set the other gas data. A =40.5 Z =20.8 RHO =0.0018 CMEAN =30.5 EMPROB=2430 EPAIR =25.5 GASID='Argon 73% Methane 20% Propanol 7%' *** Set the GASOK bits. GASOK(1)=.TRUE. GASOK(2)=.TRUE. GASOK(3)=.TRUE. GASOK(4)=.FALSE. GASOK(5)=.TRUE. GASOK(6)=.FALSE. GASOK(7)=.FALSE. GASOK(8)=.FALSE. CLSTYP='LANDAU' *** Set the extrapolation method. IVEXTR=1 IDEXTR=1 IAEXTR=0 JVEXTR=0 JDEXTR=0 JAEXTR=0 *** Call the timing routine TIMLOG to register the amount of CPU time. CALL TIMLOG('Loading argon 73% meth. 20% propanol 7%:') END +DECK,CO2. SUBROUTINE CO2 *----------------------------------------------------------------------- * CO2 - Fills the common /GASDAT/ with CO2 data obtained from * Karl Dederichs and Francois Piuz (drift velocity and * diffusion) and from Francois Rohrbach (multiplication). * VARIABLES : See /GASDAT/ replacing 'GAS' by 'CO2'. * (Last changed on 17/ 5/94.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,GASDATA. +SEQ,PRINTPLOT. REAL ECO2(33),VCO2(33),DCO2(33),ACO2(33) +SELF,IF=SAVE. SAVE ECO2,VCO2,DCO2,ACO2 +SELF. *** Initialise the CO2 data via DATA statements. DATA ECO2/ 0.15, 0.2 , 0.3 , 0.4 , 0.5 , 0.6 , 0.7 , - 0.8 , 0.9 , 1.0 , 1.5 , 2.0 , 3.0 , 4.0 , - 5.0 , 6.0 , 7.0 , 8.0 , 9.0 , 10.0 , 15.0 , - 20.0 , 30.0 , 32.0 , 34.0 , 36.0 , 38.0 , 40.0 , - 42.0 , 44.0 , 46.0 , 48.0 , 50.0 / DATA VCO2/ 0.075, 0.10 , 0.15 , 0.20 , 0.25 , 0.3 , 0.35 , - 0.4 , 0.45 , 0.5 , 0.76 , 1.1 , 1.7 , 3.0 , - 5.0 , 6.8 , 8.1 , 9.0 ,10.0 ,11.0 ,13.5 , - 13.5 ,12.5 ,12.6 ,12.8 ,13.1 ,13.5 ,14.0 , - 14.6 ,15.2 ,15.8 ,16.4 ,17.0 / DATA DCO2/0.021 ,0.018 ,0.015 ,0.0125,0.0115,0.0105,0.01 , - 0.0092,0.009 ,0.0088,0.0078,0.0074,0.0072,0.008 , - 0.0096,0.0115,0.013 ,0.015 ,0.0165,0.018 ,0.02 , - 0.02 ,0.02 ,0.02 ,0.02 ,0.02 ,0.02 ,0.02 , - 0.02 ,0.02 ,0.02 ,0.02 ,0.02 / DATA ACO2/0.0 ,0.0 ,0.0 ,0.0 ,0.0 ,0.0 ,0.0 , - 0.0 ,0.0 ,0.0 ,0.0 ,0.0 ,0.0 ,0.0 , - 0.0 ,0.0 ,0.0 ,0.0 ,0.0 ,0.0 ,0.0 , - 0.0 ,0.016 ,0.0232,0.031 ,0.04 ,0.051 ,0.063 , - 0.074 ,0.088 ,0.102 ,0.115 ,0.124 / *** Identify the routine, if requested. IF(LIDENT)PRINT *,' /// ROUTINE CO2 ///' *** Transfer the CO2 data to the /GASDAT/ common block. NGAS=33 DO 10 I=1,NGAS EGAS(I)=ECO2(I) VGAS(I)=VCO2(I) DGAS(I)=DCO2(I)*SQRT(760.0) AGAS(I)=ACO2(I) MGAS(I)=1.09E-6 WGAS(I)=0.0 10 CONTINUE *** Copy the other data as well. GASID ='CO2' A =44.0 Z =22.0 RHO =1.86E-3 CMEAN =31.0 EMPROB=3010.0 EPAIR =33.0 *** Set the GASOK bits. GASOK(1)=.TRUE. GASOK(2)=.TRUE. GASOK(3)=.TRUE. GASOK(4)=.TRUE. GASOK(5)=.TRUE. GASOK(6)=.FALSE. GASOK(7)=.FALSE. GASOK(8)=.FALSE. CLSTYP='LANDAU' *** Set the extrapolation method. IVEXTR=1 IDEXTR=0 IAEXTR=1 JVEXTR=0 JDEXTR=0 JAEXTR=0 IVMETH=0 IDMETH=0 IAMETH=0 *** Register the amount of CPU time used for transferring. CALL TIMLOG('Loading the description of pure CO2: ') END +DECK,C80E20. SUBROUTINE C80E20 *----------------------------------------------------------------------- * C80E20 - Stores the gas data for the mixture CO2 80% ethane 20% * in the common /GASDAT/. The data were provided by Diego * Bettoni. * (Last changed on 17/ 5/94.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,GASDATA. +SEQ,PRINTPLOT. REAL EDAT(15),VDAT(15),DDAT(15) +SELF,IF=SAVE. SAVE EDAT,VDAT,DDAT +SELF. *** Store the drift velocity and diffusion in temporary storage arrays. DATA EDAT/ 0.00526, 0.01053, 0.01316, 0.02632, 0.05263, - 0.10526, 0.13158, 0.26316, 0.52632, 1.05263, - 1.31579, 2.63158, 5.26316, 10.5263 , 13.1579 / DATA VDAT/0.3472E-02,0.6945E-02,0.8681E-02,0.1736E-01,0.3472E-01, - 0.6945E-01,0.8681E-01,0.1736E-00,0.3473E-00,0.6949E-00, - 0.8690E-00,0.1764E+01,0.4417E+01,0.8179E+01,0.8639E+01/ DATA DDAT/0.1160E-00,0.0789E-00,0.0706E-00,0.0499E-00,0.0353E-00, - 0.0250E-00,0.0223E-00,0.0158E-00,0.0113E-00,0.0084E-00, - 0.0077E-00,0.0069E-00,0.0112E-00,0.0152E-00,0.0158E-00/ *** Identify the routine if requested. IF(LIDENT)PRINT *,' /// ROUTINE C80E20 ///' *** Copy them to the common block. NGAS=15 DO 10 I=1,NGAS EGAS(I)=EDAT(I) VGAS(I)=VDAT(I) DGAS(I)=DDAT(I)*SQRT(760.0) MGAS(I)=0.12E-5 WGAS(I)=0.0 10 CONTINUE *** Next set the other gas data. A =41.2 Z =21.2 RHO =0.00168 CMEAN =30.0 EMPROB=2790.0 EPAIR =32.4 GASID='CO2 80% C2H6 20%' *** Set the GASOK bits. GASOK(1)=.TRUE. GASOK(2)=.TRUE. GASOK(3)=.TRUE. GASOK(4)=.FALSE. GASOK(5)=.TRUE. GASOK(6)=.FALSE. GASOK(7)=.FALSE. GASOK(8)=.FALSE. CLSTYP='LANDAU' *** Set the extrapolation method. IVEXTR=1 IDEXTR=1 IAEXTR=0 JVEXTR=0 JDEXTR=0 JAEXTR=0 IVMETH=0 IDMETH=0 IAMETH=0 *** Call the timing routine TIMLOG to register the amount of CPU time. CALL TIMLOG('Loading CO2 80 % ethane 20%. ') END +DECK,C90E10. SUBROUTINE C90E10 *----------------------------------------------------------------------- * C90E10 - Stores the gas data for the mixture CO2 90% ethane 10% * in the common /GASDAT/. The data were provided by Diego * Bettoni, A and Z from Reyad Sawafti. * (Last changed on 17/ 5/94.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,GASDATA. +SEQ,PRINTPLOT. REAL EDAT(17),VDAT(17),DDAT(17) +SELF,IF=SAVE. SAVE EDAT,VDAT,DDAT +SELF. *** Store the drift velocity and diffusion in temporary storage arrays. DATA EDAT/ 1.316E-03, 2.632E-03, 5.263E-03,10.526E-03,13.158E-03, - 26.316E-03,52.632E-03, 0.1053 , 0.1316 , 0.2632 , - 0.5263 , 1.0526 , 1.3158 , 2.6316 , 5.2632 , - 10.5263 ,13.1579 / DATA VDAT/0.8186E-03,0.1637E-02,0.3274E-02,0.6549E-02,0.8186E-02, - 0.1637E-01,0.3274E-01,0.6549E-01,0.8186E-01,0.1637 , - 0.3274 ,0.6547 ,0.8184 ,0.1657E01 ,0.4383E01 , - 0.9121E01 ,0.9635E01 / DATA DDAT/0.2231 ,0.1578 ,0.1116 ,0.0789 ,0.0706 , - 0.0499 ,0.0353 ,0.0250 ,0.0223 ,0.0158 , - 0.0113 ,0.0083 ,0.0076 ,0.0066 ,0.0108 , - 0.0153 ,0.0159 / *** Identify the routine if requested. IF(LIDENT)PRINT *,' /// ROUTINE C90E10 ///' *** Copy them to the common block. NGAS=17 DO 10 I=1,NGAS EGAS(I)=EDAT(I) VGAS(I)=VDAT(I) DGAS(I)=DDAT(I)*SQRT(760.0) MGAS(I)=0.12E-5 WGAS(I)=0.0 10 CONTINUE *** Next set the other gas data. A =45.4 Z =23.2 RHO =0.00177 CMEAN =31.0 EMPROB=2900.0 EPAIR =32.6 GASID='CO2 90% C2H6 10%' *** Set the GASOK bits. GASOK(1)=.TRUE. GASOK(2)=.TRUE. GASOK(3)=.TRUE. GASOK(4)=.FALSE. GASOK(5)=.TRUE. GASOK(6)=.FALSE. GASOK(7)=.FALSE. GASOK(8)=.FALSE. CLSTYP='LANDAU' *** Set the extrapolation method. IVEXTR=1 IDEXTR=1 IAEXTR=0 JVEXTR=0 JDEXTR=0 JAEXTR=0 IVMETH=0 IDMETH=0 IAMETH=0 *** Call the timing routine TIMLOG to register the amount of CPU time. CALL TIMLOG('Loading CO2 90 % ethane 10%. ') END +DECK,C90I10. SUBROUTINE C90I10 *----------------------------------------------------------------------- * C90I10 - Stores the gas data for the mixture CO2 90%, isobutane 10% * in the common /GASDAT/. The data were stolen from Manfred * Guckes. Parameters from Helmut Boettcher. * (Last changed on 17/ 5/94.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,GASDATA. +SEQ,PRINTPLOT. REAL EDAT(17),VDAT(17),DDAT(17) +SELF,IF=SAVE. SAVE EDAT,VDAT,DDAT +SELF. *** Store the drift velocity and diffusion in temporary storage arrays. DATA EDAT/0.026 ,0.039 ,0.065 ,0.13 ,0.26 ,0.53 ,0.92 , - 1.32 ,2.10 ,2.63 ,3.95 ,6.58 ,13.2 ,15.0 , - 17.1 ,21.0 ,26.3 / DATA VDAT/0.015 ,0.023 ,0.038 ,0.076 ,0.153 ,0.30 ,0.54 , - 0.76 ,1.22 ,1.6 ,2.8 ,6.6 ,10.0 ,10.2 , - 10.3 ,10.4 ,10.5 / DATA DDAT/0.0514,0.0420,0.0325,0.0230,0.0163,0.0115,0.0088, - 0.0077,0.0069,0.0072,0.0107,0.0130,0.0087,0.0086, - 0.0085,0.0086,0.0093/ *** Identify the routine if requested. IF(LIDENT)PRINT *,' /// ROUTINE C90I10 ///' *** Copy them to the common block. NGAS=17 DO 10 I=1,NGAS EGAS(I)=EDAT(I) VGAS(I)=VDAT(I) DGAS(I)=DDAT(I)*SQRT(760.0) MGAS(I)=0.101E-5 WGAS(I)=0.0 10 CONTINUE *** Next set the other gas data. A =45.4 Z =23.2 RHO =0.00192 CMEAN =32.5 EMPROB=3159.0 EPAIR =32.0 GASID='CO2 90% Isobutane 10%' *** Set the GASOK bits. GASOK(1)=.TRUE. GASOK(2)=.TRUE. GASOK(3)=.TRUE. GASOK(4)=.FALSE. GASOK(5)=.FALSE. GASOK(6)=.FALSE. GASOK(7)=.FALSE. GASOK(8)=.FALSE. CLSTYP='NOT SET' *** Call the timing routine TIMLOG to register the amount of CPU time. CALL TIMLOG('Loading CO2 90% isobutane 10%. ') END +DECK,ETHANE. SUBROUTINE ETHANE *----------------------------------------------------------------------- * ETHANE - A routine filling the common /GASDAT/ with ethane data * obtained from Ingo Herbst. * VARIABLES : See the /GASDAT/ common block and the gas routines; * the letters 'gas' are to be changed into 'eta'. * (Last changed on 17/ 5/94.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,GASDATA. +SEQ,PRINTPLOT. REAL EETA(34),VETA(34),DETA(34) +SELF,IF=SAVE. SAVE EETA,VETA,DETA,AETA,ZETA,RHOETA,CMETA,EMETA,EPETA,GMETA +SELF. *** Initialise the ethane data via DATA statements. DATA EETA/0.20,0.33,0.43,0.58,0.83,1.08,1.32,1.58,1.84,2.09, - 2.34,2.58,2.83,3.07,3.32,3.55,3.80,4.04,4.29,4.53,4.83,5.07, - 5.32,10.0,20.0,30.0,40.0,50.0,60.0,70.0,80.0,90.0,100.,130./ DATA VETA/2.42,3.46,4.08,4.46,4.85,5.08,5.23,5.31,5.39,5.42, - 5.46,5.48,5.50,5.50,5.48,5.46,5.44,5.40,5.38,5.36,5.34,5.32, - 5.30,5.00,6.00,7.10,8.40,10.0,12.0,14.5,17.0,20.0,23.0,32.0/ DATA DETA/.0218,.0214,.0212,.0207,.0201,.0195,.0188,.0182, - .0176,.0171,.0166,.0160,.0155,.0150,.0145,.0141,.0137,.0132, - .0128,.0124,.0120,.0116,.0112,.0100,.0117,.0150,.0200,.0200, - .0200,.0200,.0200,.0200,.0200,.0200/ DATA AETA,ZETA,RHOETA ,CMETA,EMETA,EPETA,GMETA / - 30.1,18.0,1.30E-3, 30.0,1600., 24.6,1.10E-6/ *** Identify the routine if requested. IF(LIDENT)PRINT *,' /// ROUTINE ETHANE ///' *** Transfer the ethane data to the /GASDAT/ common block. NGAS=34 DO 10 I=1,34 EGAS(I)=EETA(I) VGAS(I)=VETA(I) DGAS(I)=DETA(I)*SQRT(760.0) MGAS(I)=GMETA WGAS(I)=0.0 10 CONTINUE GASID ='Ethane (C2H6)' A =AETA Z =ZETA RHO =RHOETA CMEAN =CMETA EMPROB=EMETA EPAIR =EPETA *** Set the GASOK bits. GASOK(1)=.TRUE. GASOK(2)=.TRUE. GASOK(3)=.TRUE. GASOK(4)=.FALSE. GASOK(5)=.TRUE. GASOK(6)=.FALSE. GASOK(7)=.FALSE. GASOK(8)=.FALSE. CLSTYP='LANDAU' *** Register the amount of CPU time with TIMLOG. CALL TIMLOG('Loading the description of pure ethane: ') END +DECK,ISOBUT. SUBROUTINE ISOBUT *----------------------------------------------------------------------- * ISOBUT - A routine filling the common /GASDAT/ with isobutane data * obtained from Emile Schmoetter. Parameters obtained from * Helmut Boettcher. Mobility corrected (Guido Michelon). * VARIABLES : See /GASDAT/ replacing 'GAS' by 'ISO'. * (Last changed on 15/ 2/99.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,GASDATA. +SEQ,PRINTPLOT. REAL EISO(7),VISO(7),DISO(7),AISO,ZISO,RHOISO,CMISO,EMISO,EPISO, - GMISO INTEGER I +SELF,IF=SAVE. SAVE EISO,VISO,DISO,AISO,ZISO,RHOISO,CMISO,EMISO,EPISO,GMISO +SELF. *** Initialise the isobutane data via DATA statements. DATA EISO/0.263,0.526,0.789,1.053,1.316,2.132,10.00/ DATA VISO/0.612,1.408,2.082,2.694,3.306,5.000,5.300/ DATA DISO/0.427,0.353,0.342,0.334,0.327,0.336,0.400/ DATA AISO,ZISO,RHOISO ,CMISO,EMISO,EPISO,GMISO / - 58.0,34.0,2.42E-3, 46.0,4500., 23.0,0.61E-6/ *** Identify the routine. IF(LIDENT)PRINT *,' /// ROUTINE ISOBUT ///' *** Transfer the isobutane data to the /GASDAT/ common block. NGAS=7 DO 10 I=1,7 EGAS(I)=EISO(I) VGAS(I)=VISO(I) DGAS(I)=DISO(I)*SQRT(760.0) MGAS(I)=GMISO WGAS(I)=0.0 10 CONTINUE GASID ='Isobutane (C4H10)' A =AISO Z =ZISO RHO =RHOISO CMEAN =CMISO EMPROB=EMISO EPAIR =EPISO *** Set the GASOK bits. GASOK(1)=.TRUE. GASOK(2)=.TRUE. GASOK(3)=.TRUE. GASOK(4)=.FALSE. GASOK(5)=.TRUE. GASOK(6)=.FALSE. GASOK(7)=.FALSE. GASOK(8)=.FALSE. CLSTYP='LANDAU' *** Register the amount of CPU time used for transferring the data. CALL TIMLOG('Loading the description of isobutane: ') END +DECK,METHAN. SUBROUTINE METHAN *----------------------------------------------------------------------- * METHAN - A routine filling the common /GASDAT/ with methane data * obtained from Ingo Herbst, for the drift velocity and the * diffusion and from "Basic data of plasma physics, 1966", * Sanborn C. Brown. * VARIABLES : See the /GASDAT/ common block, replacing 'GAS' by 'MET'. * (Last changed on 17/ 5/94.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,GASDATA. +SEQ,PRINTPLOT. REAL EMET(22),VMET(22),DMET(22),AMET(22) +SELF,IF=SAVE. SAVE EMET,VMET,DMET,AMET +SELF. *** Initialise the methane data via DATA statements. DATA EMET/ 0.1 , 0.25, 0.5 , 0.75, 1.0 , 1.25, 1.5 , - 1.75, 2.0 , 3.0 , 4.0 , 7.0 , 10.0 , 20.0 , - 30.0 , 40.0 , 50.0 , 60.0 , 70.0 , 80.0 , 90.0 , - 100.0 / DATA VMET/ 1.2 , 3.5 , 7.0 , 9.5 , 10.4 , 10.5 , 10.4 , - 9.8 , 9.2 , 7.7 , 7.0 , 6.3 , 6.0 , 5.8 , - 6.8 , 8.0 , 10.0 , 13.0 , 16.0 , 19.0 , 22.0 , - 25.0 / DATA DMET/ 0.033, 0.029, 0.025, 0.024, 0.023, 0.023, 0.024, - 0.025, 0.026, 0.028, 0.029,0.0298,0.0299, 0.03 , - 0.03 , 0.03 , 0.03 , 0.03 , 0.03 , 0.03 , 0.03 , - 0.03 / DATA AMET/ 0.0 , 0.0 , 0.0 , 0.0 , 0.0 , 0.0 , 0.0 , - 0.0 , 0.0 , 0.0 , 0.0 , 0.0 , 0.0 , 0.0 , - 0.0 , 0.0 , 0.0 , 0.2 , 0.4 , 0.6 , 0.8 , - 1.0 / *** Identify the routine, if requested. IF(LIDENT)PRINT *,' /// ROUTINE METHAN ///' *** Transfer the methane data to the /GASDAT/ common block. NGAS=22 DO 10 I=1,NGAS EGAS(I)=EMET(I) VGAS(I)=VMET(I) DGAS(I)=DMET(I)*SQRT(760.0) AGAS(I)=AMET(I) MGAS(I)=2.26E-6 WGAS(I)=0.0 10 CONTINUE GASID ='Methane (CH4)' A =16.1 Z =10.0 RHO =7.17E-4 CMEAN =16.0 EMPROB=910.0 EPAIR =27.3 *** Set the GASOK bits. GASOK(1)=.TRUE. GASOK(2)=.TRUE. GASOK(3)=.TRUE. GASOK(4)=.TRUE. GASOK(5)=.TRUE. GASOK(6)=.FALSE. GASOK(7)=.FALSE. GASOK(8)=.FALSE. CLSTYP='LANDAU' *** Set the extrapolation method. IVEXTR=1 IDEXTR=1 IAEXTR=1 JVEXTR=0 JDEXTR=0 JAEXTR=0 IVMETH=0 IDMETH=0 IAMETH=0 *** Register the amount of CPU time with TIMLOG. CALL TIMLOG('Loading the description of pure methane:') END +PATCH,FIELD. +DECK,FLDINP. SUBROUTINE FLDINP *----------------------------------------------------------------------- * FLDINP - Routine reading and interpreting the instructions of the * field section. * Variables : NGRIDR : NGRID as read from input file * (Last changed on 14/11/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. +SEQ,PARAMETERS. +SEQ,CELLDATA. +SEQ,BFIELD. +SEQ,CONSTANTS. CHARACTER*(MXCHAR) STRING REAL XTEST,YTEST,ZTEST,EX,EY,EZ,ETOT,BX,BY,BZ,BTOT,VOLT,CPU,RNDM INTEGER ILOC,NC,IFAIL1,IFAIL2,IFAIL3,IFAIL, - NGRIDR,NGRDXR,NGRDYR,I,NTEST,NWORD,INPCMP EXTERNAL INPCMP,RNDM +SELF,IF=AST. EXTERNAL ASTCCH +SELF. *** Identify the routine. IF(LIDENT)PRINT *,' /// ROUTINE FLDINP ///' *** Print a header for this page. WRITE(*,'(''1'')') PRINT *,' ================================================' PRINT *,' ========== Start of field section ==========' PRINT *,' ================================================' PRINT *,' ' *** Start an input loop. CALL INPPRM('Field','NEW-PRINT') 10 CONTINUE CALL INPWRD(NWORD) +SELF,IF=AST. *** Set up ASTCCH as the condition handler. CALL LIB$ESTABLISH(ASTCCH) +SELF. CALL INPSTR(1,1,STRING,NC) *** Skip the line if blank. IF(NWORD.EQ.0)GOTO 10 *** Return to main program if '&' is the first character. IF(STRING(1:1).EQ.'&')THEN RETURN *** Look for the AREA instruction. ELSEIF(INPCMP(1,'A#REA').NE.0)THEN CALL CELVIE(PXMIN,PYMIN,PZMIN,PXMAX,PYMAX,PZMAX) *** Look for the keyword CHECK. ELSEIF(INPCMP(1,'CH#ECK').NE.0)THEN CALL FLDCHK *** Look for the keyword GRID. ELSEIF(INPCMP(1,'G#RID').NE.0)THEN IF(NWORD.EQ.1)THEN WRITE(LUNOUT,'('' Current number of grid points is '', - I3,'' by '',I3,''.'')') NGRIDX,NGRIDY ELSEIF(NWORD.EQ.2)THEN CALL INPCHK(2,1,IFAIL1) CALL INPRDI(2,NGRIDR,25) IF(NGRIDR.LE.1.OR.NGRIDR.GT.MXGRID) - CALL INPMSG(2,'GRID out of range 2 -> MXGRID.') IF(IFAIL1.NE.0.OR.NGRIDR.LE.1.OR.NGRIDR.GT.MXGRID)THEN PRINT *,' !!!!!! FLDINP WARNING : GRID statement', - ' ignored because of syntax or value errors.' ELSE NGRIDX=NGRIDR NGRIDY=NGRIDR ENDIF ELSEIF(NWORD.EQ.3)THEN CALL INPCHK(2,1,IFAIL1) CALL INPCHK(3,1,IFAIL2) CALL INPRDI(2,NGRDXR,25) CALL INPRDI(3,NGRDYR,25) IF(NGRDXR.LE.1.OR.NGRDXR.GT.MXGRID) - CALL INPMSG(2,'out of the range 2 -> MXGRID. ') IF(NGRDYR.LE.1.OR.NGRDYR.GT.MXGRID) - CALL INPMSG(2,'out of the range 2 -> MXGRID. ') IF(IFAIL1.NE.0.OR.NGRDXR.LE.1.OR.NGRDXR.GT.MXGRID.OR. - NGRDYR.LE.1.OR.NGRDYR.GT.MXGRID)THEN PRINT *,' !!!!!! FLDINP WARNING : GRID statement', - ' ignored because of syntax or value errors.' ELSE NGRIDX=NGRDXR NGRIDY=NGRDYR ENDIF ELSE PRINT *,' !!!!!! FLDINP WARNING : GRID requires 1'// - ' or 2 arguments ; the instruction is ignored.' ENDIF *** Dipole moments. ELSEIF(INPCMP(1,'MULT#IPOLE-#MOMENTS').NE.0)THEN CALL EFMWIR *** Look for the keyword OPTION, ELSEIF(INPCMP(1,'OPT#IONS').NE.0)THEN IF(NWORD.LE.1)WRITE(LUNOUT,'(/ - '' LOCAL OPTIONS CURRENTLY IN EFFECT: ''// - '' Check for multiple field map indices: '', - L1/ - '' Contour all media (T) or drift medium (F): '', - L1/ - '' Plot wires by markers (WIRE-MARKERS): '', - L1)') LMAPCH,LCNTAM,LWRMRK * Check for the various options. DO 11 I=2,NWORD * Detect multiple map indices. IF(INPCMP(I,'CH#ECK-MAP-#INDICES')+ - INPCMP(I,'CH#ECK-MAP-#INDEXING').NE.0)THEN LMAPCH=.TRUE. ELSEIF(INPCMP(I,'NOCH#ECK-MAP-#INDICES')+ - INPCMP(I,'NOCH#ECK-MAP-#INDEXING').NE.0)THEN LMAPCH=.FALSE. * Contours in other than drift media. ELSEIF(INPCMP(I,'CONT#OUR-ALL-#MEDIA').NE.0)THEN LCNTAM=.TRUE. ELSEIF(INPCMP(I,'CONT#OUR-DR#IFT-#MEDIUM')+ - INPCMP(I,'CONT#OUR-DR#IFT-#MEDIA').NE.0)THEN LCNTAM=.FALSE. * Wires drawn as markers. ELSEIF(INPCMP(I,'NOW#IRE-M#ARKERS').NE.0)THEN LWRMRK=.FALSE. ELSEIF(INPCMP(I,'W#IRE-M#ARKERS').NE.0)THEN LWRMRK=.TRUE. ELSE CALL INPMSG(I,'The option is not known. ') ENDIF 11 CONTINUE *** Make plots if PLOT is a keyword. ELSEIF(INPCMP(1,'PL#OT-#FIELD').NE.0)THEN CALL FLDPLT *** Look for the keyword PRINT. ELSEIF(INPCMP(1,'PR#INT-#FIELD').NE.0)THEN CALL FLDPRT *** Test field calculation. ELSEIF(INPCMP(1,'S#AMPLE').NE.0)THEN CALL INPCHK(2,2,IFAIL1) CALL INPCHK(3,2,IFAIL2) CALL INPCHK(4,2,IFAIL3) CALL INPRDR(2,XTEST,0.0) CALL INPRDR(3,YTEST,0.0) CALL INPRDR(4,ZTEST,0.0) PRINT *,' ++++++ FLDINP DEBUG : Sampling EFIELD + BFIELD' IF(.NOT.POLAR)PRINT 3020,XTEST,YTEST,ZTEST IF(POLAR)THEN PRINT 3025,XTEST,YTEST,ZTEST CALL CFMPTR(XTEST,YTEST,XTEST,YTEST,1,IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! FLDINP WARNING : Illegal polar', - ' coordinates; command not executed.' CALL INPERR GOTO 10 ENDIF PRINT *,' Internal coordinates:' PRINT 3020,XTEST,YTEST,ZTEST ENDIF CALL EFIELD(XTEST,YTEST,ZTEST,EX,EY,EZ,ETOT,VOLT,1,ILOC) PRINT *,' Location code for this point : ',ILOC IF(POLAR)THEN EX=EX/EXP(XTEST) EY=EY/EXP(XTEST) ETOT=ETOT/EXP(XTEST) ENDIF IF(.NOT.POLAR)PRINT 3030,EX,EY,EZ,ETOT,VOLT IF(POLAR)PRINT 3035,EX,EY,EZ,ETOT,VOLT IF(MAGOK)THEN CALL BFIELD(XTEST,YTEST,ZTEST,BX,BY,BZ,BTOT) PRINT 3040,BX,BY,BZ,BTOT ENDIF 3020 FORMAT(' At (x,y,z) = (',F10.3,2(',',F10.3),')') 3025 FORMAT(' At (r,phi,z) = (',F10.3,2(',',F10.3),')') 3030 FORMAT(' Ex=',F15.4,' Ey=',F15.4,' Ez=',F15.4, - ' Etot=',F15.4,' V=',F15.4) 3035 FORMAT(' Er=',F15.4,' Ephi=',F15.4,' Ez=',F15.4, - ' Etot=',F15.4,' V=',F15.4) 3040 FORMAT(' Bx=',F15.4,' By=',F15.4,' Bz=',F15.4, - ' Btot=',F15.4) PRINT *,' ++++++ FLDINP DEBUG : End of SAMPLE.' *** Search for the SELECT instruction. ELSEIF(INPCMP(1,'SEL#ECT').NE.0)THEN CALL CELSEL *** Perform a timing if TIME is a keyword. ELSEIF(INPCMP(1,'TIM#E').NE.0)THEN CALL INPCHK(2,1,IFAIL1) CALL INPRDI(2,NTEST,1000) IF(NTEST.LE.0)NTEST=1000 CALL TIMED(CPU) DO 3050 I=1,NTEST XTEST=PXMIN+RNDM(I) *(PXMAX-PXMIN) YTEST=PYMIN+RNDM(I+1)*(PYMAX-PYMIN) CALL EFIELD(XTEST,YTEST,0.0,EX,EY,EZ,ETOT,VOLT,1,ILOC) 3050 CONTINUE CALL TIMED(CPU) CALL TIMLOG('< TIME: field evaluation > ') PRINT *,' ++++++ FLDINP DEBUG : CPU time required for', - NTEST,' field evaluations is ',CPU,' seconds.' *** Look for the instruction TRACK. ELSEIF(INPCMP(1,'TR#ACK').NE.0)THEN CALL TRAREA +SELF,IF=ZERO. *** Look for the ZERO instruction ELSEIF(INPCMP(1,'ZERO').NE.0)THEN PRINT *,' !!!!! FLDINP WARNING : This instruction is', - ' currently being debugged.' CALL ZROTST +SELF. *** It is not possible to get here if the keyword is valid. ELSE CALL INPSTR(1,1,STRING,NC) PRINT *,' !!!!!! FLDINP WARNING : ',STRING(1:NC),' is', - ' not a valid instruction ; ignored' ENDIF CALL INPERR GOTO 10 END +DECK,FLDPLT. SUBROUTINE FLDPLT *----------------------------------------------------------------------- * FLDPLT - Subroutine plotting the electric field, the magnetic field * and the potential in a variety of ways: histograms, contour * plots, vector plots and surface plots. * Variables : XPL,YPL : Used for plotting lines * FUNCT. : Stores the function text the plots * VAR : Array of input values for ALGEXE * GRID : Array of 'heights' for surface plots * COORD : Contains the ordinate of the graph data * VALUE : Contains the function values of the graph * HIST : Stores the histogram * CMIN,CMAX : Range of contour heights * HMIN,HMAX : Range in the histogram * NCHA : Number of bins in the histogram. * FLAG : Logicals used for parsing the command * LHIST ... : Determines whether the plot will be made * PHI,THETA : Viewing angle for 3-dimensional plots. * (Last changed on 6/11/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CONSTANTS. +SEQ,CELLDATA. +SEQ,PARAMETERS. +SEQ,GRAPHICS. +SEQ,PRINTPLOT. +SEQ,BFIELD. REAL COORD(MXLIST),VALUE(MXLIST),RES(5),VAR(MXVAR), - HMIN,HMAX,HMINR,HMAXR,CMIN,CMAX,CMINR,CMAXR,PHI,THETA, - XPOS,YPOS,ZPOS,FACNRM,RT0,RT1,PT0,PT1,XXPOS,YYPOS, - VXMIN,VYMIN,VXMAX,VYMAX,GMINR,GRSMIN,GMAXR,GRSMAX INTEGER MODVAR(MXVAR),MODRES(5),NCONT,NCONTR,NCONTP,I,J,II,INEXT, - NWORD,NC1,NC2,NC3,NC4,NC5,NCAUX,NCTOT,IFAIL,IFAIL1,IFAIL2, - NCHA,NCHAR,IOPT,NRES,NREXP,IENTRY,ICOORD,ILOC,IHIST, - IVECT1,IVECT2,IVECT3,ISURF,INPTYP,INPCMP,IHISRF,IENCON, - NCAUX1,NCAUX2,NCAUX3,NCAUX4,NGRPNT,NPNTR,NCFTRA,IENTRA CHARACTER*(MXCHAR) STRING,FUNCT1,FUNCT2,FUNCT3,FUNCT4,FUNCT5, - FUNTRA CHARACTER*20 AUX1,AUX2,AUX3,AUX4 CHARACTER*10 VARLIS(MXVAR) LOGICAL USE(MXVAR),FLAG(MXWORD+5),EVALE,EVALB,LGRPRT, - LHIST,LVECT,LGRAPH,LCONT,LSURF,CAUTO,HAUTO,CLAB EXTERNAL INPCMP,INPTYP,FCONT COMMON /CNTDAT/ IOPT,IENCON,EVALE,EVALB +SELF,IF=NAG. INTEGER ICHK,JCHK,IFLAT,IERR REAL CHEXP DOUBLE PRECISION WS,CHTS,DUM COMMON /MATRIX/ WS(MXWIRE,MXWIRE),CHTS(MXWIRE),DUM(3*MXWIRE+3) +SELF,IF=HIGZ. INTEGER ICHK,JCHK,IFLAT REAL WS,PAR,DUM,SMIN,SMAX COMMON /MATRIX/ WS(MXWIRE,MXWIRE),PAR(37), - DUM(MXWIRE**2+8*MXWIRE-31) +SELF,IF=SAVE. SAVE VARLIS,HMIN,HMAX,NCHA,PHI,THETA,NCONT +SELF. DATA (VARLIS(I),I=5,13)/'E ','V ','BX ', - 'BY ','BZ ','B ', - 'Z ','EZ ','T '/ DATA HMIN,HMAX /0.0,10000.0/ DATA NCHA/100/ DATA NCONT/21/ DATA NGRPNT/MXLIST/,LGRPRT/.FALSE./ DATA PHI,THETA/30.0,60.0/ *** Define an output format. 1010 FORMAT(26X,A10,L2,3X,A20,2X,I2,2(2X,E10.3),2(2X,I6),2(2X,E10.3)) *** Identify the routine. IF(LIDENT)PRINT *,' /// ROUTINE FLDPLT ///' *** Set default area. CALL GRASET(PXMIN,PYMIN,PZMIN,PXMAX,PYMAX,PZMAX) *** Preset the options, function strings etc, FUNCT1=' ' FUNCT2=' ' FUNCT3=' ' FUNCT4=' ' FUNCT5=' ' LGRAPH=.FALSE. LSURF=.FALSE. LVECT=.FALSE. LHIST=.FALSE. LCONT=.FALSE. FUNTRA='?' NCFTRA=1 CMIN=VMIN CMAX=VMAX CAUTO=.TRUE. CLAB=.TRUE. HAUTO=.TRUE. GRSMIN=1 GRSMAX=-1 *** Make sure the variables have appropriate names IF(POLAR)THEN VARLIS(1)='R ' VARLIS(2)='PHI ' VARLIS(3)='ER ' VARLIS(4)='EPHI ' ELSE VARLIS(1)='X ' VARLIS(2)='Y ' VARLIS(3)='EX ' VARLIS(4)='EY ' ENDIF *** Examine the input, first step is finding out where the keywords are. CALL INPNUM(NWORD) DO 10 I=1,MXWORD+5 IF(I.EQ.1.OR.I.GT.NWORD)THEN FLAG(I)=.TRUE. ELSEIF(INPCMP(I,'A#NGLES')+INPCMP(I,'AUTO#MATIC')+ - INPCMP(I,'BI#NS')+INPCMP(I,'SC#ALE')+ - INPCMP(I,'PR#INT')+INPCMP(I,'NOPR#INT')+ - INPCMP(I,'C#ONTOUR')+INPCMP(I,'G#RAPH')+ - INPCMP(I,'H#ISTOGRAM')+INPCMP(I,'N')+ - INPCMP(I,'LAB#ELS')+INPCMP(I,'NOLAB#ELS')+ - INPCMP(I,'RA#NGE')+INPCMP(I,'S#URFACE')+ - INPCMP(I,'VE#CTOR')+INPCMP(I,'ON').NE.0)THEN FLAG(I)=.TRUE. ELSE FLAG(I)=.FALSE. ENDIF 10 CONTINUE *** Start a loop over the list, INEXT=1 DO 20 I=2,NWORD IF(I.LT.INEXT)GOTO 20 * warn if the user uses a sub-keyword out of context. IF(INPCMP(I,'RA#NGE')+INPCMP(I,'N')+INPCMP(I,'BI#NS')+ - INPCMP(I,'LAB#ELS')+INPCMP(I,'NOLAB#ELS')+ - INPCMP(I,'A#NGLES')+INPCMP(I,'AUTO#MATIC')+ - INPCMP(I,'PR#INT')+INPCMP(I,'NOPR#INT')+ - INPCMP(I,'ON')+INPCMP(I,'SC#ALE').NE.0)THEN CALL INPMSG(I,'Valid keyword out of context. ') IF(.NOT.FLAG(I+1))THEN CALL INPMSG(I+1,'See the previous message. ') INEXT=I+2 IF(.NOT.FLAG(I+2))THEN CALL INPMSG(I+2,'See the previous messages. ') INEXT=I+3 ENDIF ENDIF * warn if an unknown keywords appear, ELSEIF(.NOT.FLAG(I))THEN CALL INPMSG(I,'Item is not a known keyword. ') ** Find out whether a GRAPH is requested next, ELSEIF(INPCMP(I,'G#RAPH').NE.0)THEN IF(LGRAPH)PRINT *,' !!!!!! FLDPLT WARNING : Only one'// - ' graph per PLOT statement can be processed.' LGRAPH=.TRUE. IF(FLAG(I+1))THEN FUNCT1(1:1)='V' NC1=1 INEXT=I+1 ELSE CALL INPSTR(I+1,I+1,STRING,NC1) FUNCT1(1:NC1)=STRING(1:NC1) INEXT=I+2 ENDIF * Look for sub-keywords with GRAPH. DO 230 II=I,NWORD IF(II.LT.INEXT)GOTO 230 * Look for the subkeyword ON. IF(INPCMP(II,'ON').NE.0)THEN IF(FLAG(II+1))THEN CALL INPMSG(II,'The curve function is absent. ') ELSE CALL INPSTR(II+1,II+1,FUNTRA,NCFTRA) INEXT=II+2 ENDIF * Look for the subkeyword N. ELSEIF(INPCMP(II,'N').NE.0)THEN IF(FLAG(II+1))THEN CALL INPMSG(II,'number of points is missing. ') ELSE CALL INPCHK(II+1,1,IFAIL1) CALL INPRDI(II+1,NPNTR,NGRPNT) IF(NPNTR.LT.2.AND.IFAIL1.EQ.0)CALL INPMSG(II+1, - 'number of point less than 2. ') IF(NPNTR.GT.MXLIST.AND.IFAIL1.EQ.0)CALL INPMSG - (II+1,'number of points > MXLIST. ') IF(NPNTR.GE.2.AND.NPNTR.LE.MXLIST)NGRPNT=NPNTR INEXT=II+2 ENDIF * Look for print options. ELSEIF(INPCMP(II,'PR#INT').NE.0)THEN LGRPRT=.TRUE. INEXT=II+1 ELSEIF(INPCMP(II,'NOPR#INT').NE.0)THEN LGRPRT=.FALSE. INEXT=II+1 * Scale of the graph. ELSEIF(INPCMP(II,'SC#ALE')+INPCMP(II,'RA#NGE').NE.0)THEN IF(FLAG(II+1).OR.FLAG(II+2))THEN CALL INPMSG(II,'the arguments are missing. ') ELSE CALL INPCHK(II+1,2,IFAIL1) CALL INPRDR(II+1,GMINR,+1.0) CALL INPCHK(II+2,2,IFAIL2) CALL INPRDR(II+2,GMAXR,-1.0) IF(GMINR.EQ.GMAXR)THEN CALL INPMSG(II+1,'zero range in the') CALL INPMSG(II+2,'scale not permitted') ELSE GRSMIN=MIN(GMINR,GMAXR) GRSMAX=MAX(GMINR,GMAXR) ENDIF INEXT=II+3 ENDIF * Otherwise skip to the next keyword. ELSE GOTO 20 ENDIF 230 CONTINUE ** Find out whether a CONTOUR plot is requested next, ELSEIF(INPCMP(I,'C#ONTOUR').NE.0)THEN IF(LCONT)PRINT *,' !!!!!! FLDPLT WARNING : Only one'// - ' contour plot per PLOT statement can be processed.' LCONT=.TRUE. * Store the function string, using the default if absent. IF(FLAG(I+1))THEN FUNCT2(1:1)='V' NC2=1 INEXT=I+1 ELSE CALL INPSTR(I+1,I+1,STRING,NC2) FUNCT2(1:NC2)=STRING(1:NC2) INEXT=I+2 ENDIF * Set default values for the range, depending on the function. IF(FUNCT2(1:NC2).EQ.'V')THEN CMIN=VMIN CMAX=VMAX ELSE CMIN=0.0 CMAX=10000.0 ENDIF * Look for sub-keywords with CONTOUR. DO 210 II=I+1,NWORD IF(II.LT.INEXT)GOTO 210 * LABELing of the contours. IF(INPCMP(II,'LAB#ELS').NE.0)THEN CLAB=.TRUE. INEXT=II+1 ELSEIF(INPCMP(II,'NOLAB#ELS').NE.0)THEN CLAB=.FALSE. INEXT=II+1 * The RANGE subkeyword. ELSEIF(INPCMP(II,'RA#NGE').NE.0)THEN IF(INPCMP(II+1,'AUTO#MATIC').NE.0)THEN CMIN=0.0 CMAX=0.0 CAUTO=.TRUE. INEXT=II+2 ELSEIF((.NOT.FLAG(II+1)).AND.FLAG(II+2))THEN CALL INPCHK(II+1,2,IFAIL1) CALL INPRDR(II+1,CMINR,CMIN) CMIN=CMINR CMAX=CMINR CAUTO=.FALSE. INEXT=II+2 ELSEIF((.NOT.FLAG(II+1)).AND.(.NOT.FLAG(II+2)))THEN CALL INPCHK(II+1,2,IFAIL1) CALL INPCHK(II+2,2,IFAIL2) CALL INPRDR(II+1,CMINR,CMIN) CALL INPRDR(II+2,CMAXR,CMAX) CMIN=MIN(CMINR,CMAXR) CMAX=MAX(CMINR,CMAXR) CAUTO=.FALSE. INEXT=II+3 ELSE CALL INPMSG(II,'RANGE takes two arguments. ') IF(FLAG(II+1))THEN INEXT=II+1 ELSE CALL INPMSG(II+1, - 'Ignored, see previous message.') INEXT=II+2 ENDIF ENDIF * Sub keyword N. ELSEIF(INPCMP(II,'N').NE.0)THEN IF(FLAG(II+1))THEN CALL INPMSG(II,'N must have an argument. ') INEXT=II+1 ELSE CALL INPCHK(II+1,1,IFAIL1) CALL INPRDI(II+1,NCONTR,NCONT) IF(NCONTR.LT.1.AND.IFAIL1.EQ.0)CALL INPMSG(II+1, - 'number of contour steps is < 1') IF(NCONTR.GT.MXWIRE.AND.IFAIL1.EQ.0)CALL INPMSG - (II+1,'may not exceed MXWIRE. ') IF(NCONTR.GE.1.AND.NCONTR.LE.MXWIRE)NCONT=NCONTR INEXT=II+2 ENDIF * Otherwise skip to the next keyword. ELSE GOTO 20 ENDIF 210 CONTINUE ** A SURFACE (3 dimensional plot) has perhaps been requested, ELSEIF(INPCMP(I,'S#URFACE').NE.0)THEN IF(LSURF)PRINT *,' !!!!!! FLDPLT WARNING : Only one'// - ' surface per PLOT statement can be processed.' LSURF=.TRUE. IF(FLAG(I+1))THEN FUNCT3(1:1)='V' NC3=1 INEXT=I+1 ELSE CALL INPSTR(I+1,I+1,STRING,NC3) FUNCT3(1:NC3)=STRING(1:NC3) INEXT=I+2 ENDIF * Look for sub-keywords with SURFACE. DO 220 II=I,NWORD IF(II.LT.INEXT)GOTO 220 * Look for the subkeyword ANGLE. IF(INPCMP(II,'A#NGLES').NE.0)THEN IF(.NOT.FLAG(II+1).AND.FLAG(II+2))THEN CALL INPMSG(II,'ANGLE has 2 args: theta, phi. ') CALL INPMSG(II+1,'See the previous message. ') INEXT=II+2 ELSEIF(FLAG(II+1))THEN CALL INPMSG(II,'ANGLE has 2 args: theta, phi. ') INEXT=II+1 ELSE CALL INPCHK(II+1,2,IFAIL1) CALL INPRDR(II+1,PHI,30.0) CALL INPCHK(II+2,2,IFAIL1) CALL INPRDR(II+2,THETA,60.0) INEXT=II+3 ENDIF * Otherwise skip to the next keyword. ELSE GOTO 20 ENDIF 220 CONTINUE ** The next plot might be a VECTOR plot, ELSEIF(INPCMP(I,'VE#CTOR').NE.0)THEN IF(LVECT)PRINT *,' !!!!!! FLDPLT WARNING : Only one'// - ' vector plot per PLOT statement can be processed.' LVECT=.TRUE. IF(FLAG(I+1).OR.FLAG(I+2))THEN IF(.NOT.POLAR)THEN FUNCT4(1:8)='EX,EY,EZ' NC4=8 ELSE FUNCT4(1:10)='ER,EPHI,EZ' NC4=10 ENDIF IF(.NOT.FLAG(I+1).AND.FLAG(I+2))THEN CALL INPSTR(I+1,I+1,STRING,NCAUX) IF(INDEX(STRING(1:NCAUX),'@').NE.0)THEN FUNCT4(1:1)='@' NC4=1 ELSE CALL INPMSG(I+1, - 'Has 2 or 3 args, default used.') ENDIF INEXT=I+2 ELSE INEXT=I+1 ENDIF ELSE CALL INPSTR(I+1,I+1,STRING,NC4) FUNCT4(1:NC4+1)=STRING(1:NC4)//',' CALL INPSTR(I+2,I+2,STRING,NCAUX) FUNCT4(NC4+2:NC4+NCAUX+2)=STRING(1:NCAUX)//',' NC4=NC4+NCAUX+2 IF(.NOT.FLAG(I+3))THEN CALL INPSTR(I+3,I+3,STRING,NCAUX) FUNCT4(NC4+1:NC4+NCAUX)=STRING(1:NCAUX) NC4=NC4+NCAUX INEXT=I+4 ELSE FUNCT4(NC4+1:NC4+1)='0' NC4=NC4+1 INEXT=I+3 ENDIF ENDIF ** Finally, find out whether the next plot is a HISTOGRAM. ELSEIF(INPCMP(I,'H#ISTOGRAM').NE.0)THEN IF(LHIST)PRINT *,' !!!!!! FLDPLT WARNING : Only one'// - ' histogram per PLOT statement can be processed.' LHIST=.TRUE. IF(FLAG(I+1))THEN FUNCT5(1:1)='E' NC5=1 HMIN=0.0 HMAX=10000.0 INEXT=I+1 ELSE CALL INPSTR(I+1,I+1,STRING,NC5) FUNCT5(1:NC5)=STRING(1:NC5) INEXT=I+2 ENDIF * Look for subkeywords associated with HISTOGRAM. DO 200 II=I,NWORD IF(II.LT.INEXT)GOTO 200 * The RANGE subkeyword. IF(INPCMP(II,'RA#NGE').NE.0)THEN IF(INPCMP(II+1,'AUTO#MATIC').NE.0)THEN HMIN=0.0 HMAX=0.0 HAUTO=.TRUE. INEXT=II+2 ELSEIF(.NOT.FLAG(II+1).AND..NOT.FLAG(II+2))THEN CALL INPCHK(II+1,2,IFAIL1) CALL INPCHK(II+2,2,IFAIL2) CALL INPRDR(II+1,HMINR,HMIN) CALL INPRDR(II+2,HMAXR,HMAX) HAUTO=.FALSE. IF(HMINR.EQ.HMAXR)THEN CALL INPMSG(II+1, - 'Zero range not permitted. ') CALL INPMSG(II+2, - 'See the previous message. ') ELSE HMIN=MIN(HMINR,HMAXR) HMAX=MAX(HMINR,HMAXR) ENDIF INEXT=II+3 ELSE CALL INPMSG(II,'RANGE takes two arguments. ') IF(FLAG(II+1))THEN INEXT=II+1 ELSE CALL INPMSG(II+1, - 'Ignored, see previous message.') INEXT=II+2 ENDIF ENDIF * The BINS subkeyword. ELSEIF(INPCMP(II,'BI#NS').NE.0)THEN IF(FLAG(II+1))THEN CALL INPMSG(II,'This keyword has one argument.') INEXT=II+1 ELSE CALL INPCHK(II+1,1,IFAIL) CALL INPRDI(II+1,NCHAR,MXCHA) IF(NCHAR.LE.1.OR.NCHAR.GT.MXCHA)THEN CALL INPMSG(II+1, - 'Inacceptable number of bins. ') ELSE NCHA=NCHAR ENDIF INEXT=II+2 ENDIF * Otherwise quit this loop. ELSE GOTO 20 ENDIF 200 CONTINUE ** Warn if the user aks for an unknown plot type or makes an error, ELSE CALL INPMSG(I,'Should have been a plot type. ') ENDIF 20 CONTINUE *** Next print the list of plots if the DEBUG option is on. IF(LDEBUG)THEN PRINT *,' ++++++ FLDPLT DEBUG : List of requested plots:' PRINT *,' Type Y/N ', - 'Function (1:20) NC <--------Range-------> ', - '# cont # bins <-------Angle-------->' IF(LGRAPH)THEN PRINT '(26X,A10,L2,3X,A20,2X,I2)', - 'Graph ',LGRAPH,FUNCT1(1:20),NC1 ELSE PRINT '(26X,A10,L2)','Graph ',LGRAPH ENDIF IF(LCONT.AND..NOT.CAUTO)THEN PRINT '(26X,A7,3X,L2,3X,A20,1X,I3,2(2X,E10.3),2X,I6)', - 'Contour',LCONT,FUNCT2(1:20),NC2,CMIN,CMAX,NCONT ELSEIF(LCONT.AND.CAUTO)THEN PRINT '(26X,A7,3X,L2,3X,A20,1X,I3, - '' Automatic scaling'',2X,I6)', - 'Contour',LCONT,FUNCT2(1:20),NC2,NCONT ELSE PRINT '(26X,A10,L2)','Contour ',LCONT ENDIF IF(LSURF)THEN PRINT '(26X,A10,L2,3X,A20,1X,I3,40X,2(2X,E10.3))', - 'Surface ',LSURF,FUNCT3(1:20),NC3,PHI,THETA ELSE PRINT '(26X,A10,L2)','Surface ',LSURF ENDIF IF(LVECT)THEN PRINT '(26X,A10,L2,3X,A20,1X,I3)', - 'Vector ',LVECT ,FUNCT4(1:20),NC4 ELSE PRINT '(26X,A10,L2)','Vector ',LVECT ENDIF IF(LHIST.AND..NOT.HAUTO)THEN PRINT '(26X,A10,L2,3X,A20,1X,I3,2(2X,E10.3),10X,I6)', - 'Histogram ',LHIST ,FUNCT5(1:20),NC5, - HMIN,HMAX,NCHA ELSEIF(LHIST)THEN PRINT '(26X,A10,L2,3X,A20,1X,I3, - '' Automatic scaling'',10X,I6)', - 'Histogram ',LHIST ,FUNCT5(1:20),NC5,NCHA ELSE PRINT '(26X,A10,L2)','Histogram ',LHIST ENDIF PRINT *,' ' ENDIF *** Take care of the 'GRAPH' type plots, translate curve function. IF(LGRAPH.AND.FUNTRA(1:NCFTRA).NE.'?')THEN CALL ALGPRE(FUNTRA,NCFTRA,VARLIS(13),1,NRES,USE(13), - IENTRA,IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! FLDPLT WARNING : Graph not made'// - ' because of an error in the track function.' CALL ALGCLR(IENTRA) GOTO 101 ELSEIF(NRES.NE.3)THEN PRINT *,' !!!!!! FLDPLT WARNING : Graph not made'// - ' because the curve does not give 3 results.' CALL ALGCLR(IENTRA) GOTO 101 ELSEIF(.NOT.USE(13))THEN PRINT *,' !!!!!! FLDPLT WARNING : Graph not made'// - ' because the track does not depend on T.' CALL ALGCLR(IENTRA) GOTO 101 ENDIF * If no curve is defined, the track must be. ELSEIF(LGRAPH.AND..NOT.TRFLAG(1))THEN PRINT *,' !!!!!! FLDPLT WARNING : Neither a track nor'// - ' a curve has been defined ; graph not made.' GOTO 101 ENDIF ** Parameters look reasonable. IF(LGRAPH)THEN * Transform the function into an instruction list, IF(INDEX(FUNCT1(1:NC1),'@').NE.0)THEN NRES=1 CALL ALGEDT(VARLIS,12,IENTRY,USE,NRES) FUNCT1='Edited function' NC1=15 ELSE CALL ALGPRE(FUNCT1,NC1,VARLIS,12,NRES,USE,IENTRY,IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! FLDPLT WARNING : Graph not'// - ' produced because of syntax errors.' GOTO 100 ENDIF ENDIF * Figure out which quatities are effectively used. EVALE=.FALSE. EVALB=.FALSE. IOPT=0 IF(USE(3).OR.USE(4).OR.USE(5).OR.USE(6).OR.USE(12)) - EVALE=.TRUE. IF(USE(7).OR.USE(8).OR.USE(9).OR.USE(10))EVALB=.TRUE. IF(USE(6))IOPT=1 * Be sure only one result is returned. IF(NRES.NE.1)THEN PRINT *,' !!!!!! FLDPLT WARNING : The function'// - ' does not return precisely 1 result; no graph.' GOTO 100 ENDIF * check the use of magnetic field quantities, IF(EVALB.AND..NOT.MAGOK)THEN PRINT *,' !!!!!! FLDPLT WARNING : The function to be'// - ' plotted uses magnetic field quantities,' PRINT *,' no such field has'// - ' been defined however ; plot not made.' GOTO 100 ENDIF IF((USE(7).OR.USE(8)).AND.POLAR)THEN PRINT *,' !!!!!! FLDPLT WARNING : Bx and By should'// - ' not be used with polar cells ; plot not made.' GOTO 100 ENDIF * Select the axis with the largest range for ordinate. IF(FUNTRA(1:NCFTRA).NE.'?')THEN ICOORD=3 ELSEIF(POLAR)THEN CALL CFMCTP(XT0,YT0,RT0,PT0,1) CALL CFMCTP(XT1,YT1,RT1,PT1,1) IF((ZT1-ZT0)**2.GT.(XT1-XT0)**2+(YT1-YT0)**2)THEN ICOORD=11 ELSEIF(ABS(RT0-RT1).GT.ABS(PT0-PT1))THEN ICOORD=1 ELSE ICOORD=2 ENDIF ELSE IF((ZT1-ZT0)**2.GT.(XT1-XT0)**2+(YT1-YT0)**2)THEN ICOORD=11 ELSEIF(ABS(XT0-XT1).GT.ABS(YT0-YT1))THEN ICOORD=1 ELSE ICOORD=2 ENDIF ENDIF * Print a heading for the numbers. IF(FUNTRA(1:NCFTRA).EQ.'?')THEN IF(LGRPRT)WRITE(LUNOUT,'(/'' GRAPH OF '',A, - '' ON '',A//2X,''Coordinate'',48X,''Function'')') - FUNCT1(1:NC1),'THE TRACK' ELSE IF(LGRPRT)WRITE(LUNOUT,'(/'' GRAPH OF '',A, - '' ON '',A//2X,''Coordinate'',48X,''Function'')') - FUNCT1(1:NC1),FUNTRA(1:NCFTRA) ENDIF * fill the vectors, DO 30 I=1,NGRPNT IF(ICOORD.NE.3)THEN XPOS=XT0+REAL(I-1)*(XT1-XT0)/REAL(NGRPNT-1) YPOS=YT0+REAL(I-1)*(YT1-YT0)/REAL(NGRPNT-1) ZPOS=ZT0+REAL(I-1)*(ZT1-ZT0)/REAL(NGRPNT-1) IF(POLAR)CALL CFMCTR(XPOS,YPOS,XPOS,YPOS,1) ELSE VAR(1)=REAL(I-1)/REAL(NGRPNT-1) MODVAR(1)=2 CALL ALGEXE(IENTRA,VAR,MODVAR,1,RES,MODRES,3,IFAIL) XPOS=RES(1) YPOS=RES(2) ZPOS=RES(3) IF(POLAR)CALL CFMPTR(XPOS,YPOS,XPOS,YPOS,1,IFAIL1) IF(IFAIL1.NE.0)THEN XPOS=1.0 YPOS=0.0 ZPOS=0.0 PRINT *,' !!!!!! FLDPLT WARNING : The curve'// - ' function returns invalid coordinates.' ENDIF ENDIF VAR(1)=XPOS VAR(2)=YPOS VAR(11)=ZPOS IF(EVALE)CALL EFIELD(VAR(1),VAR(2),VAR(11), - VAR(3),VAR(4),VAR(12),VAR(5),VAR(6),IOPT,ILOC) IF(EVALB)CALL BFIELD(VAR(1),VAR(2),VAR(11), - VAR(7),VAR(8),VAR(9),VAR(10)) IF(POLAR)THEN CALL CFMRTP(VAR(1),VAR(2),VAR(1),VAR(2),1) VAR(3)=VAR(3)/VAR(1) VAR(4)=VAR(4)/VAR(1) VAR(5)=VAR(5)/VAR(1) ENDIF DO 35 II=1,12 MODVAR(II)=2 35 CONTINUE CALL ALGEXE(IENTRY,VAR,MODVAR,12,RES,MODRES,1,IFAIL) IF(ICOORD.EQ.3)THEN COORD(I)=REAL(I-1)/REAL(NGRPNT-1) ELSE COORD(I)=VAR(ICOORD) ENDIF VALUE(I)=RES(1) * Print the point if this has been requested. IF(LGRPRT)WRITE(LUNOUT,'(4(2X,E15.8))') - XPOS,YPOS,ZPOS,VALUE(I) 30 CONTINUE * Plot the graph. IF(GRSMIN.LT.GRSMAX)CALL GRGRSC(GRSMIN,GRSMAX) IF(ICOORD.EQ.3)THEN CALL GRGRPH(COORD,VALUE,NGRPNT,'Curve parameter', - FUNCT1(NC1+1:40)//FUNCT1(1:NC1), - 'GRAPH OF '//FUNCT1(1:31)) ELSEIF(POLAR.AND.ICOORD.EQ.1)THEN CALL GRGRPH(COORD,VALUE,NGRPNT,'Radius [cm]', - FUNCT1(NC1+1:40)//FUNCT1(1:NC1), - 'Graph of '//FUNCT1(1:31)) ELSEIF(POLAR.AND.ICOORD.EQ.2)THEN CALL GRGRPH(COORD,VALUE,NGRPNT,'Angle [degrees]', - FUNCT1(NC1+1:40)//FUNCT1(1:NC1), - 'Graph of '//FUNCT1(1:31)) ELSEIF(ICOORD.EQ.1)THEN CALL GRGRPH(COORD,VALUE,NGRPNT,'x-Axis [cm]', - FUNCT1(NC1+1:40)//FUNCT1(1:NC1), - 'Graph of '//FUNCT1(1:31)) ELSEIF(ICOORD.EQ.2)THEN CALL GRGRPH(COORD,VALUE,NGRPNT,'y-Axis [cm]', - FUNCT1(NC1+1:40)//FUNCT1(1:NC1), - 'Graph of '//FUNCT1(1:31)) ELSEIF(ICOORD.EQ.11)THEN CALL GRGRPH(COORD,VALUE,NGRPNT,'z-Axis [cm]', - FUNCT1(NC1+1:40)//FUNCT1(1:NC1), - 'Graph of '//FUNCT1(1:31)) ELSE PRINT *,' ###### FLDPLT ERROR : Inconsistent axis'// - ' selection ; program bug - please report.' ENDIF IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) * Log this frame and prepare for the next plot. CALL GRNEXT CALL GRALOG('Graph of '//FUNCT1(1:31)) CALL TIMLOG('Plotting the graph of '//FUNCT1(1:18)) * print the number of arithmetic errors. CALL ALGERR 100 CONTINUE * Release the entry point. CALL ALGCLR(IENTRY) IF(FUNTRA(1:NCFTRA).NE.'?')CALL ALGCLR(IENTRA) ENDIF * Continue here if the parameters were not acceptable. 101 CONTINUE *** Take care of the contours. IF(LCONT)THEN * Convert to an instruction list, IF(INDEX(FUNCT2(1:NC2),'@').NE.0)THEN NRES=1 CALL ALGEDT(VARLIS,12,IENCON,USE,NRES) FUNCT2='Edited function' NC2=15 ELSE CALL ALGPRE(FUNCT2,NC2,VARLIS,12,NRES,USE,IENCON,IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! FLDPLT WARNING : No contour'// - ' plot because of function syntax errors.' GOTO 110 ENDIF ENDIF * Be sure only one result is returned. IF(NRES.NE.1)THEN PRINT *,' !!!!!! FLDPLT WARNING : The function does'// - ' not return precisely 1 result; no contour.' GOTO 110 ENDIF * Figure out which quantities are effectively used. EVALE=.FALSE. EVALB=.FALSE. IOPT=0 IF(USE(3).OR.USE(4).OR.USE(5).OR.USE(6).OR.USE(12)) - EVALE=.TRUE. IF(USE(7).OR.USE(8).OR.USE(9).OR.USE(10))EVALB=.TRUE. IF(USE(6))IOPT=1 * Check the use of magnetic field quantities. IF(EVALB.AND..NOT.MAGOK)THEN PRINT *,' !!!!!! FLDPLT WARNING : The function to be'// - ' plotted uses magnetic field quantities,' PRINT *,' no such field has'// - ' been defined however ; plot not made.' GOTO 110 ENDIF IF((USE(7).OR.USE(8)).AND.POLAR)THEN PRINT *,' !!!!!! FLDPLT WARNING : Bx and By should'// - ' not be used with polar cells ; plot not made.' GOTO 110 ENDIF * Plot the contours. CALL GRCELL(VXMIN,VYMIN,VXMAX,VYMAX, - 'Contours of '//FUNCT2(1:NC2)) NCONTP=NCONT CALL GRCONT(FCONT,CMIN,CMAX,VXMIN,VYMIN,VXMAX,VYMAX, - NCONTP,CAUTO,POLAR,CLAB) CALL GRNEXT * Print the table of contour heights. CALL OUTFMT(CMIN,2,AUX1,NCAUX1,'LEFT') CALL OUTFMT(CMAX,2,AUX2,NCAUX2,'LEFT') CALL OUTFMT(REAL(NCONTP),2,AUX3,NCAUX3,'LEFT') CALL OUTFMT((CMAX-CMIN)/REAL(MAX(1,NCONTP)),2, - AUX4,NCAUX4,'LEFT') IF(NCONTP.GE.1)WRITE(LUNOUT,'(/'' The contours'', - '' correspond to '',A,'' = '',A,'' to '',A, - '' in '',A,'' steps.''/'' The interval between 2'', - '' contours is '',A,''.'')') - FUNCT2(1:NC2),AUX1(1:NCAUX1),AUX2(1:NCAUX2), - AUX3(1:NCAUX3),AUX4(1:NCAUX4) IF(NCONTP.EQ.0)WRITE(LUNOUT,'(/'' The contour'', - '' corresponds to '',A,'' = '',A,''.'')') - FUNCT2(1:NC2),AUX1(1:NCAUX1) * Keep track of the plots being made. CALL GRALOG('Contours of '//FUNCT2(1:NC2)//':') CALL TIMLOG('Plotting contours of '//FUNCT2(1:NC2)//':') * Print the number of arithmetic errors. CALL ALGERR 110 CONTINUE CALL ALGCLR(IENCON) ENDIF *** If one of the other plots is asked for, prepare the function string. IF(LHIST.OR.LSURF.OR.LVECT)THEN NCTOT=0 IF(LSURF)THEN ISURF=1 FUNCT1(1:NC3)=FUNCT3(1:NC3) NCTOT=NC3 ENDIF IF(LVECT)THEN IF(LSURF)THEN IVECT1=2 IVECT2=3 IVECT3=4 FUNCT1(NCTOT+1:NCTOT+NC4+1)=','//FUNCT4(1:NC4) NCTOT=NCTOT+NC4+1 ELSE IVECT1=1 IVECT2=2 IVECT3=3 FUNCT1(1:NC4)=FUNCT4(1:NC4) NCTOT=NC4 ENDIF ENDIF IF(LHIST)THEN IF(LSURF.OR.LVECT)THEN IF(LSURF.AND..NOT.LVECT)IHIST=2 IF(LVECT.AND..NOT.LSURF)IHIST=4 IF(LSURF.AND. LVECT)IHIST=5 FUNCT1(NCTOT+1:NCTOT+NC5+1)=','//FUNCT5(1:NC5) NCTOT=NCTOT+NC5+1 ELSE IHIST=1 FUNCT1(1:NC5)=FUNCT5(1:NC5) NCTOT=NC5 ENDIF ENDIF * Turn it into an instruction list, NREXP=0 IF(LHIST)NREXP=NREXP+1 IF(LSURF)NREXP=NREXP+1 IF(LVECT)NREXP=NREXP+3 IF(INDEX(FUNCT1(1:NCTOT),'@').NE.0)THEN NRES=NREXP CALL ALGEDT(VARLIS,12,IENTRY,USE,NRES) FUNCT1='Edited function' NCTOT=15 ELSE CALL ALGPRE(FUNCT1,NCTOT,VARLIS,12,NRES,USE,IENTRY, - IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! FLDPLT WARNING : Plots not'// - ' produced because of syntax errors.' GOTO 120 ENDIF ENDIF * Be sure only one result is returned. IF(NRES.NE.NREXP)THEN PRINT *,' !!!!!! FLDPLT WARNING : The function does'// - ' not return the correct number of results;'// - ' histogram, surface and vector plot skipped.' GOTO 120 ENDIF * Figure out which quantities are effectively used. EVALE=.FALSE. EVALB=.FALSE. IOPT=0 IF(USE(3).OR.USE(4).OR.USE(5).OR.USE(6).OR.USE(12)) - EVALE=.TRUE. IF(USE(7).OR.USE(8).OR.USE(9).OR.USE(10))EVALB=.TRUE. IF(USE(6))IOPT=1 * check the use of magnetic field quantities, IF(EVALB.AND..NOT.MAGOK)THEN PRINT *,' !!!!!! FLDPLT WARNING : The function to be'// - ' plotted uses magnetic field quantities,' PRINT *,' no such field has'// - ' been defined however ; plot not made.' GOTO 120 ENDIF IF((USE(7).OR.USE(8)).AND.POLAR)THEN PRINT *,' !!!!!! FLDPLT WARNING : Bx and By should'// - ' not be used with polar cells ; plot not made.' GOTO 120 ENDIF +SELF,IF=NAG,HIGZ. * Obtain the matrix for surface plotting. IF(LSURF)THEN CALL BOOK('BOOK','MATRIX','SURFACE',IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! FLDPLT WARNING : Unable to'// - ' obtain storage for the surface plot.' PRINT *,' The plot'// - ' will not be made.' LSURF=.FALSE. ENDIF ENDIF +SELF. * Open a plotting frame for a VECTOR plot, if requested. IF(LVECT)THEN CALL GRCELL(VXMIN,VYMIN,VXMAX,VYMAX, - 'Vector plot of '//FUNCT4(1:NC4)) CALL GRALOG('Vector plot of '//FUNCT4(1:NC4)//':') * Otherwise, merely request the viewing area. ELSE CALL GRVIEW(VXMIN,VYMIN,VXMAX,VYMAX) ENDIF * Allocate an histogram, if needed. IF(LHIST)THEN CALL HISADM('ALLOCATE',IHISRF,NCHA,HMIN,HMAX, - HAUTO,IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! FLDPLT WARNING : Unable to'// - ' allocate histogram storage; histogram'// - ' cancelled.' LHIST=.FALSE. ENDIF ENDIF * Fill all the arrays and matrices required for these plots. CALL GRATTS('FUNCTION-1','POLYLINE') DO 50 I=1,NGRIDX IF(.NOT.POLAR)THEN XXPOS=VXMIN+REAL(I-1)*(VXMAX-VXMIN)/REAL(NGRIDX-1) ELSE XXPOS=LOG(EXP(VXMIN)+REAL(I-1)*(EXP(VXMAX)-EXP(VXMIN))/ - REAL(NGRIDX-1)) ENDIF * set a normalisation factor, to get the arrows more or less right IF(.NOT.POLAR)THEN FACNRM=MIN(VYMAX-VYMIN,VXMAX-VXMIN)/REAL(NGRIDX) ELSE FACNRM=LOG((EXP(VXMIN)+REAL(I-1)*(EXP(VXMAX)- - EXP(VXMIN))/REAL(NGRIDX))/(EXP(VXMIN)+REAL(I)* - (EXP(VXMAX)-EXP(VXMIN))/REAL(NGRIDX))) ENDIF DO 60 J=1,NGRIDY YYPOS=VYMIN+REAL(J-1)*(VYMAX-VYMIN)/REAL(NGRIDY-1) * Coordinate transformation to the viewing plane. XPOS=FPROJ(1,1)*XXPOS+FPROJ(2,1)*YYPOS+FPROJ(3,1) YPOS=FPROJ(1,2)*XXPOS+FPROJ(2,2)*YYPOS+FPROJ(3,2) ZPOS=FPROJ(1,3)*XXPOS+FPROJ(2,3)*YYPOS+FPROJ(3,3) IF(XPOS.LT.PXMIN.OR.XPOS.GT.PXMAX.OR. - YPOS.LT.PYMIN.OR.YPOS.GT.PYMAX.OR. - ZPOS.LT.PZMIN.OR.ZPOS.GT.PZMAX)THEN +SELF,IF=NAG,HIGZ. IF(LSURF)WS(I,J)=0.0 +SELF. GOTO 60 ENDIF * Evaluate field. IF(EVALE)CALL EFIELD(XPOS,YPOS,ZPOS, - VAR(3),VAR(4),VAR(12),VAR(5),VAR(6),IOPT,ILOC) IF(EVALB)CALL BFIELD(XPOS,YPOS,ZPOS, - VAR(7),VAR(8),VAR(9),VAR(10)) IF(POLAR)THEN CALL CFMRTP(XPOS,YPOS,VAR(1),VAR(2),1) VAR(3)=VAR(3)/VAR(1) VAR(4)=VAR(4)/VAR(1) VAR(5)=VAR(5)/VAR(1) ELSE VAR(1)=XPOS VAR(2)=YPOS ENDIF VAR(11)=ZPOS DO 65 II=1,12 MODVAR(II)=2 65 CONTINUE CALL ALGEXE(IENTRY,VAR,MODVAR,12,RES,MODRES,5,IFAIL) IF(LVECT)THEN IF(RES(IVECT1)**2+RES(IVECT2)**2+RES(IVECT3)**2.GT.0) - CALL PLAARR(XPOS,YPOS,ZPOS, - 0.5*FACNRM*RES(IVECT1)/SQRT(RES(IVECT1)**2+ - RES(IVECT2)**2+RES(IVECT3)**2), - 0.5*FACNRM*RES(IVECT2)/SQRT(RES(IVECT1)**2+ - RES(IVECT2)**2+RES(IVECT3)**2), - 0.5*FACNRM*RES(IVECT3)/SQRT(RES(IVECT1)**2+ - RES(IVECT2)**2+RES(IVECT3)**2)) ENDIF +SELF,IF=NAG,HIGZ. IF(LSURF)WS(I,J)=RES(ISURF) +SELF. * fill the histogram, if requested, IF(LHIST)CALL HISENT(IHISRF,RES(IHIST),1.0) 60 CONTINUE 50 CONTINUE CALL TIMLOG('Accumulating plot data on the grid: ') IF(LVECT)CALL GRNEXT * plot the 3-dimensional picture if requested IF(LSURF)THEN +SELF,IF=NAG. * Check that the surface is not flat. IFLAT=1 DO 80 ICHK=1,NGRIDX DO 70 JCHK=1,NGRIDY IF(ABS(WS(ICHK,JCHK)-WS(1,1)).GT.1.0E-5* - (1.0+ABS(WS(ICHK,JCHK))+ABS(WS(1,1))))IFLAT=0 70 CONTINUE 80 CONTINUE IF(IFLAT.NE.0)THEN PRINT *,' !!!!!! FLDPLT WARNING : The surface is', - ' not plotted because it is entirely flat.' CALL BOOK('RELEASE','MATRIX','SURFACE',IFAIL) GOTO 90 ENDIF * Switch the screen to graphics mode. CALL GRGRAF(.TRUE.) * Store the CH eXPansion, NAG has the nasty habit of changing it. CALL GQCHXP(IERR,CHEXP) IF(IERR.NE.0)CHEXP=1.0 * Initialize NAG. CALL X04AAF(1,10) CALL J06WAF CALL J06WCF(0.1D0,0.9D0,0.1D0,0.9D0) CALL J06WBF(0.0D0,1.0D0,0.0D0,1.0D0,1) IFAIL=0 IF(POLAR)THEN CALL J06HCF(WS,MXWIRE,NGRIDX,NGRIDY,DBLE(THETA), - DBLE(PHI),'Along a radius', - 'Increasing angle',IFAIL) ELSE CALL J06HCF(WS,MXWIRE,NGRIDX,NGRIDY,DBLE(THETA), - DBLE(PHI),'u-axis','v-axis',IFAIL) ENDIF CALL GRNEXT * Reset the CH eXPension factor to the original value, CALL GSCHXP(CHEXP) CALL TIMLOG('Making a 3-dimensional plot: ') CALL GRALOG('3-D plot of '//FUNCT3(1:28)) * Release the matrix. CALL BOOK('RELEASE','MATRIX','SURFACE',IFAIL) +SELF,IF=HIGZ. * Check that the surface is not flat. IFLAT=1 SMIN=WS(1,1) SMAX=WS(1,1) DO 80 ICHK=1,NGRIDX DO 70 JCHK=1,NGRIDY IF(ABS(WS(ICHK,JCHK)-WS(1,1)).GT.1.0E-5* - (1.0+ABS(WS(ICHK,JCHK))+ABS(WS(1,1))))IFLAT=0 SMIN=MIN(SMIN,WS(1,1)) SMAX=MAX(SMAX,WS(1,1)) 70 CONTINUE 80 CONTINUE IF(IFLAT.NE.0)THEN PRINT *,' !!!!!! FLDPLT WARNING : The surface is', - ' not plotted because it is entirely flat.' CALL BOOK('RELEASE','MATRIX','SURFACE',IFAIL) GOTO 90 ENDIF * Switch the screen to graphics mode. CALL GRGRAF(.TRUE.) * Fill the PAR vector. PAR(1)=THETA PAR(2)=PHI PAR(3)=VXMIN-0.5*(VXMAX-VXMIN)/REAL(NGRIDX-1) PAR(4)=VXMAX+0.5*(VXMAX-VXMIN)/REAL(NGRIDX-1) PAR(5)=VYMIN-0.5*(VYMAX-VYMIN)/REAL(NGRIDY-1) PAR(6)=VYMAX+0.5*(VYMAX-VYMIN)/REAL(NGRIDY-1) PAR(7)=SMIN PAR(8)=SMAX PAR(9)=1000+NGRIDX PAR(10)=1000+NGRIDY PAR(11)=510 PAR(12)=510 PAR(13)=510 PAR(14)=1 PAR(15)=1 PAR(16)=1 PAR(17)=0.02 PAR(18)=0.02 PAR(19)=0.02 PAR(20)=0.03 PAR(21)=2 PAR(22)=0.03 PAR(23)=0.03 PAR(24)=0.03 PAR(25)=7 PAR(26)=8 PAR(27)=9 PAR(28)=10 PAR(29)=11 PAR(30)=12 PAR(31)=13 PAR(32)=14 PAR(33)=15 PAR(34)=16 PAR(35)=17 PAR(36)=18 PAR(37)=19 * Plot the surface. CALL ISVP(1,0.1,0.9,0.1,0.9) CALL ISWN(1,0.0,1.0,0.0,1.0) CALL ISELNT(1) CALL IGTABL(MXWIRE,MXWIRE,WS,37,PAR,'S1') * Close the plot. CALL GRNEXT * Record what happened. CALL TIMLOG('Making a 3-dimensional plot: ') CALL GRALOG('3-D plot of '//FUNCT3(1:28)) * Release the matrix. CALL BOOK('RELEASE','MATRIX','SURFACE',IFAIL) +SELF,IF=-NAG,IF=-HIGZ. * No graphics system present to plot the surface. PRINT *,' !!!!!! FLDPLT WARNING : The plotting system', - ' used for this module has no SURFACE facilities.' +SELF. 90 CONTINUE ENDIF * plot the histogram if requested, delete after use. IF(LHIST)THEN CALL HISPLT(IHISRF,FUNCT5(1:NC5), - 'Histogram of '//FUNCT5(1:NC5),.TRUE.) IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) CALL GRNEXT CALL GRALOG('Histogram of '//FUNCT5(1:NC5)//':') CALL TIMLOG('Plotting an histogram of '// - FUNCT5(1:NC5)//':') CALL HISADM('DELETE',IHISRF,0,0.0,0.0,.FALSE.,IFAIL) ENDIF * print the number of arithmetic errors. CALL ALGERR 120 CONTINUE * release the algebra storage. CALL ALGCLR(IENTRY) ENDIF END +DECK,FCONT. SUBROUTINE FCONT(X0,Y0,FVAL,ILOC) *----------------------------------------------------------------------- * FCONT - Returns the function value of to the contour routine * (Last changed on 19/10/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,PARAMETERS. +SEQ,CONTDATA. +SEQ,PRINTPLOT. REAL RES(1),VAR(MXVAR),X0,Y0,FVAL INTEGER MODRES(1),MODVAR(MXVAR),ILOC,I,IFAIL LOGICAL EVALE,EVALB INTEGER IOPT,IENCON COMMON /CNTDAT/ IOPT,IENCON,EVALE,EVALB *** Return if we're far out the boundaries. IF(X0.LT.2*CXMIN-CXMAX.OR.X0.GT.2*CXMAX-CXMIN.OR. - Y0.LT.2*CYMIN-CYMAX.OR.Y0.GT.2*CYMAX-CYMIN)THEN FVAL=0.0 ILOC=-4 RETURN ENDIF *** Ensure the location code is defined, also if EVALE is false. ILOC=0 *** Copy the positions into the algebra buffer. VAR(1)= FPROJ(1,1)*X0+FPROJ(2,1)*Y0+FPROJ(3,1) VAR(2)= FPROJ(1,2)*X0+FPROJ(2,2)*Y0+FPROJ(3,2) VAR(11)=FPROJ(1,3)*X0+FPROJ(2,3)*Y0+FPROJ(3,3) *** Check the location - could be outside volume for 3D plots. IF(VAR(1).LT.PXMIN.OR.VAR(1).GT.PXMAX.OR. - VAR(2).LT.PYMIN.OR.VAR(2).GT.PYMAX.OR. - VAR(11).LT.PZMIN.OR.VAR(11).GT.PZMAX)THEN ILOC=-4 RETURN ENDIF *** Calculate the field, IF(EVALE)CALL EFIELD(VAR(1),VAR(2),VAR(11), - VAR(3),VAR(4),VAR(12),VAR(5),VAR(6),IOPT,ILOC) IF(EVALB)CALL BFIELD(VAR(1),VAR(2),VAR(11), - VAR(7),VAR(8),VAR(9),VAR(10)) * Location code -5 (in a material) is acceptable for contours. IF(ILOC.EQ.-5.AND.LCNTAM)ILOC=0 * evaluate the function, IF(POLAR)THEN VAR(3)=VAR(3)/EXP(VAR(1)) VAR(4)=VAR(4)/EXP(VAR(1)) VAR(5)=VAR(5)/EXP(VAR(1)) ENDIF * assign modes. DO 10 I=1,12 MODVAR(I)=2 10 CONTINUE * evaluate function. CALL ALGEXE(IENCON,VAR,MODVAR,12,RES,MODRES,1,IFAIL) * and return it to the contour routine. FVAL=RES(1) END +DECK,FLDPRT. SUBROUTINE FLDPRT *----------------------------------------------------------------------- * FLDPRT - Subroutine printing any function of the electric field, the * the potential and the magnetic field on a grid of GRID **2 * points in the area (PXMIN,PYMIN) (PXMAX,PYMAX). This * routine will not work for mappings other than polar. * VARIABLES : VECTOR : vector to be printed. * FUNCT, NF : string (and length) of the function. * USE : .TRUE. if the corresponding var is used. * EVALE, EVALB : .TRUE. if E resp B is used. *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,CONSTANTS. +SEQ,CELLDATA. +SEQ,PARAMETERS. +SEQ,PRINTPLOT. +SEQ,BFIELD. CHARACTER*10 VARLIS(MXVAR) CHARACTER*(MXCHAR) FUNCT,STRING REAL VECTOR(4,10),VAR(MXVAR) INTEGER MODVAR(MXVAR),MODRES(4) DOUBLE PRECISION SUMFLD(4) LOGICAL USE(MXVAR),EVALE,EVALB +SELF,IF=SAVE. SAVE VARLIS +SELF. DATA (VARLIS(I),I=5,10)/'E ','V ','BX ', - 'BY ','BZ ','B '/ *** Identify the routine. IF(LIDENT)PRINT *,' /// ROUTINE FLDPRT ///' *** Make sure the variables have appropriate names. IF(POLAR)THEN VARLIS(1)='R ' VARLIS(2)='PHI ' VARLIS(3)='ER ' VARLIS(4)='EPHI ' ELSE VARLIS(1)='X ' VARLIS(2)='Y ' VARLIS(3)='EX ' VARLIS(4)='EY ' ENDIF *** Get the number of words in the input string CALL INPNUM(NWORD) * Warn if the function is absent. IF(NWORD.EQ.1)THEN PRINT *,' !!!!!! FLDPRT WARNING : To obtain a table, a'// - ' (list of) function(s) should be given as argument.' RETURN ENDIF * Loop over the input string DO 70 IW=1,NWORD-1,4 * Extract the function. NF=1 FUNCT=' ' DO 10 JW=1,4 IF(IW+JW.GT.NWORD)GOTO 10 CALL INPSTR(IW+JW,IW+JW,STRING,NC) FUNCT(NF:NF+NC)=STRING(1:NC)//',' NF=NF+NC+1 10 CONTINUE FUNCT(NF-1:NF-1)=' ' NF=NF-2 IF(NF.EQ.0)GOTO 70 * Convert into an instruction list. IF(INDEX(FUNCT,'@').NE.0)THEN NRES=0 CALL ALGEDT(VARLIS,10,IENTRY,USE,NRES) FUNCT='Edited function' NF=15 IF(NRES.LE.0)THEN PRINT *,' !!!!!! FLDPRT WARNING : The edited'// - ' instruction list does not return results;'// - ' no printout.' GOTO 70 ENDIF ELSE CALL ALGPRE(FUNCT,NF,VARLIS,10,NRES,USE,IENTRY,IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! FLDPRT WARNING : Table of '// - FUNCT(1:NF)//' not printed because of'// - ' syntax error(s) in one of the functions.' GOTO 70 ENDIF ENDIF * Determine which quantities are going to be used. EVALE=.FALSE. EVALB=.FALSE. IOPT=0 IF(USE(3).OR.USE(4).OR.USE(5).OR.USE(6))EVALE=.TRUE. IF(USE(7).OR.USE(8).OR.USE(9).OR.USE(10))EVALB=.TRUE. IF(USE(6))IOPT=1 * Make sure the function does not use B if MAGOK is .FALSE.. IF(EVALB.AND..NOT.MAGOK)THEN PRINT *,' !!!!!! FLDPRT WARNING : A magnetic field'// - ' quantity is used in '//FUNCT(1:NF) PRINT *,' no such field has'// - ' been defined however ; table not printed.' GOTO 70 ENDIF *** Print a header for the table. WRITE(LUNOUT,'(''1 Printed table of the field''/ - '' ==========================''//)',IOSTAT=IOS,ERR=2010) WRITE(LUNOUT,'(A)',IOSTAT=IOS,ERR=2010) - ' Function being printed: '//FUNCT(1:NF) WRITE(LUNOUT,'(A55)',IOSTAT=IOS,ERR=2010) - ' where the symbolic variables stand for the following:' IF(USE(1).AND..NOT.POLAR) - WRITE(LUNOUT,'(1X,A56)',IOSTAT=IOS,ERR=2010) - ' X = x-coordinate [cm]' IF(USE(1).AND.POLAR) - WRITE(LUNOUT,'(1X,A56)',IOSTAT=IOS,ERR=2010) - ' R = radial coordinate [cm]' IF(USE(2).AND..NOT.POLAR) - WRITE(LUNOUT,'(1X,A56)',IOSTAT=IOS,ERR=2010) - ' Y = y-coordinate [cm]' IF(USE(2).AND.POLAR) - WRITE(LUNOUT,'(1X,A56)',IOSTAT=IOS,ERR=2010) - ' PHI = angular coordinate [degree]' IF(USE(3).AND..NOT.POLAR) - WRITE(LUNOUT,'(1X,A56)',IOSTAT=IOS,ERR=2010) - ' EX = x-component of the electric field [V/cm]' IF(USE(3).AND.POLAR) - WRITE(LUNOUT,'(1X,A56)',IOSTAT=IOS,ERR=2010) - ' ER = radial component of the electric field [V/cm]' IF(USE(4).AND..NOT.POLAR) - WRITE(LUNOUT,'(1X,A56)',IOSTAT=IOS,ERR=2010) - ' EY = y-component of the electric field [V/cm]' IF(USE(4).AND.POLAR)WRITE(LUNOUT,'(1X,A56)',IOSTAT=IOS,ERR=2010) - ' EPHI = angular component of the electric field [V/cm]' IF(USE(5))WRITE(LUNOUT,'(1X,A56)',IOSTAT=IOS,ERR=2010) - ' E = magnitude of the electric field [V/cm]' IF(USE(6))WRITE(LUNOUT,'(1X,A56)',IOSTAT=IOS,ERR=2010) - ' V = electrostatic potential [V]' IF(USE(7))WRITE(LUNOUT,'(1X,A56)',IOSTAT=IOS,ERR=2010) - ' BX = x-component of the magnetic field [V sec/cm2]' IF(USE(8))WRITE(LUNOUT,'(1X,A56)',IOSTAT=IOS,ERR=2010) - ' BY = y-component of the magnetic field [V sec/cm2]' IF(USE(9))WRITE(LUNOUT,'(1X,A56)',IOSTAT=IOS,ERR=2010) - ' BZ = z-component of the magnetic field [V sec/cm2]' IF(USE(10))WRITE(LUNOUT,'(1X,A56)',IOSTAT=IOS,ERR=2010) - ' B = magnitude of the magnetic field [V sec/cm2]' WRITE(LUNOUT,'(/'' The data apply to a rectangular grid of '', - I2,'' points in the area delimited by:'')') PXMIND=PXMIN PXMAXD=PXMAX PYMIND=PYMIN PYMAXD=PYMAX IF(POLAR)CALL CFMRTP(PXMIND,PYMIND,PXMIND,PYMIND,1) IF(POLAR)CALL CFMRTP(PXMAXD,PYMAXD,PXMAXD,PYMAXD,1) IF(POLAR)THEN WRITE(LUNOUT,'('' '',F10.3,'' < r < '',F10.3/ - '' '',F10.3,'' < phi < '',F10.3)', - ERR=2010,IOSTAT=IOS) PXMIND,PXMAXD,PYMIND,PYMAXD ELSE WRITE(LUNOUT,'('' '',F10.3,'' < x < '',F10.3/ - '' '',F10.3,'' < y < '',F10.3)', - ERR=2010,IOSTAT=IOS) PXMIND,PXMAXD,PYMIND,PYMAXD ENDIF *** Set the averaging variables to 0. DO 15 ISUM=1,NRES SUMFLD(ISUM)=0 15 CONTINUE NSUM=0 *** Loop over the area, printing the field at the same time, DO 60 JJ=0,10*INT((NGRIDY-1)/10.0),10 JMAX=MIN(NGRIDY-JJ,10) DO 50 II=0,10*INT((NGRIDX-1)/10.0),10 IMAX=MIN(NGRIDX-II,10) WRITE(LUNOUT,'(''1 FIELD-PRINT'',109X,''PART '',I1,''.'',I1)', - ERR=2010,IOSTAT=IOS) 1+II/10,1+JJ/10 WRITE(LUNOUT,'('' ==========='',109X,''========''/)', - IOSTAT=IOS,ERR=2010) IF(.NOT.POLAR)THEN WRITE(LUNOUT,'('' y x:'',10(E11.4,1X:)/)', - IOSTAT=IOS,ERR=2010) - (PXMIN+(PXMAX-PXMIN)*(II+I-1)/REAL(NGRIDX-1),I=1,IMAX) ELSE WRITE(LUNOUT,'('' phi r:'',10(E11.4,1X:)/)', - IOSTAT=IOS,ERR=2010) - (EXP(PXMIN)+(EXP(PXMAX)-EXP(PXMIN))*REAL(II+I-1)/ - REAL(NGRIDX-1),I=1,IMAX) ENDIF DO 40 J=1,JMAX YPOS=PYMIN+(PYMAX-PYMIN)*REAL(JJ+J-1)/REAL(NGRIDY-1) DO 20 I=1,IMAX IF(POLAR)THEN XPOS=LOG(EXP(PXMIN)+(EXP(PXMAX)-EXP(PXMIN))* - REAL(II+I-1)/REAL(NGRIDX-1)) ELSE XPOS=PXMIN+(PXMAX-PXMIN)*REAL(II+I-1)/REAL(NGRIDX-1) ENDIF * evaluate the field, IF(EVALE)CALL EFIELD(XPOS,YPOS,0.0, - VAR(3),VAR(4),EZ,VAR(5),VAR(6), - IOPT,ILOC) IF(EVALB)CALL BFIELD(XPOS,YPOS,0.0, - VAR(7),VAR(8),VAR(9),VAR(10)) * convert to polar coordinates if the cell is polar, IF(EVALE.AND.POLAR)THEN VAR(3)=VAR(3)/EXP(XPOS) VAR(4)=VAR(4)/EXP(XPOS) VAR(5)=VAR(5)/EXP(XPOS) ENDIF IF(POLAR)THEN VAR(1)=EXP(XPOS) VAR(2)=180.0*YPOS/PI ELSE VAR(1)=XPOS VAR(2)=YPOS ENDIF * Assign modes. DO 80 K=1,10 MODVAR(K)=2 80 CONTINUE * Evaluate the field functions and store the results in VECTOR, CALL ALGEXE(IENTRY,VAR,MODVAR,10,VECTOR(1,I),MODRES,4,IFAIL) * And add the new values to the sum. DO 16 ISUM=1,NRES SUMFLD(ISUM)=SUMFLD(ISUM)+VECTOR(ISUM,I) 16 CONTINUE NSUM=NSUM+1 20 CONTINUE * Print VECTOR, WRITE(LUNOUT,'(1X,E10.3)',IOSTAT=IOS,ERR=2010) VAR(2) DO 30 K=1,NRES WRITE(LUNOUT,'(12X,10(E11.4,1X:))',IOSTAT=IOS,ERR=2010) - (VECTOR(K,I),I=1,IMAX) 30 CONTINUE 40 CONTINUE 50 CONTINUE 60 CONTINUE * Finally print the averages as well. WRITE(LUNOUT,'(''1 Number of sampling points on the grid: '',I5 - /'' Averaging over this grid yields:'')',ERR=2010, - IOSTAT=IOS) NSUM DO 65 ISUM=1,NRES WRITE(LUNOUT,'(/'' Function '',I1,'': '',E15.8)',ERR=2010, - IOSTAT=IOS) ISUM,SUMFLD(ISUM)/NSUM 65 CONTINUE *** Proceed with the next group of functions. 70 CONTINUE * Release the algebra entry point. CALL ALGCLR(IENTRY) *** Register the amount of CPU time used in the step. CALL TIMLOG('Printing a table of the field: ') RETURN *** Handle I/O errors. 2010 CONTINUE PRINT *,' ###### FLDPRT ERROR : Error writing the field'// - ' table on unit ',LUNOUT,' ; output terminated.' CALL INPIOS(IOS) END +DECK,FLDCHK. SUBROUTINE FLDCHK *----------------------------------------------------------------------- * FLDCHK - Subroutine printing the field and the potential at the * wire surface and at the plane surface. It checks also that * the Maxwell equations are satisfied. * VARIABLES : ERADS,E2RADS: Sum of fieldstrength at (twice) the radius * CHNUM : Charge calculated from the E-field * VRADS,V2RADS: Sum of potential at (twice) the radius * TABLE : Is used for extrapolating to the r=d/2 * ..HIST : Histogram's for the 'Maxwell' option * DVDX ETC : Derivatives, self explanatory * LPLCHK : Checking potentials at the plane surface * LMWCHK : Checking that the Maxwell equations are * satisfied * LSWCHK : Checking the field at the s-wire surface * LTUCHK : Check the field at the tube surface. * (Last changed on 25/ 6/97.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,CONSTANTS. +SEQ,PARAMETERS. +SEQ,BFIELD. +SEQ,PRINTPLOT. REAL DVDX(10),DVDY(10),DVDZ(10),DIVE(10),DIVB(10),PHVECT(20), - ETVECT(20), - VTVECT(20),EXVECT(20),EYVECT(20),EZVECT(20),TABLE(5,5), - XPL(MXLIST),YPL(MXLIST),EXPL1(MXLIST),EXPL2(MXLIST), - EYPL1(MXLIST),EYPL2(MXLIST),VPL1(MXLIST),VPL2(MXLIST), - EX,EY,EZ,BX,BY,BZ,EXX1,EXX2,EXY1,EXY2,EXZ1,EXZ2, - EYX1,EYX2,EYY1,EYY2,EYZ1,EYZ2,EZX1,EZX2,EZY1,EZY2, - EZZ1,EZZ2,BXX1,BXX2,BXY1,BXY2,BXZ1,BXZ2, - BYX1,BYX2,BYY1,BYY2,BYZ1,BYZ2,BZX1,BZX2,BZY1,BZY2, - BZZ1,BZZ2,DX,DY,DZ,EPSWIR,EPSMXW,EPSR,STEPA,STEPB,XPRT,YPRT, - ERADS,E2RADS,VRADS,V2RADS,CHNUM,CHERR,SURFTS,SURFTH,ANG, - EX1,EX2,EY1,EY2,EZ1,EZ2,V1,V2,ETOT,ETOT1,ETOT2,ETOT3,ETOT4, - ETOT5,ETOT6,ERSUM,EPSUM,V1SUM,PHI,BTOT,VOLT, - V2SUM,E2SUM,RLOC,PHIPRO,ER,EPHI,ERCHK,DR,VX1,VX2,VY1,VY2, - VZ1,VZ2,ESUM,XRNDM,YRNDM,ZRNDM,RRNDM,XPOS,YPOS,ZPOS, - VT,AUX,RNDM INTEGER ISIZ(1),IDIM(1),NCHA,I,II,J,JJ,NWORD,INEXT,NDATA, - ITAB,JTAB,NC, - KTAB,NRNDM,IHISEX,IHISEY,IHISEZ,IHISDE,IHISDB,NENTEX, - NENTEY,NENTEZ,NENTDE,NENTDB,IMAX,JMAX,NCHAR, - ILOC,ILOC1,ILOC2,ILOC3,ILOC4,ILOC5,ILOC6,ILOC7, - INPTYP,INPCMP,IFAIL,IFAIL1,IFAIL2,IFAIL3,IFAIL4,IFAIL5 CHARACTER*133 INFILE LOGICAL LPLCHK,LMWCHK,LSWCHK,LMTCHK,LTUCHK,LCHCHK,LKEEP, - FLAGEX(10),FLAGEY(10),FLAGEZ(10),FLAGDE(10),FLAGDB(10), - LMWPRT,LMWPLT EXTERNAL INPCMP,INPTYP,RNDM +SELF,IF=SAVE. SAVE NCHA,EPSWIR,EPSMXW,LMWPRT,LMWPLT +SELF. DATA NCHA/100/,EPSWIR/1.0E-5/,EPSMXW/1.0E-3/, - LMWPRT/.TRUE./,LMWPLT/.TRUE./ *** Define some output formats. 1010 FORMAT('1 Table of the field at the surface of wire ',I3/ - ' ============================================='// - ' Wire type : ',A1/ - ' The wire is located at : (',F9.2,',',F9.2,')'/ - ' The wire potential is : ',F10.2,' [V]'/ - ' SETUP calculated a charge of : ',F10.2// - ' Angle Surface field Field at 2*rad', - ' Surface pot. Pot. at 2*rad Surface angle'/ - ' [degree] [V/cm] [V/cm]', - ' [V] [V] [degree]'/) 1040 FORMAT('1 Table of the field at the surface of plane ',I3,/, - ' ==============================================',//, - ' ',A1,'-coordinate : ',F10.2/ - ' Potential as specified : ',F10.2,' [V]',/) 1050 FORMAT('1 Table of the field at the surface of the tube ',/, - ' ==============================================',//, - ' Radius : ',F10.2/ - ' Potential as specified : ',F10.2,' [V]',/) 1060 FORMAT('1 FIELD-CHECK',109X,'part ',I1,'.',I1/122X, - '========'//' y x:',10(F10.2,2X:)) 1100 FORMAT('1 Numerical check of the Maxwell relations for the', - ' fields used by the program'/ - ' ================================================', - '==========================='// - ' The data will be printed in blocks of 10 by 10', - ' points, in the format '// - ' dV/dx + Ex [V/cm]'/ - ' dV/dy + Ey [V/cm]'/ - ' dV/dz + Ez [V/cm]'/ - ' Divergence of the electric field [V/cm]') *** Identify the routine. IF(LIDENT)PRINT *,' /// ROUTINE FLDCHK ///' *** Find out which options have been selected. LSWCHK=.FALSE. LPLCHK=.FALSE. LMWCHK=.FALSE. LMTCHK=.FALSE. LTUCHK=.FALSE. LCHCHK=.FALSE. LKEEP=.FALSE. CALL INPNUM(NWORD) INEXT=2 DO 70 I=2,NWORD IF(I.LT.INEXT)GOTO 70 IF(INPCMP(I,'D#IELECTRICA').NE.0)THEN IF(NXMATT.GE.0.OR.NYMATT.GE.0)THEN LMTCHK=.TRUE. ELSE CALL INPMSG(I,'no dielectrica in the cell. ') ENDIF ELSEIF(INPCMP(I,'NOD#IELECTRICA').NE.0)THEN LMTCHK=.FALSE. ELSEIF(INPCMP(I,'P#LANES').NE.0)THEN IF(YNPLAN(1).OR.YNPLAN(2).OR.YNPLAN(3).OR.YNPLAN(4))THEN LPLCHK=.TRUE. ELSE CALL INPMSG(I,'the cell does not have planes.') ENDIF ELSEIF(INPCMP(I,'NOP#LANES').NE.0)THEN LPLCHK=.FALSE. ELSEIF(INPCMP(I,'T#UBE').NE.0)THEN IF(TUBE)THEN LTUCHK=.TRUE. ELSE CALL INPMSG(I,'the cell does not have a tube.') ENDIF ELSEIF(INPCMP(I,'NOT#UBE').NE.0)THEN LTUCHK=.FALSE. ELSEIF(INPCMP(I,'W#IRES').NE.0)THEN LSWCHK=.TRUE. ELSEIF(INPCMP(I,'NOW#IRES').NE.0)THEN LSWCHK=.FALSE. ELSEIF(INPCMP(I,'CH#ARGES').NE.0)THEN LCHCHK=.TRUE. ELSEIF(INPCMP(I,'NOCH#ARGES').NE.0)THEN LCHCHK=.FALSE. ELSEIF(INPCMP(I,'M#AXWELL').NE.0)THEN LMWCHK=.TRUE. ELSEIF(INPCMP(I,'NOM#AXWELL').NE.0)THEN LMWCHK=.FALSE. ELSEIF(INPCMP(I,'F#ULL')+INPCMP(I,'A#LL').NE.0)THEN LPLCHK=YNPLAX.OR.YNPLAY LSWCHK=NSW.GT.0 LMWCHK=.TRUE. LMTCHK=.TRUE. LTUCHK=TUBE LCHCHK=N3D.GT.0 * The BINS keyword. ELSEIF(INPCMP(I,'B#INS').NE.0)THEN IF(I+1.GT.NWORD.OR.INPTYP(I+1).NE.1)THEN CALL INPMSG(I,'Has one integer as argument. ') ELSE CALL INPCHK(I+1,1,IFAIL) CALL INPRDI(I+1,NCHAR,MXCHA) IF(NCHAR.LE.1.OR.NCHAR.GT.MXCHA)THEN CALL INPMSG(I+1,'Inacceptable number of bins. ') ELSE NCHA=NCHAR ENDIF ENDIF INEXT=I+2 * The differentation epsilon for the wires. ELSEIF(INPCMP(I,'EPS#ILON-W#IRES').NE.0)THEN IF(I+1.GT.NWORD.OR.INPTYP(I+1).LE.0)THEN CALL INPMSG(I,'Has one real as argument. ') ELSE CALL INPCHK(I+1,2,IFAIL) CALL INPRDR(I+1,EPSR,EPSWIR) IF(EPSR.LE.0.0)THEN CALL INPMSG(I+1,'Epsilon must be larger than 0.') ELSE EPSWIR=EPSR ENDIF ENDIF INEXT=I+2 * The differentation epsilon for Maxwell. ELSEIF(INPCMP(I,'EPS#ILON-M#AXWELL').NE.0)THEN IF(I+1.GT.NWORD.OR.INPTYP(I+1).LE.0)THEN CALL INPMSG(I,'Has one real as argument. ') ELSE CALL INPCHK(I+1,2,IFAIL) CALL INPRDR(I+1,EPSR,EPSMXW) IF(EPSR.LE.0.0)THEN CALL INPMSG(I+1,'Epsilon must be larger than 0.') ELSE EPSMXW=EPSR ENDIF ENDIF INEXT=I+2 * Print and plot results. ELSEIF(INPCMP(I,'PR#INT').NE.0)THEN LMWPRT=.TRUE. ELSEIF(INPCMP(I,'NOPR#INT').NE.0)THEN LMWPRT=.FALSE. ELSEIF(INPCMP(I,'PL#OT').NE.0)THEN LMWPLT=.TRUE. ELSEIF(INPCMP(I,'NOPL#OT').NE.0)THEN LMWPLT=.FALSE. * Keep results or not. ELSEIF(INPCMP(I,'KEEP-#RESULTS').NE.0)THEN LKEEP=.TRUE. ELSEIF(INPCMP(I,'NOKEEP-#RESULTS').NE.0)THEN LKEEP=.FALSE. * Invalid keyword. ELSE CALL INPMSG(I,'the option is not known. ') ENDIF 70 CONTINUE CALL INPERR *** Check that at least one of the options is on. IF(.NOT.(LPLCHK.OR.LSWCHK.OR.LMWCHK.OR.LMTCHK.OR. - LTUCHK.OR.LCHCHK))THEN PRINT *,' !!!!!! FLDCHK WARNING : To obtain output from'// - ' CHECK, select at least one of the' PRINT *,' options (CHARGES,'// - ' DIELECTRICA, MAXWELL, PLANES, TUBE, WIRES or FULL).' RETURN ENDIF *** Handle the 'WIRE' option. IF(LSWCHK)THEN DO 60 I=1,NWIRE * Skip non sense wires. IF(INDSW(I).EQ.0)GOTO 60 * Prepare the extrapolation stepsizes for this wire. STEPB=0.25*(1.0/(0.5+EPSWIR*MAX(ABS(X(I)),ABS(Y(I)), - D(I)/2.0)/D(I))-1.0) STEPA=1.0+5.0*STEPB IF(LDEBUG)PRINT *,' ++++++ FLDCHK DEBUG : The table'// - ' points are at D/(',STEPA,' - I * ',STEPB,')' * Extrapolation is impossible if STEPB .LE. 0 (numerically unstable). IF(STEPB.LE.0)THEN PRINT *,' !!!!!! FLDCHK WARNING : The field near the'// - ' surface of wire ',I,' can not be calculated' PRINT *,' to a reasonable'// - ' accuracy with single precision arithmetic.' GOTO 60 ENDIF * Print a suitable heading. XPRT=X(I) YPRT=Y(I) IF(POLAR)CALL CFMRTP(XPRT,YPRT,XPRT,YPRT,1) WRITE(LUNOUT,1010) I,WIRTYP(I),XPRT,YPRT,V(I),E(I) * Make a table of the field at the wire surface. ERADS =0.0 E2RADS=0.0 VRADS =0.0 V2RADS=0.0 CHNUM =0.0 SURFTS=0.0 NDATA =0 * Loop over the angle around the wire. DO 50 ANG=0.0,1.9*PI,PI/9.0 * Set up a table for the extrapolation. DO 10 ITAB=1,5 TABLE(1,ITAB)=D(I)/(STEPA-REAL(ITAB)*STEPB) XPOS=X(I)+COS(ANG)*TABLE(1,ITAB) YPOS=Y(I)+SIN(ANG)*TABLE(1,ITAB) CALL EFIELD(XPOS,YPOS,0.0,TABLE(2,ITAB),TABLE(3,ITAB),EZ, - TABLE(4,ITAB),TABLE(5,ITAB),1,ILOC) IF(ILOC.NE.0)THEN IF(ILOC.GT.0)WRITE(LUNOUT,'(1X,F10.1,'' Leaving'', - '' the wire at this angle, you enter wire '', - I3,'' very soon; no data printed.'')') - 180*ANG/PI,ILOC IF(ILOC.LT.0)WRITE(LUNOUT,'(1X,F10.1,'' Leaving'', - '' the wire at this angle, you get outside'', - '' a plane very soon; no data printed.'')') - 180*ANG/PI GOTO 50 ENDIF IF(POLAR)THEN TABLE(2,ITAB)=TABLE(2,ITAB)/EXP(XPOS) TABLE(3,ITAB)=TABLE(3,ITAB)/EXP(XPOS) TABLE(4,ITAB)=TABLE(4,ITAB)/EXP(XPOS) ENDIF IF(TABLE(4,ITAB).EQ.0)PRINT *,' !!!!!! FLDCHK WARNING :'// - ' Field zero at ITAB=',ITAB,' (program bug) ;'// - ' extrapolation probably incorrect' 10 CONTINUE * Loop over the quantities to be extrapolated. DO 40 KTAB=2,5 * Extrapolate using Neville polynomial extrapolation. DO 30 ITAB=1,5 DO 20 JTAB=ITAB-1,1,-1 TABLE(KTAB,JTAB)=TABLE(KTAB,JTAB+1)+ - (TABLE(KTAB,JTAB+1)-TABLE(KTAB,JTAB))* - (0.5*D(I)-TABLE(1,ITAB))/(TABLE(1,ITAB)-TABLE(1,JTAB)) 20 CONTINUE 30 CONTINUE 40 CONTINUE * Add new values at r and at 2 r to the sum. NDATA=NDATA+1 ERADS=ERADS+TABLE(4,1) VRADS=VRADS+TABLE(5,1) E2RADS=E2RADS+TABLE(4,5) V2RADS=V2RADS+TABLE(5,5) * Store the results for a save later. PHVECT(NDATA)=ANG EXVECT(NDATA)=TABLE(2,1) EYVECT(NDATA)=TABLE(3,1) ETVECT(NDATA)=TABLE(4,1) VTVECT(NDATA)=TABLE(5,1) * Compute radial component of the electric field. CHNUM=CHNUM+TABLE(2,5)*COS(ANG)+TABLE(3,5)*SIN(ANG) * Compute the angle at the surface of the wire. SURFTH=TABLE(2,1)*COS(ANG)+TABLE(3,1)*SIN(ANG) IF(TABLE(4,1).EQ.0.0)SURFTH=1.0 IF(TABLE(4,1).NE.0.0)SURFTH=SURFTH/TABLE(4,1) IF(ABS(SURFTH).GT.1.0)SURFTH=1.0 SURFTH=90.0+(180.0/PI)*ACOS(SURFTH) SURFTS=SURFTS+SURFTH * Print values for this angle. WRITE(LUNOUT,'(1X,F10.1,5F15.4)') - 180*ANG/PI,TABLE(4,1),TABLE(4,5), - TABLE(5,1),TABLE(5,5),SURFTH 50 CONTINUE * Check data has been collected. IF(NDATA.EQ.0)THEN WRITE(LUNOUT,'(/'' No data collected for this'', - '' wire; no averages or check sums.''/)') GOTO 60 ENDIF * Print averages. WRITE(LUNOUT,'(''0 Averages'',5F15.4,/)') - ERADS/NDATA,E2RADS/NDATA, - VRADS/NDATA,V2RADS/NDATA,SURFTS/NDATA * Print check-charge. CHNUM=CHNUM*D(I)/NDATA IF(POLAR)CHNUM=CHNUM*EXP(X(I)) IF(E(I).EQ.0.OR.CHNUM.EQ.0)THEN CHERR=0.0 ELSE CHERR=100.0*ABS((CHNUM-E(I))/E(I)) ENDIF WRITE(LUNOUT,'(/'' Charge calculated using the electric'', - '' field '',E10.3,'' (relative error '',E10.3, - ''%)''/)') CHNUM,CHERR * Save the data if required, format the wire number. IF(LKEEP)THEN CALL OUTFMT(REAL(I),2,INFILE,NC,'LEFT') ISIZ(1)=NDATA IDIM(1)=20 CALL MATSAV(EXVECT,1,IDIM,ISIZ, - 'EX_'//INFILE(1:NC),IFAIL1) CALL MATSAV(EYVECT,1,IDIM,ISIZ, - 'EY_'//INFILE(1:NC),IFAIL2) CALL MATSAV(ETVECT,1,IDIM,ISIZ, - 'E_'//INFILE(1:NC),IFAIL3) CALL MATSAV(VTVECT,1,IDIM,ISIZ, - 'V_'//INFILE(1:NC),IFAIL4) CALL MATSAV(PHVECT,1,IDIM,ISIZ, - 'PHI_'//INFILE(1:NC),IFAIL5) IF(IFAIL1.EQ.0.AND.IFAIL2.EQ.0.AND.IFAIL3.EQ.0.AND. - IFAIL4.EQ.0.AND.IFAIL5.EQ.0)THEN PRINT *,' ------ FLDCHK MESSAGE : Saving'// - ' EX_'//INFILE(1:NC)//', EY_'//INFILE(1:NC)// - ', E_'//INFILE(1:NC)//', V_'//INFILE(1:NC)// - ' and PHI_'//INFILE(1:NC)//' as surface'// - ' field on wire '//INFILE(1:NC)//'.' ELSE PRINT *,' !!!!!! FLDCHK WARNING : Unable to'// - ' save the surface field of wire '// - INFILE(1:NC)//'.' ENDIF ENDIF * Next wire, 60 CONTINUE * End of this step, register amount of CPU time. CALL TIMLOG('Check: field on the wire-surface: ') ENDIF *** Check of the planes. IF(LPLCHK)THEN DO 120 I=1,4 IF(.NOT.YNPLAN(I))GOTO 120 * Print a suitable heading. IF(.NOT.POLAR)THEN IF(I.LE.2)WRITE(LUNOUT,1040) I,'X',COPLAN(I),VTPLAN(I) IF(I.GE.3)WRITE(LUNOUT,1040) I,'Y',COPLAN(I),VTPLAN(I) ELSE IF(I.LE.2)WRITE(LUNOUT,1040) - I,'R',EXP(COPLAN(I)),VTPLAN(I) IF(I.GE.3)WRITE(LUNOUT,1040) - I,'P',180.0*COPLAN(I)/PI,VTPLAN(I) ENDIF IF(I.LE.2)THEN IF(POLAR)THEN WRITE(LUNOUT,'('' phi-coord. V inside'', - '' V outside Er inside E'', - ''r outside''/)') ELSE WRITE(LUNOUT,'('' y-coord. V left'', - '' V right Ex left '', - '' Ex right''/)') ENDIF DO 100 J=0,10 CALL EFIELD(COPLAN(I)-(XMAX-XMIN)/1000.0, - YMIN+J*(YMAX-YMIN)/10.0,0.0, - EX1,EY1,EZ1,ETOT1,V1,1,ILOC) CALL EFIELD(COPLAN(I)+(XMAX-XMIN)/1000.0, - YMIN+J*(YMAX-YMIN)/10.0,0.0, - EX2,EY2,EZ2,ETOT2,V2,1,ILOC) IF(POLAR)THEN EX1=EX1/EXP(COPLAN(I)-(XMAX-XMIN)/1000.0) EX2=EX2/EXP(COPLAN(I)+(XMAX-XMIN)/1000.0) ENDIF IF(POLAR)WRITE(LUNOUT,'(1X,F10.1,4F15.4)') - 180.0*(YMIN+J*(YMAX-YMIN)/10.0)/PI,V1,V2,EX1,EX2 IF(.NOT.POLAR)WRITE(LUNOUT,'(1X,F10.1,4F15.4)') - YMIN+J*(YMAX-YMIN)/10.0,V1,V2,EX1,EX2 100 CONTINUE ELSE IF(POLAR)THEN WRITE(LUNOUT,'('' r-coord. V above'', - '' V under Ephi above '', - '' Ephi under''/)') ELSE WRITE(LUNOUT,'('' x coord. V above'', - '' V under Ey above '', - '' Ey under''/)') ENDIF DO 110 J=0,10 IF(POLAR)XPRT=LOG(EXP(XMIN)+ - J*(EXP(XMAX)-EXP(XMIN))/10.0) IF(.NOT.POLAR)XPRT=XMIN+J*(XMAX-XMIN)/10.0 CALL EFIELD(XPRT,COPLAN(I)+(YMAX-YMIN)/1000.0,0.0, - EX1,EY1,EZ1,ETOT1,V1,1,ILOC) CALL EFIELD(XPRT,COPLAN(I)-(YMAX-YMIN)/1000.0,0.0, - EX2,EY2,EZ2,ETOT2,V2,1,ILOC) IF(POLAR)THEN EY1=EY1/EXP(XPRT) EY2=EY2/EXP(XPRT) ENDIF IF(POLAR)WRITE(LUNOUT,'(1X,F10.1,4F15.4)') - EXP(XPRT),V1,V2,EY1,EY2 IF(.NOT.POLAR)WRITE(LUNOUT,'(1X,F10.1,4F15.4)') - XPRT,V1,V2,EY1,EY2 110 CONTINUE ENDIF 120 CONTINUE * Register the amount of CPU time spent on this operation. CALL TIMLOG('Check: field on the planes: ') ENDIF *** Check of the tube. IF(LTUCHK.AND..NOT.TUBE)THEN PRINT *,' !!!!!! FLDCHK WARNING : Tube checking requested'// - ' but the cell has no tube.' ELSEIF(LTUCHK)THEN * Print a heading. WRITE(LUNOUT,1050) COTUBE,VTTUBE WRITE(LUNOUT,'('' phi V inside V outside'', - '' Er inside Ephi inside E outside''/ - '' [degrees] [V] [V]'', - '' [V/cm] [V/cm] [V/cm]''/)') * Summing variables. ERSUM=0.0 EPSUM=0.0 V1SUM=0.0 V2SUM=0.0 E2SUM=0.0 * Angular loop. DO 130 J=1,25 IF(NTUBE.GT.2)THEN PHI=REAL(J-1)*2*PI/REAL(25*NTUBE) IF(COS(PI/REAL(NTUBE)-PHI).EQ.0)GOTO 130 RLOC=COTUBE*COS(PI/REAL(NTUBE))/COS(PI/REAL(NTUBE)-PHI) PHIPRO=PI/REAL(NTUBE) ELSE PHI=REAL(J-1)*2*PI/REAL(25) RLOC=COTUBE PHIPRO=PHI ENDIF CALL EFIELD(0.999*RLOC*COS(PHI),0.999*RLOC*SIN(PHI), - 0.0,EX1,EY1,EZ1,ETOT1,V1,1,ILOC) CALL EFIELD(1.001*RLOC*COS(PHI),1.001*RLOC*SIN(PHI), - 0.0,EX2,EY2,EZ2,ETOT2,V2,1,ILOC) ER = COS(PHIPRO)*EX1+SIN(PHIPRO)*EY1 EPHI=-SIN(PHIPRO)*EX1+COS(PHIPRO)*EY1 ERSUM=ERSUM+ER EPSUM=EPSUM+EPHI V1SUM=V1SUM+V1 V2SUM=V2SUM+V2 E2SUM=E2SUM+ETOT2 WRITE(LUNOUT,'(1X,F10.1,5(1X,F12.5))') - 180*PHI/PI,V1,V2,ER,EPHI,ETOT2 130 CONTINUE * Print averages. WRITE(LUNOUT,'(/2X,''Average: '',5(1X,F12.5))') - V1SUM/25.0,V2SUM/25.0,ERSUM/25.0, - EPSUM/25.0,E2SUM/25.0 * Print summary. IF(NTUBE.GT.2)THEN ERSUM=ERSUM*0.999*SQRT(2*(1-COS(2*PI/REAL(NTUBE))))* - COTUBE*NTUBE/25.0 ELSE ERSUM=ERSUM*0.999*COTUBE/25.0 ENDIF ERCHK=0.0 DO 140 J=1,NWIRE IF(MTUBE.EQ.0.OR.X(J)**2+Y(J)**2.LT.D(J)**2/4)THEN ERCHK=ERCHK+E(J) ELSE ERCHK=ERCHK+E(J)*MTUBE ENDIF 140 CONTINUE WRITE(LUNOUT,'(/'' Charge check: Tube : '',E12.5/16X, - ''Wires : '',E12.5)') ERSUM,ERCHK * Register the amount of CPU time spent on this operation. CALL TIMLOG('Check: field on the tube surface: ') ENDIF *** Check that the charges match the electric field around them. IF(LCHCHK.AND.N3D.EQ.0)THEN PRINT *,' !!!!!! FLDCHK WARNING : Charge checking has been', - ' requested but there are no charges.' ELSEIF(LCHCHK)THEN * Print a header. WRITE(LUNOUT,'(''1 Check of the three dimensional charges''/ - '' ======================================''// - '' No Charge given Charge found'')') * Loop over the charges. DO 410 I=1,N3D * Determine for each of the charges a radius. DR=1E-4*(1+ABS(X3D(I))+ABS(Y3D(I))+ABS(Z3D(I))) * Check that there are no other charges nearby. DO 420 J=1,N3D IF(I.EQ.J)GOTO 420 IF((X3D(I)-X3D(J))**2+(Y3D(I)-Y3D(J))**2+ - (Z3D(I)-Z3D(J))**2.LT.DR**2)THEN PRINT *,' !!!!!! FLDCHK WARNING : Charge ',J,' is', - ' located too close to charge ',I,' to be able', - ' to verify the charges.' GOTO 410 ENDIF 420 CONTINUE * Check that there are no wires nearby. DO 430 J=1,NWIRE IF((X3D(I)-X(J))**2+(Y3D(I)-Y(J))**2.LT.DR**2)THEN PRINT *,' !!!!!! FLDCHK WARNING : Wire ',J,' is', - ' located too close to charge ',I,' to be able', - ' to verify the charges.' GOTO 410 ENDIF 430 CONTINUE * Determine the flow out of the sphere by MC integration. ESUM=0.0 NRNDM=0 DO 440 J=1,1000 * Generate a random point on the unit circle. XRNDM=-1+2*RNDM(1*J) YRNDM=-1+2*RNDM(2*J) ZRNDM=-1+2*RNDM(3*J) RRNDM=SQRT(XRNDM**2+YRNDM**2+ZRNDM**2) IF(RRNDM.EQ.0)GOTO 440 XRNDM=DR*XRNDM/RRNDM YRNDM=DR*YRNDM/RRNDM ZRNDM=DR*ZRNDM/RRNDM * Evaluate the field at that point. CALL EFIELD(X3D(I)+XRNDM,Y3D(I)+YRNDM,Z3D(I)+ZRNDM, - EX,EY,EZ,ETOT,VOLT,0,ILOC) IF(ILOC.NE.0)GOTO 440 NRNDM=NRNDM+1 * Project the field onto the out-bound vector. ESUM=ESUM+(EX*XRNDM+EY*YRNDM+EZ*ZRNDM)/DR * Next MC cycle. 440 CONTINUE * Print results for this charge. IF(NRNDM.EQ.0)THEN WRITE(LUNOUT,'(2X,I6,1X,''No data collected.'')') I ELSE WRITE(LUNOUT,'(2X,I6,1X,E15.8,1X,E15.8)') - I,E3D(I),ESUM*DR**2/NRNDM ENDIF * Next charge. 410 CONTINUE ENDIF *** Check that E and V are consistent ('MAXWELL' option). IF(LMWCHK)THEN * Print a suitable heading. IF(LMWPRT)THEN WRITE(LUNOUT,1100) IF(MAGOK)THEN WRITE(LUNOUT,'('' Divergence of the'', - '' magnetic field [V microsec/cm2]'')') ELSE WRITE(LUNOUT,'('' Potential '', - '' [V]'')') ENDIF IF(POLAR)WRITE(LUNOUT, - '('' WARNING: The coordinates are internal.'')') ENDIF * Allocate histograms. CALL HISADM('ALLOCATE',IHISEX,NCHA,0.0,0.0,.TRUE.,IFAIL1) CALL HISADM('ALLOCATE',IHISEY,NCHA,0.0,0.0,.TRUE.,IFAIL2) CALL HISADM('ALLOCATE',IHISEZ,NCHA,0.0,0.0,.TRUE.,IFAIL3) CALL HISADM('ALLOCATE',IHISDE,NCHA,0.0,0.0,.TRUE.,IFAIL4) CALL HISADM('ALLOCATE',IHISDB,NCHA,0.0,0.0,.TRUE.,IFAIL5) IF(IFAIL1+IFAIL2+IFAIL3+IFAIL4+IFAIL5.NE.0)THEN PRINT *,' !!!!!! FLDCHK WARNING : Unable to allocate'// - ' all required histograms.' ENDIF NENTEX=0 NENTEY=0 NENTEZ=0 NENTDE=0 NENTDB=0 * Loop over the whole area. ZPOS=0.0 DO 240 JJ=0,10*INT(REAL(NGRIDY-1)/10.0),10 JMAX=MIN(NGRIDY-JJ,10) DO 230 II=0,10*INT(REAL(NGRIDX-1)/10.0),10 IMAX=MIN(NGRIDX-II,10) IF(LMWPRT)WRITE(LUNOUT,1060) 1+II/10,1+JJ/10, - (PXMIN+(PXMAX-PXMIN)*REAL(II+I-1)/REAL(NGRIDX-1), - I=1,IMAX) IF(LMWPRT)WRITE(LUNOUT,'('' '')') DO 220 J=1,JMAX YPOS=PYMIN+(PYMAX-PYMIN)*REAL(JJ+J-1)/REAL(NGRIDY-1) DO 210 I=1,IMAX XPOS=PXMIN+(PXMAX-PXMIN)*REAL(II+I-1)/REAL(NGRIDX-1) * Preset the flags. FLAGEX(I)=.TRUE. FLAGEY(I)=.TRUE. FLAGEZ(I)=.TRUE. FLAGDE(I)=.TRUE. FLAGDB(I)=.TRUE. * Choose step sizes. DX=EPSMXW*(1.0+ABS(XPOS)) DY=EPSMXW*(1.0+ABS(YPOS)) DZ=EPSMXW*(1.0+ABS(ZPOS)) * Calculate the field. CALL EFIELD(XPOS ,YPOS ,ZPOS , - EX ,EY ,EZ ,ETOT ,VT ,1,ILOC1) CALL EFIELD(XPOS+DX,YPOS ,ZPOS , - EXX1,EYX1,EZX1,ETOT1,VX1,1,ILOC2) CALL EFIELD(XPOS-DX,YPOS ,ZPOS , - EXX2,EYX2,EZX2,ETOT2,VX2,1,ILOC3) CALL EFIELD(XPOS ,YPOS+DY,ZPOS , - EXY1,EYY1,EZY1,ETOT3,VY1,1,ILOC4) CALL EFIELD(XPOS ,YPOS-DY,ZPOS , - EXY2,EYY2,EZY2,ETOT4,VY2,1,ILOC5) CALL EFIELD(XPOS ,YPOS ,ZPOS+DZ, - EXZ1,EYZ1,EZZ1,ETOT5,VZ1,1,ILOC6) CALL EFIELD(XPOS ,YPOS ,ZPOS-DZ, - EXZ2,EYZ2,EZZ2,ETOT6,VZ2,1,ILOC7) EXVECT(I)=EX EYVECT(I)=EY EZVECT(I)=EZ VTVECT(I)=VT IF(MAGOK)THEN CALL BFIELD(XPOS ,YPOS ,ZPOS , - BX ,BY ,BZ ,BTOT) CALL BFIELD(XPOS+DX,YPOS ,ZPOS , - BXX1,BYX1,BZX1,BTOT) CALL BFIELD(XPOS-DX,YPOS ,ZPOS , - BXX2,BYX2,BZX2,BTOT) CALL BFIELD(XPOS ,YPOS+DY,ZPOS , - BXY1,BYY1,BZY1,BTOT) CALL BFIELD(XPOS ,YPOS-DY,ZPOS , - BXY2,BYY2,BZY2,BTOT) CALL BFIELD(XPOS ,YPOS ,ZPOS+DZ, - BXZ1,BYZ1,BZZ1,BTOT) CALL BFIELD(XPOS ,YPOS ,ZPOS-DZ, - BXZ2,BYZ2,BZZ2,BTOT) ENDIF * Skip histogramming if (XPOS,YPOS) lies within or near a wire. IF(ILOC1.NE.0.OR.ILOC2.NE.0.OR.ILOC3.NE.0.OR.ILOC4.NE.0.OR. - ILOC5.NE.0.OR.ILOC6.NE.0.OR.ILOC7.NE.0)THEN DVDX(I)=-EX DVDY(I)=-EY DVDZ(I)=-EZ DIVE(I)=0.0 DIVB(I)=0.0 FLAGEX(I)=.FALSE. FLAGEY(I)=.FALSE. FLAGEZ(I)=.FALSE. FLAGDE(I)=.FALSE. FLAGDB(I)=.FALSE. GOTO 210 ENDIF * Calculate derivatives and divergence. IF((VX1-VT)*(VT-VX2).LT.0)FLAGEX(I)=.FALSE. DVDX(I)=(VX1-VX2)/(2*DX) IF((VY1-VT)*(VT-VY2).LT.0)FLAGEY(I)=.FALSE. DVDY(I)=(VY1-VY2)/(2*DY) IF((VZ1-VT)*(VT-VZ2).LT.0)FLAGEZ(I)=.FALSE. DVDZ(I)=(VZ1-VZ2)/(2*DZ) IF((EXX1-EX)*(EX-EXX2).LT.0.OR. - (EYY1-EY)*(EY-EYY2).LT.0.OR. - (EZZ1-EZ)*(EZ-EZZ2).LT.0)FLAGDE(I)=.FALSE. DIVE(I)=(EXX1-EXX2)/(2*DX)+(EYY1-EYY2)/(2*DY)+ - (EZZ1-EZZ2)/(2*DZ) IF(MAGOK)THEN IF((BXX1-BX)*(BX-BXX2).LT.0.OR. - (BYY1-BY)*(BY-BYY2).LT.0.OR. - (BZZ1-BZ)*(BZ-BZZ2).LT.0)FLAGDB(I)=.FALSE. DIVB(I)=(BXX1-BXX2)/(2*DX)+(BYY1-BYY2)/(2*DY)+ - (BZZ1-BZZ2)/(2*DZ) ENDIF * Fill histograms. IF(ABS(DVDX(I))+ABS(EX).NE.0.AND.FLAGEX(I))THEN CALL HISENT(IHISEX,(DVDX(I)+EX)/(ABS(DVDX(I))+ABS(EX)), - 1.0) NENTEX=NENTEX+1 ENDIF IF(ABS(DVDY(I))+ABS(EY).NE.0.AND.FLAGEY(I))THEN CALL HISENT(IHISEY,(DVDY(I)+EY)/(ABS(DVDY(I))+ABS(EY)), - 1.0) NENTEY=NENTEY+1 ENDIF IF(ABS(DVDZ(I))+ABS(EZ).NE.0.AND.FLAGEZ(I))THEN CALL HISENT(IHISEZ,(DVDZ(I)+EZ)/(ABS(DVDZ(I))+ABS(EZ)), - 1.0) NENTEZ=NENTEZ+1 ENDIF IF(FLAGDE(I))THEN CALL HISENT(IHISDE,DIVE(I),1.0) NENTDE=NENTDE+1 ENDIF IF(MAGOK.AND.FLAGDB(I))THEN CALL HISENT(IHISDB,DIVB(I),1.0) NENTDB=NENTDB+1 ENDIF 210 CONTINUE * Print the quantities obtained. WRITE(INFILE,'(1X,F8.2,3X,10(F10.3,2X:))') - YPOS,(DVDX(I)+EXVECT(I),I=1,IMAX) DO 250 I=1,IMAX IF(.NOT.FLAGEX(I))INFILE(1+I*12:10+I*12)=' (invalid)' 250 CONTINUE IF(LMWPRT)WRITE(LUNOUT,'(A)') INFILE WRITE(INFILE,'(12X,10(F10.3,2X:))') - (DVDY(I)+EYVECT(I),I=1,IMAX) DO 260 I=1,IMAX IF(.NOT.FLAGEY(I))INFILE(1+I*12:10+I*12)=' (invalid)' 260 CONTINUE IF(LMWPRT)WRITE(LUNOUT,'(A)') INFILE WRITE(INFILE,'(12X,10(F10.3,2X:))') - (DVDZ(I)+EZVECT(I),I=1,IMAX) DO 265 I=1,IMAX IF(.NOT.FLAGEZ(I))INFILE(1+I*12:10+I*12)=' (invalid)' 265 CONTINUE IF(LMWPRT)WRITE(LUNOUT,'(A)') INFILE WRITE(INFILE,'(12X,10(F10.3,2X:))') (DIVE(I),I=1,IMAX) DO 270 I=1,IMAX IF(.NOT.FLAGDE(I))INFILE(1+I*12:10+I*12)=' (invalid)' 270 CONTINUE IF(LMWPRT)WRITE(LUNOUT,'(A)') INFILE IF(MAGOK)THEN WRITE(INFILE,'(12X,10(F10.3,2X:))') (DIVB(I),I=1,IMAX) DO 280 I=1,IMAX IF(.NOT.FLAGDB(I))INFILE(1+I*12:10+I*12)=' (invalid)' 280 CONTINUE IF(LMWPRT)WRITE(LUNOUT,'(A)') INFILE ELSE IF(LMWPRT)WRITE(LUNOUT,'(12X,10(F10.3,2X:))') - (VTVECT(I),I=1,IMAX) ENDIF IF(LMWPRT)WRITE(LUNOUT,'('' '')') 220 CONTINUE 230 CONTINUE 240 CONTINUE * Plot the histograms. IF(NENTEX.GT.0.AND.LMWPLT)THEN CALL HISPLT(IHISEX, - '(dV/dx + Ex) / (|dV/dx| + |Ex|)', - 'Relative error in Ex',.TRUE.) IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) CALL GRNEXT CALL GRALOG('Relative error in Ex') ELSEIF(LMWPLT)THEN PRINT *,' !!!!!! FLDCHK WARNING : No useable data'// - ' collected for dV/dx + Ex; check epsilon.' ENDIF IF(NENTEY.GT.0.AND.LMWPLT)THEN CALL HISPLT(IHISEY, - '(dV/dy + Ey) / (|dV/dy| + |Ey|)', - 'Relative error in Ey',.TRUE.) IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) CALL GRNEXT CALL GRALOG('Relative error in Ey') ELSEIF(LMWPLT)THEN PRINT *,' !!!!!! FLDCHK WARNING : No useable data'// - ' collected for dV/dy + Ey; check epsilon.' ENDIF IF(NENTEZ.GT.0.AND.LMWPLT)THEN CALL HISPLT(IHISEZ, - '(dV/dz + Ez) / (|dV/dz| + |Ez|)', - 'Relative error in Ez',.TRUE.) IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) CALL GRNEXT CALL GRALOG('Relative error in Ez') ELSEIF(LMWPLT)THEN PRINT *,' !!!!!! FLDCHK WARNING : No useable data'// - ' collected for dV/dz + Ez; check epsilon.' ENDIF IF(NENTDE.GT.0.AND.LMWPLT)THEN CALL HISPLT(IHISDE, - 'dEx/dx+dEy/dy+dEz/dz [V/cm2]', - 'Divergence of the electric field',.TRUE.) IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) CALL GRNEXT CALL GRALOG('Divergence of the E field') ELSEIF(LMWPLT)THEN PRINT *,' !!!!!! FLDCHK WARNING : No useable data'// - ' collected for div E; check epsilon.' ENDIF IF(MAGOK.AND.NENTDB.GT.0.AND.LMWPLT)THEN CALL HISPLT(IHISDB, - 'dBz/dz + dBz/dz', - 'Divergence of the magnetic field',.TRUE.) IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) CALL GRNEXT CALL GRALOG('Divergence of the B field ') ELSEIF(MAGOK.AND.LMWPLT)THEN PRINT *,' !!!!!! FLDCHK WARNING : No useable data'// - ' collected for div B; check epsilon.' ENDIF * Delete histograms. IF(LKEEP)THEN CALL HISSAV(IHISEX,'EX_ERROR',IFAIL1) CALL HISSAV(IHISEY,'EY_ERROR',IFAIL2) CALL HISSAV(IHISEZ,'EZ_ERROR',IFAIL3) CALL HISSAV(IHISDE,'DIV_E',IFAIL4) CALL HISSAV(IHISDB,'DIV_B',IFAIL5) IF(IFAIL1.EQ.0.AND.IFAIL2.EQ.0.AND.IFAIL3.EQ.0.AND. - IFAIL4.EQ.0.AND.IFAIL5.EQ.0)THEN PRINT *,' ------ FLDCHK MESSAGE : Maxwell'// - ' histograms saved as EX_ERROR, EY_ERROR'// - ' EZ_ERROR, DIV_E (DIV_B).' ELSE PRINT *,' !!!!!! FLDCHK WARNING : Error saving'// - ' the Maxwell histograms.' ENDIF ELSE CALL HISADM('DELETE',IHISEX,0,0.0,0.0,.FALSE.,IFAIL1) CALL HISADM('DELETE',IHISEY,0,0.0,0.0,.FALSE.,IFAIL2) CALL HISADM('DELETE',IHISEZ,0,0.0,0.0,.FALSE.,IFAIL3) CALL HISADM('DELETE',IHISDE,0,0.0,0.0,.FALSE.,IFAIL4) CALL HISADM('DELETE',IHISDB,0,0.0,0.0,.FALSE.,IFAIL5) ENDIF * Register the amount of cpu time spent on this operation. CALL TIMLOG('Check: consistency of E and V: ') ENDIF *** Look for 'DIELECTRICA' option. IF(LMTCHK)THEN IF(YNMATX)THEN * Prepare a comment label. INFILE='Dielectric constant: ' CALL OUTFMT(XMATT(1,5),2,INFILE(22:),NC,'LEFT') * Walk along the boundary. DO 300 I=1,MXLIST XPL(I)=YMIN+REAL(I-1)*(YMAX-YMIN)/REAL(MXLIST-1) CALL EFIELD(COMATX-1.0E-3*(1+ABS(COMATX)),XPL(I),0.0, - EXPL1(I),EYPL1(I),EZ,ETOT,VPL1(I),1,ILOC1) CALL EFIELD(COMATX+1.0E-3*(1+ABS(COMATX)),XPL(I),0.0, - EXPL2(I),EYPL2(I),EZ,ETOT,VPL2(I),1,ILOC2) 300 CONTINUE * Plot the Ex ratio. DO 310 I=1,MXLIST IF(EXPL1(I).EQ.0.OR.EXPL2(I).EQ.0)THEN YPL(I)=0.0 ELSE YPL(I)=EXPL1(I)/EXPL2(I) ENDIF 310 CONTINUE CALL GRGRPH(XPL,YPL,MXLIST,'y-axis [cm]', - 'Ex right / Ex left','CHECKING EX') AUX=XPL(2) XPL(2)=XPL(MXLIST) IF(XMATT(1,3).NE.0)THEN YPL(1)=XMATT(1,5) ELSE YPL(1)=1/XMATT(1,5) ENDIF YPL(2)=YPL(1) CALL GRATTS('COMMENT','POLYLINE') CALL GPL(2,XPL,YPL) XPL(2)=AUX IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) CALL GRCOMM(3,INFILE(1:21+NC)) CALL GRNEXT CALL GRALOG('Check of Ex on a dielectric x-boundary. ') * Plot the Ey ratio. DO 320 I=1,MXLIST IF(EYPL1(I).EQ.0.OR.EYPL2(I).EQ.0)THEN YPL(I)=1.0 ELSE YPL(I)=EYPL1(I)/EYPL2(I) ENDIF 320 CONTINUE CALL GRGRPH(XPL,YPL,MXLIST,'y-axis [cm]', - 'Ey right / Ey left','CHECKING EY') AUX=XPL(2) XPL(2)=XPL(MXLIST) YPL(1)=1.0 YPL(2)=1.0 CALL GRATTS('COMMENT','POLYLINE') CALL GPL(2,XPL,YPL) XPL(2)=AUX IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) CALL GRCOMM(3,INFILE(1:21+NC)) CALL GRNEXT CALL GRALOG('Check of Ey on a dielectric x-boundary. ') * Plot the V ratio. DO 330 I=1,MXLIST IF(VPL1(I).EQ.0.OR.VPL2(I).EQ.0)THEN YPL(I)=1.0 ELSE YPL(I)=VPL1(I)/VPL2(I) ENDIF 330 CONTINUE CALL GRGRPH(XPL,YPL,MXLIST,'y-axis [cm]', - 'V right / V left','CHECKING V') AUX=XPL(2) XPL(2)=XPL(MXLIST) YPL(1)=1.0 YPL(2)=1.0 CALL GRATTS('COMMENT','POLYLINE') CALL GPL(2,XPL,YPL) XPL(2)=AUX IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) CALL GRCOMM(3,INFILE(1:21+NC)) CALL GRNEXT CALL GRALOG('Check of V on a dielectric x-boundary. ') ENDIF * Register the amount of CPU time spent on this operation. CALL TIMLOG('Check: dielectrica: ') ENDIF END +DECK,FLDIN2. SUBROUTINE FLDIN2(XXC,YYC,RRC,QINT) *----------------------------------------------------------------------- * FLDIN2 - Integrates the charge in a circle with radius RC around * (XC,YC). * (Last changed on 8/ 4/98.) *----------------------------------------------------------------------- implicit none +SEQ,CONSTANTS. REAL XXC,YYC,RRC,QINT DOUBLE PRECISION XAUX(6),XC,YC,ZC,RC,DGMLT1 EXTERNAL FCHK3,DGMLT1 COMMON /FCHDAT/ XC,YC,ZC,RC *** Generate double precision copies for the common block. XC=DBLE(XXC) YC=DBLE(YYC) ZC=0.0D0 RC=DBLE(RRC) *** Perform the integration. QINT=REAL(DGMLT1(FCHK3,0.0D0,DBLE(2*PI),50,6,XAUX))/(2*PI) END +DECK,FLDIN3. SUBROUTINE FLDIN3(XXC,YYC,ZZC,RRC,QINT) *----------------------------------------------------------------------- * FLDIN3 - Integrates the charge in a sphere with radius RC around * (XC,YC,ZC). * (Last changed on 8/ 4/98.) *----------------------------------------------------------------------- implicit none +SEQ,CONSTANTS. REAL XXC,YYC,ZZC,RRC,QINT DOUBLE PRECISION XAUX(6),XC,YC,ZC,RC,DGMLT2 EXTERNAL FCHK2,DGMLT2 COMMON /FCHDAT/ XC,YC,ZC,RC *** Generate double precision copies for the common block. XC=DBLE(XXC) YC=DBLE(YYC) ZC=DBLE(ZZC) RC=DBLE(RRC) *** Perform the integration. QINT=REAL(DGMLT2(FCHK2,DBLE(-PI/2),DBLE(PI/2),20,6,XAUX))/(4*PI) END +DECK,FLDIN4. SUBROUTINE FLDIN4(XX0,YY0,ZZ0,DDX1,DDY1,DDZ1,DDX2,DDY2,DDZ2,Q, - NNU,NNV) *----------------------------------------------------------------------- * FLDIN4 - Integrates the electric field flux through a parallelogram * with corners (X0,Y0,Z0), (X0+DX1,Y0+DY1,Z0+DZ1), * (X0+DX2,Y0+DY2,Z0+DZ2). * (Last changed on 28/ 5/98.) *----------------------------------------------------------------------- implicit none +SEQ,PRINTPLOT. +SEQ,CONSTANTS. REAL XX0,YY0,ZZ0,DDX1,DDY1,DDZ1,DDX2,DDY2,DDZ2,Q DOUBLE PRECISION X0,Y0,Z0,DX1,DY1,DZ1,DX2,DY2,DZ2,XN,YN,ZN, - XAUX(6),DGMLT2 INTEGER NNU,NNV,NU,NV EXTERNAL FCHK4,DGMLT2 COMMON /FCHDA4/ X0,Y0,Z0,DX1,DY1,DZ1,DX2,DY2,DZ2,XN,YN,ZN,NU,NV *** Create double precision copies of the coordinates. X0=DBLE(XX0) Y0=DBLE(YY0) Z0=DBLE(ZZ0) DX1=DBLE(DDX1) DY1=DBLE(DDY1) DZ1=DBLE(DDZ1) DX2=DBLE(DDX2) DY2=DBLE(DDY2) DZ2=DBLE(DDZ2) NU=NNU NV=NNV *** Check integration points. IF(NU.LE.1.OR.NV.LE.1)THEN PRINT *,' !!!!!! FLDIN4 WARNING : Number of points to'// - ' integrate over is not > 1 ; flux set to 0.' Q=0 RETURN ENDIF IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ FLDIN4 DEBUG : Number'', - '' of integration points: '',2I5)') NU,NV *** Compute the normal vector. XN=DY1*DZ2-DZ1*DY2 YN=DZ1*DX2-DX1*DZ2 ZN=DX1*DY2-DY1*DX2 IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ FLDIN4 DEBUG : Norm'', - '' vector = '',3E12.5)') XN,YN,ZN *** If this vector has zero norm, return 0 flux. IF(XN**2+YN**2+ZN**2.LT.1D-10* - SQRT((DX1**2+DY1**2+DZ1**2)*(DX2**2+DY2**2+DZ2**2)).OR. - DX1**2+DY1**2+DZ1**2.LT.1D-10*(DX2**2+DY2**2+DZ2**2).OR. - DX2**2+DY2**2+DZ2**2.LT.1D-10*(DX1**2+DY1**2+DZ1**2))THEN PRINT *,' !!!!!! FLDIN4 WARNING : Area is not a'// - ' parallelogram with non-zero area; flux set to 0.' Q=0 RETURN ENDIF *** Perform the integration. Q=REAL(DGMLT2(FCHK4,0.0D0,1.0D0,NV,6,XAUX)) END +DECK,FLDIN5. SUBROUTINE FLDIN5(XX0,YY0,ZZ0,XX1,YY1,ZZ1,XXP,YYP,ZZP,Q,NNU, - IISIGN) *----------------------------------------------------------------------- * FLDIN5 - Integrates the electric field flux through a line from * (X0,Y0,Z0) to (X1,Y1,Z1) along a direction (XP,YP,ZP). * (Last changed on 14/ 5/99.) *----------------------------------------------------------------------- implicit none +SEQ,PRINTPLOT. +SEQ,CONSTANTS. REAL XX0,YY0,ZZ0,XX1,YY1,ZZ1,XXP,YYP,ZZP,Q DOUBLE PRECISION X0,Y0,Z0,X1,Y1,Z1,XP,YP,ZP,XAUX(6),DGMLT1 INTEGER NNU,NU,IISIGN,ISIGN EXTERNAL FCHK6,DGMLT1 COMMON /FCHDA6/ X0,Y0,Z0,X1,Y1,Z1,XP,YP,ZP,NU,ISIGN *** Create double precision copies of the coordinates. X0=DBLE(XX0) Y0=DBLE(YY0) Z0=DBLE(ZZ0) X1=DBLE(XX1) Y1=DBLE(YY1) Z1=DBLE(ZZ1) * Normalise the norm vector. IF(XXP**2+YYP**2+ZZP**2.GT.0)THEN XP=DBLE(XXP/SQRT(XXP**2+YYP**2+ZZP**2)) YP=DBLE(YYP/SQRT(XXP**2+YYP**2+ZZP**2)) ZP=DBLE(ZZP/SQRT(XXP**2+YYP**2+ZZP**2)) ELSE PRINT *,' !!!!!! FLDIN5 WARNING : Normal vector has zero'// - ' length; flux set to 0.' Q=0 RETURN ENDIF * Copy number of integration intervals. NU=NNU * Copy the integration sign. ISIGN=IISIGN *** Check integration points. IF(NU.LE.1)THEN PRINT *,' !!!!!! FLDIN5 WARNING : Number of points to'// - ' integrate over is not > 1 ; flux set to 0.' Q=0 RETURN ENDIF *** Ensure the segment has non-zero length. IF((X0-X1)**2+(Y0-Y1)**2+(Z0-Z1)**2.LE.0)THEN PRINT *,' !!!!!! FLDIN5 WARNING : Segment has zero'// - ' length; flux set to 0.' Q=0 RETURN * Segment should be perpendicular to the norm vector. ELSEIF(ABS((X1-X0)*XP+(Y1-Y0)*YP+(Z1-Z0)*ZP).GT. - 1D-4*SQRT(((X0-X1)**2+(Y0-Y1)**2+(Z0-Z1)**2)* - (XP**2+YP**2+ZP**2)))THEN C print *,' product: ',ABS((X1-X0)*XP+(Y1-Y0)*YP+(Z1-Z0)*ZP) C print *,' length: ',SQRT((X0-X1)**2+(Y0-Y1)**2+(Z0-Z1)**2) C print *,' norm: ',sqrt(XP**2+YP**2+ZP**2) PRINT *,' !!!!!! FLDIN5 WARNING : Segment is not'// - ' perpendicular to norm vector; flux set to 0.' Q=0 RETURN ENDIF *** Perform the integration. Q=REAL(DGMLT1(FCHK6,0.0D0,1.0D0,NU,6,XAUX))* - SQRT((X0-X1)**2+(Y0-Y1)**2+(Z0-Z1)**2) END +DECK,FCHK1. SUBROUTINE FCHK1(M,U1,F1,X) *----------------------------------------------------------------------- * FCHK1 - One of 2 auxiliary routines for verifying that space * charges indeed have the proper charge. * (Last changed on 8/ 4/98.) *----------------------------------------------------------------------- implicit none DOUBLE PRECISION U1(*),F1(*),X(2),XC,YC,ZC,RC REAL XF,YF,ZF,EX,EY,EZ,ETOT,VOLT INTEGER ILOC,L,M COMMON /FCHDAT/ XC,YC,ZC,RC *** Loop over the positions. DO 10 L=1,M X(1)=U1(L) XF=XC+COS(X(1))*COS(X(2))*RC YF=YC+SIN(X(1))*COS(X(2))*RC ZF=ZC+ SIN(X(2))*RC CALL EFIELD(XF,YF,ZF,EX,EY,EZ,ETOT,VOLT,0,ILOC) F1(L)=DBLE((EX*COS(X(1))+EY*SIN(X(1)))*COS(X(2))+EZ*SIN(X(2))) 10 CONTINUE END +DECK,FCHK2. SUBROUTINE FCHK2(M,U2,F2,X) *----------------------------------------------------------------------- * FCHK2 - One of 2 auxiliary routines for verifying that space * charges indeed have the proper charge. * (Last changed on 8/ 4/98.) *----------------------------------------------------------------------- implicit none +SEQ,CONSTANTS. DOUBLE PRECISION U2(*),F2(*),X(2),XC,YC,ZC,RC,DGMLT1 INTEGER L,M EXTERNAL FCHK1,DGMLT1 COMMON /FCHDAT/ XC,YC,ZC,RC *** Loop over the positions. DO 10 L=1,M X(2)=U2(L) F2(L)=RC**2*COS(X(2))*DGMLT1(FCHK1,0.0D0,DBLE(2*PI),20,6,X) 10 CONTINUE END +DECK,FCHK3. SUBROUTINE FCHK3(M,U1,F1,X) *----------------------------------------------------------------------- * FCHK3 - One of 2 auxiliary routines for verifying that space * charges indeed have the proper charge. * (Last changed on 8/ 4/98.) *----------------------------------------------------------------------- implicit none DOUBLE PRECISION U1(*),F1(*),X(2),XC,YC,ZC,RC REAL XF,YF,EX,EY,EZ,ETOT,VOLT INTEGER ILOC,L,M COMMON /FCHDAT/ XC,YC,ZC,RC *** Loop over the positions. DO 10 L=1,M X(1)=U1(L) XF=XC+COS(X(1))*RC YF=YC+SIN(X(1))*RC CALL EFIELD(XF,YF,0.0,EX,EY,EZ,ETOT,VOLT,0,ILOC) F1(L)=RC*DBLE(EX*COS(X(1))+EY*SIN(X(1))) 10 CONTINUE END +DECK,FCHK4. SUBROUTINE FCHK4(M,U2,F2,X) *----------------------------------------------------------------------- * FCHK4 - One of 2 auxiliary routines for calculating a flux. * (Last changed on 28/ 5/98.) *----------------------------------------------------------------------- implicit none +SEQ,CONSTANTS. DOUBLE PRECISION U2(*),F2(*),X(2),DGMLT1, - X0,Y0,Z0,DX1,DY1,DZ1,DX2,DY2,DZ2,XN,YN,ZN INTEGER L,M,NU,NV EXTERNAL FCHK5,DGMLT1 COMMON /FCHDA4/ X0,Y0,Z0,DX1,DY1,DZ1,DX2,DY2,DZ2,XN,YN,ZN,NU,NV *** Loop over the positions. DO 10 L=1,M X(2)=U2(L) F2(L)=DGMLT1(FCHK5,0.0D0,1.0D0,NU,6,X) 10 CONTINUE END +DECK,FCHK5. SUBROUTINE FCHK5(M,U1,F1,X) *----------------------------------------------------------------------- * FCHK5 - One of 2 auxiliary routines for calculating a flux. * (Last changed on 28/ 5/98.) *----------------------------------------------------------------------- implicit none DOUBLE PRECISION U1(*),F1(*),X(2), - X0,Y0,Z0,DX1,DY1,DZ1,DX2,DY2,DZ2,XN,YN,ZN REAL XF,YF,ZF,EX,EY,EZ,ETOT,VOLT INTEGER ILOC,L,M,NU,NV COMMON /FCHDA4/ X0,Y0,Z0,DX1,DY1,DZ1,DX2,DY2,DZ2,XN,YN,ZN,NU,NV *** Loop over the positions. DO 10 L=1,M X(1)=U1(L) XF=X0+X(1)*DX1+X(2)*DX2 YF=Y0+X(1)*DY1+X(2)*DY2 ZF=Z0+X(1)*DZ1+X(2)*DZ2 CALL EFIELD(XF,YF,ZF,EX,EY,EZ,ETOT,VOLT,0,ILOC) F1(L)=EX*XN+EY*YN+EZ*ZN 10 CONTINUE END +DECK,FCHK6. SUBROUTINE FCHK6(M,U1,F1,X) *----------------------------------------------------------------------- * FCHK6 - One of 2 auxiliary routines for calculating a flux. * (Last changed on 13/ 5/99.) *----------------------------------------------------------------------- implicit none DOUBLE PRECISION U1(*),F1(*),X(2), - X0,Y0,Z0,X1,Y1,Z1,XP,YP,ZP REAL XF,YF,ZF,EX,EY,EZ,ETOT,VOLT INTEGER ILOC,L,M,NU,ISIGN COMMON /FCHDA6/ X0,Y0,Z0,X1,Y1,Z1,XP,YP,ZP,NU,ISIGN *** Loop over the positions. DO 10 L=1,M X(1)=U1(L) XF=X0+X(1)*(X1-X0) YF=Y0+X(1)*(Y1-Y0) ZF=Z0+X(1)*(Z1-Z0) CALL EFIELD(XF,YF,ZF,EX,EY,EZ,ETOT,VOLT,0,ILOC) IF(ISIGN.EQ.0)THEN F1(L)=EX*XP+EY*YP+EZ*ZP ELSEIF(ISIGN*(EX*XP+EY*YP+EZ*ZP).GT.0)THEN F1(L)=ABS(EX*XP+EY*YP+EZ*ZP) ELSE F1(L)=-1 ENDIF 10 CONTINUE END +PATCH,ZERO. +DECK,ZROTST. SUBROUTINE ZROTST +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,PRINTPLOT. +SEQ,ZERODATA. 1010 FORMAT(' ',3F10.3) *** REST VAN DE PARAMETERS 10 CONTINUE PRINT *,' Please enter your next ZERO instruction:' CALL INPWRD(NWORD) IF(NWORD.EQ.0)GOTO 10 IF(INPCMP(1,'ZOEK').NE.0)THEN CALL INPRDR(2,ZXMIN,PXMIN) CALL INPRDR(3,ZYMIN,PYMIN) CALL INPRDR(4,ZXMAX,PXMAX) CALL INPRDR(5,ZYMAX,PYMAX) CALL ZROFND(ZXMIN,ZYMIN,ZXMAX,ZYMAX,IFAIL) PRINT *,' # NULPUNTEN: ',NZ,' IFAIL=',IFAIL DO 20 I=1,NZ PRINT 1010,XZ(I),YZ(I),PZ(I) 20 CONTINUE ELSEIF(INPCMP(1,'F#IND').NE.0)THEN CALL INPRDR(2,ZXMIN,PXMIN) CALL INPRDR(3,ZYMIN,PYMIN) CALL INPRDR(4,ZXMAX,PXMAX) CALL INPRDR(5,ZYMAX,PYMAX) CALL ZROLOC(X0,Y0,ZXMIN,ZYMIN,ZXMAX,ZYMAX,IFAIL) PRINT *,' (X0,Y0)=',X0,Y0,' IFAIL=',IFAIL ELSEIF(INPCMP(1,'ST#OP').NE.0)THEN RETURN ELSE PRINT *,' Unknown instruction.' ENDIF GOTO 10 END +DECK,ZROFND. SUBROUTINE ZROFND(ZXMIN,ZYMIN,ZXMAX,ZYMAX,IFAIL) *----------------------------------------------------------------------- * ZROFND - This routine tries to find all zeros of the driftfield, * provided they are located in the rectangle (ZXMIN,ZYMIN), * (ZXMAX,ZYMAX). It stores them in the vector XZ,YZ. * VARIABLES: XLST,YDST,XRST,YUST : Rectangle searched for zeros * IDIRST : -1: Rectangle cut into 2 along y-axis, * +1: as -1, but the 2 halves are finished, * -2, +2: as -1 and +1, cut along the x-axis *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,ZERODATA. +SEQ,PRINTPLOT. +SEQ,CELLDATA. DIMENSION XLST(MXZERO),XRST(MXZERO),YDST(MXZERO),YUST(MXZERO) INTEGER NZST(MXZERO),IDIRST(MXZERO),ZROCNT EXTERNAL ZROCNT *** Define some output formats. *** Identify the routine and start debugging output, if requested. IF(LIDENT)PRINT *,' /// ROUTINE ZROFND ///' IF(LDEBUG)PRINT *,' ++++++ ZROFND DEBUG : Start of debug', - ' output' *** Initialise some global parameters. NZ=0 NFC=0 EMIN=1.0E-5 DAMIN=0.10 DAMAX=0.30 DPMIN=0.01 DPMAX=0.20 ZROSET=.FALSE. *** Initialise the search stack. IST=1 NZ=0 XLST(1)=ZXMIN XRST(1)=ZXMAX YDST(1)=ZYMIN YUST(1)=ZYMAX IDIRST(1)=-1 JWARN=0 IFAIL=0 *** Begin of 'recursive' loop, find no of zeros in the rectangle. 10 CONTINUE IF(LDEBUG)WRITE(*,'(/26X,''IST='',I3,'' Area='',4F10.3)') - IST,XLST(IST),YDST(IST),XRST(IST),YUST(IST) NZST(IST)=ZROCNT(XLST(IST),YDST(IST),XRST(IST),YUST(IST),IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' ###### ZROFND ERROR : Search abandoned because', - ' of a zero count error' RETURN ENDIF IF(NZST(IST).LT.0)THEN PRINT *,' ###### ZROFND ERROR : Number of zeros < 0', - ' (program bug) ; search abandoned' IFAIL=1 RETURN ENDIF IF(LDEBUG)WRITE(*,'(34X,''The area contains '',I3,'' zeros.'')') - NZST(IST) *** Subtract the number of zeros from the number for the larger area. IF(IST.NE.1)NZST(IST-1)=NZST(IST-1)-NZST(IST) *** 1 zero in the rectangle, check there is space left to store it, IF(NZST(IST).EQ.1)THEN IF(NZ+1.GT.MXZERO)THEN PRINT *,' !!!!!! ZROFND WARNING : number of', - ' zeros exceeds MXZERO (=',MXZERO,');', - ' remaining zeros not considered.' PRINT *,' Increase the', - ' MXZERO parameter to at least ',NZST(1), - ' and recompile the program.' IFAIL=1 RETURN ENDIF * and try to locate it. NZ=NZ+1 CALL ZROLOC(XZ(NZ),YZ(NZ),XLST(IST),YDST(IST), - XRST(IST),YUST(IST),IFAIL) IF(IFAIL.NE.0)NZ=NZ-1 ENDIF *** No zeros left, climb in the stack until an unfinished level is found IF((NZST(IST).EQ.0.OR.NZST(IST).EQ.1).AND.IFAIL.EQ.0)THEN 20 CONTINUE IST=IST-1 IF(IST.LT.1)GOTO 200 * warn if negative zero counts are found, IF(NZST(IST).LT.0)THEN IF(LDEBUG)WRITE(*,'(26X,''At IST='',I3,'' (flagged '', - I2,'') negative zero count: '',I3,''.'')') - IST,IDIRST(IST),NZST(IST) JWARN=JWARN+1 * warn for inconsistent counts (flagged finished but zeros left), ELSEIF(IDIRST(IST).GT.0.AND.NZST(IST).NE.0)THEN IF(LDEBUG)WRITE(*,'(26X,''At IST='',I3,'' (flagged '', - ''finished) '',I3,'' zeros left.'')')IST,NZST(IST) JWARN=JWARN+1 ENDIF * continue going upwards if the level is finished. IF(IDIRST(IST).GT.0.OR.NZST(IST).LE.0)GOTO 20 * Go one level deeper again setting a new search area. IST=IST+1 IF(IDIRST(IST-1).EQ.-1)THEN IDIRST(IST-1)=+1 XLST(IST)=XRST(IST) XRST(IST)=XRST(IST-1) ELSEIF(IDIRST(IST-1).EQ.-2)THEN IDIRST(IST-1)=+2 YDST(IST)=YUST(IST) YUST(IST)=YUST(IST-1) ENDIF *** Handle the case there is more than one zero. ELSEIF(NZST(IST).GT.1.OR.IFAIL.NE.0)THEN * Make sure there is room in the stack, IF(IST+1.GT.MXZERO)THEN PRINT *,' !!!!!! ZROFND WARNING : Stack exhausted;', - ' search for zeros abandoned.' PRINT *,' Increase the', - ' MXZERO parameter and recompile the program.' IFAIL=1 RETURN ENDIF * Split the area in 2, flag both halves as unfinished. IF(XRST(IST)-XLST(IST).GT.YUST(IST)-YDST(IST))THEN IDIRST(IST)=-1 XLST(IST+1)=XLST(IST) XRST(IST+1)=0.5*(XLST(IST)+XRST(IST)) YDST(IST+1)=YDST(IST) YUST(IST+1)=YUST(IST) ELSE IDIRST(IST)=-2 XLST(IST+1)=XLST(IST) XRST(IST+1)=XRST(IST) YDST(IST+1)=YDST(IST) YUST(IST+1)=0.5*(YDST(IST)+YUST(IST)) ENDIF IST=IST+1 ENDIF GOTO 10 * Normal end of this routine, warn for inconsistent zero counts. 200 CONTINUE IF(JWARN.NE.0)WRITE(*,'(/,'' !!!!!! ZROFND WARNING :'', - '' Number of detected inconsistent zero counts='',I3,/,25X, - '' zeros may well be missing and/or counted twice'')') JWARN IFAIL=0 IF(LDEBUG)WRITE(*,'(/26X,''A total of '',I3,'' zeros has been'', - '' located,'',/,26X,''requiring '',I4,'' function calls.''// - '' ++++++ ZROFND DEBUG : End of debug output.'')') - NZ,NFC END +DECK,ZROCNT. INTEGER FUNCTION ZROCNT(ZXMIN,ZYMIN,ZXMAX,ZYMAX,IFAIL) *----------------------------------------------------------------------- * ZROCNT - Determines the number of zeros in the rectangle (ZXMIN, * ZYMIN) to (ZXMAX,ZYMAX), counting the rotation of (Ex,Ey). * Variables : DATOT : Total change in argument. * DA : Change in argument over the last step. * DP : Stepsize along the border of the area. * P : Current point on the border. *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. +SEQ,CELLDATA. +SEQ,ZERODATA. LOGICAL OK,INWIRE *** Define statement functions. ARGMOD(ARG1,ARG2)=(ARG1-ARG2)-AINT(2.0*(ARG1-ARG2)) C PRINT*,' NZ ?' C READ*,ZROCNT C IFAIL=0 C RETURN *** Initialise several variables. DATOT=0.0 OK =.FALSE. P =0.0 DP =0.1 JWARN=0 *** Count the zeros. 10 CONTINUE ARG2=ZROARG(P,ZXMIN,ZYMIN,ZXMAX,ZYMAX,INWIRE) IF(.NOT.INWIRE)THEN IF(OK)THEN DA=ARGMOD(ARG1,ARG2) IF(ABS(DA).GT.DAMAX)THEN DP=DP/2.0 P=P-DP IF(DP.GT.DPMIN)GOTO 10 JWARN=JWARN+1 DP=DP*2.0 ELSEIF(ABS(DA).LT.DAMIN)THEN DP=DP*2.0 ENDIF DP=MIN(DP,DPMAX) DATOT=DATOT+DA ELSE ARG0=ARG2 OK=.TRUE. ENDIF ARG1=ARG2 ARG3=ARG2 ENDIF P=P+DP IF(P.LE.4.0)GOTO 10 IF(OK)DATOT=DATOT+ARGMOD(ARG3,ARG0) *** Count the number of wires in the rectangle. DO 20 I=1,NWIRE IF(X(I).GT.ZXMIN.AND.X(I).LE.ZXMAX.AND. - Y(I).GT.ZYMIN.AND.Y(I).LE.ZYMAX)DATOT=DATOT+1.0 20 CONTINUE *** And set the number of zeros. ZROCNT=INT(DATOT+0.5) *** Check that OK is true and that JWARN is 0. IFAIL=0 IF(.NOT.OK)IFAIL=1 IF(JWARN.NE.0)PRINT *,' !!!!!! ZROCNT WARNING : Step size ', - JWARN,' times too small; possibly incorrect zero count' IF(LDEBUG)WRITE(*,'(26X,''Change in argument='',F10.3, - '', number of zeros='',I3)') DATOT,ZROCNT END +DECK,ZROLOC. SUBROUTINE ZROLOC(XMIN,YMIN,ZXMIN,ZYMIN,ZXMAX,ZYMAX,IFAIL) *----------------------------------------------------------------------- * ZROLOC - Subroutine which tries to locate a zero accurately given * a search area. It starts picking points at random, then it * continues with the rank 2 Broyden, Fletcher, Goldfarb and * Shanno procedure. By changing the ZGAMMA and ZTHETA parms, * the DFP method (eg) can be obtained. This routine gives * reasonable results for analytic functions only. * VARIABLES : (XMIN,YMIN) : Position of the zero. * (Last changed on 4/ 4/95.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,ZERODATA. +SEQ,PRINTPLOT. REAL H(2,2),HNEW(2,2),P(2),Q(2) *** Preset some parameters. IFAIL=0 *** Perform a random search to find a suitable starting point. EOLD=0.0 DO 300 I=1,100 XRNDM=ZXMIN+(ZXMAX-ZXMIN)*RNDM(I+1) YRNDM=ZYMIN+(ZYMAX-ZYMIN)*RNDM(I-1) CALL EFIELD(XRNDM,YRNDM,0.0,EX,EY,EZ,ERNDM,VOLT,0,ILOC) NFC=NFC+1 IF(ERNDM.NE.0.0.AND.(INIT.EQ.0.OR.ERNDM.LT.EOLD))THEN XOLD=XRNDM YOLD=YRNDM EOLD=ERNDM INIT=1 ENDIF 300 CONTINUE * Warn if no starting point has been found IF(INIT.EQ.0)THEN PRINT *,' !!!!!! ZROLOC WARNING : Unable to find a suitable', - ' random starting point' IFAIL=1 RETURN ENDIF IF(LDEBUG)WRITE(*,'(/26X,''Search start '',2F11.4, - '' (Etot='',E10.3,'').''/)') XOLD,YOLD,EOLD *** Preset the matrix H to a surely pos. def. unity. H(1,1)=1.0 H(1,2)=0.0 H(2,1)=0.0 H(2,2)=1.0 *** Calculate the gradient of the function at the starting point. CALL EFIELD(XOLD+1.0E-4*(ABS(XOLD)+1.0),YOLD,0.0, - EX,EY,EZ,ETOTX1,VOLT,0,ILOC) CALL EFIELD(XOLD-1.0E-4*(ABS(XOLD)+1.0),YOLD,0.0, - EX,EY,EZ,ETOTX2,VOLT,0,ILOC) CALL EFIELD(XOLD,YOLD+1.0E-4*(ABS(YOLD)+1.0),0.0, - EX,EY,EZ,ETOTY1,VOLT,0,ILOC) CALL EFIELD(XOLD,YOLD-1.0E-4*(ABS(YOLD)+1.0),0.0, - EX,EY,EZ,ETOTY2,VOLT,0,ILOC) NFC=NFC+4 G1=(ETOTX1-ETOTX2)/(2.0E-4*(ABS(XOLD)+1.0)) G2=(ETOTY1-ETOTY2)/(2.0E-4*(ABS(YOLD)+1.0)) IF(G1.EQ.0.0.AND.G2.EQ.0.0)THEN IF(LDEBUG)WRITE(*,'(26X,''Starting point is stationary.'')') XNEW=XOLD YNEW=YOLD ENEW=EOLD GOTO 500 ENDIF *** Begin of the Newton-like search loop. NSTEPS=0 310 CONTINUE NSTEPS=NSTEPS+1 * Set a suitable direction for the linear minimisation. S1=H(1,1)*G1+H(1,2)*G2 S2=H(2,1)*G1+H(2,2)*G2 IF(LDEBUG)WRITE(*,'(26X,''Search direction: '',2F11.4)') -S1,-S2 ** Perform a linear minimisation, first check length of direction, IF(S1**2+S2**2.EQ.0.0)THEN IF(LDEBUG)WRITE(*,'(26X,''The step size is zero,'', - '' search aborted in step '',I2,''.''/)') NSTEPS IFAIL=1 XNEW=XOLD YNEW=YOLD ENEW=EOLD GOTO 500 ENDIF * copy current estimate to the variables used for linear minimisation, XLIN=XOLD YLIN=YOLD ELIN=EOLD * calculate in the neigbourhood of the present best point, EPS=0.1*(1.0+SQRT(XLIN**2+YLIN**2))/(S1**2+S2**2) CALL EFIELD (XLIN+EPS*S1,YLIN+EPS*S2,0.0, - EX,EY,EZ,ELINP,VOLT,0,ILOC) CALL EFIELD (XLIN-EPS*S1,YLIN-EPS*S2,0.0, - EX,EY,EZ,ELINM,VOLT,0,ILOC) NFC=NFC+2 * find a rough estimate for a minimum, IF(ELINP+ELINM-2*ELIN.LE.0)THEN IF(LDEBUG)WRITE(*,'(26X,''Second derivative is zero, no'', - '' second order guess can be done.'')') IF(ELINP.EQ.ELINM)THEN IF(LDEBUG)WRITE(*,'(26X,''First derivative is also 0'', - '' minimum assumed.'')') GOTO 450 ENDIF IF(LDEBUG)WRITE(*,'(26X,''A linear guess is attempted.'')') XLIN1=XLIN-S1*ELIN*EPS/(ELINP-ELINM) YLIN1=YLIN-S2*ELIN*EPS/(ELINP-ELINM) ELSE XLIN1=XLIN-S1*(EPS/2)*(ELINP-ELINM)/(ELINP-2*ELIN+ELINM) YLIN1=YLIN-S2*(EPS/2)*(ELINP-ELINM)/(ELINP-2*ELIN+ELINM) ENDIF IF(LDEBUG)WRITE(*,'(26X,''Rough estimate is ('',E10.3,'','', - E10.3,'').'')') XLIN1,YLIN1 * make sure this point has indeed a amaller E than (XLIN,YLIN), NLIN=0 400 CONTINUE NLIN=NLIN+1 IF(NLIN.GT.5)THEN IF(LDEBUG)WRITE(*,'(26X,''Maximum number of'', - '' contractions exceeded.'')') GOTO 450 ENDIF CALL EFIELD(XLIN1,YLIN1,0.0,EX,EY,EZ,ELIN1,VOLT,0,ILOC) PRINT *,' ELIN1=',ELIN1 NFC=NFC+1 IF(ELIN1.GT.ELIN)THEN XLIN1=(XLIN+XLIN1)/2 YLIN1=(YLIN+YLIN1)/2 GOTO 400 ENDIF IF(LDEBUG.AND.NLIN.GT.1)WRITE(*,'(26X,''Rough estimate'', - '' corrected '',I2,'' times.'')') NLIN * next set a point 'behind' the minimum, NLIN=0 410 CONTINUE NLIN=NLIN+1 IF(NLIN.GT.5)THEN IF(LDEBUG)WRITE(*,'(26X,''Maximum number of'', - '' expansions exceeded.'')') GOTO 440 ENDIF XLIN2=2*XLIN1-XLIN YLIN2=2*YLIN1-YLIN CALL EFIELD(XLIN2,YLIN2,0.0,EX,EY,EZ,ELIN2,VOLT,0,ILOC) PRINT *,' ELIN2=',ELIN2 NFC=NFC+1 IF(ELIN2.LT.ELIN1)THEN XLIN1=XLIN2 YLIN1=YLIN2 ELIN1=ELIN2 GOTO 410 ENDIF IF(LDEBUG.AND.NLIN.GT.1)WRITE(*,'(26X,''Over shoot point has'', - '' been corrected '',I2,'' times.'')') NLIN * perform a parabolic minimisation: first find improved minimum, NPAR=0 420 CONTINUE NPAR=NPAR+1 IF(NPAR.GT.5)THEN IF(LDEBUG)WRITE(*,'(26X,''Maximum number of'', - '' parabolic loops exceeded.'')') XLIN=XPAR YLIN=YPAR ELIN=EPAR GOTO 450 ENDIF C1=SQRT((XLIN1-XLIN)**2+(YLIN2-YLIN)**2) C2=SQRT((XLIN2-XLIN)**2+(YLIN2-YLIN)**2) CPAR=0.5*((C1**2-C2**2)*ELIN+C2**2*ELIN1-C1**2*ELIN2)/ - ((C1-C2)*ELIN+C2*ELIN1-C1*ELIN2) XPAR=XLIN+(XLIN2-XLIN)*(CPAR/C2) YPAR=YLIN+(YLIN2-YLIN)*(CPAR/C2) CALL EFIELD(XPAR,YPAR,0.0,EX,EY,EZ,EPAR,VOLT,0,ILOC) NFC=NFC+1 IF(EPAR.GT.ELIN1)THEN IF(LDEBUG)WRITE(*,'(26X,''Parabolic minimum exceeds'', - '' current minimum.'')') XLIN=XLIN1 YLIN=YLIN1 ELIN=ELIN1 GOTO 450 ENDIF * check convergence criteria IF(ABS(EPAR-ELIN1).LT.1.0E-3*ELIN1.OR.EPAR.LT.EMIN)THEN IF(LDEBUG)WRITE(*,'(26X,''Convergence criteria satisfied'', - '' after '',I2,'' parabolic loops.'')') NPAR XLIN=XPAR YLIN=YPAR ELIN=EPAR GOTO 450 ENDIF * shift the data points and perform a new parabolic minimastion, IF(CPAR.LT.C1)THEN XLIN=XLIN1 YLIN=YLIN1 ELIN=ELIN1 ELSE XLIN2=XLIN1 YLIN2=YLIN1 ELIN2=ELIN1 ENDIF XLIN1=XPAR YLIN1=YPAR ELIN1=EPAR GOTO 420 * no convergence: abort the search loop and jump to the end, 440 CONTINUE IF(LDEBUG)WRITE(*,'(26X,''The linear search did not converge,'', - '' search aborted.''/)') IFAIL=1 XNEW=XLIN YNEW=YLIN ENEW=ELIN GOTO 500 * end of linear search loop. 450 CONTINUE * make sure the new point is in the right direction. IF(S1*(XLIN-XOLD).LE.0.0.AND.S2*(YLIN-YOLD).LE.0.0)THEN XNEW=XLIN YNEW=YLIN ENEW=ELIN ELSE IF(LDEBUG)WRITE(*,'(26X,''The result of the linear'', - '' minimisation is not accepted''/29X,''because'', - '' CFAC is negative. CFAC is replaced by 1.'')') XNEW=XOLD-S1 YNEW=YOLD-S2 CALL EFIELD(XNEW,YNEW,0.0,EX,EY,EZ,ENEW,VOLT,0,ILOC) NFC=NFC+1 ENDIF IF(LDEBUG)WRITE(*,'(26X,''New estimate '',2F11.4,'' (Etot='', - E10.3,'').''/)') XNEW,YNEW,ENEW ** Before proceeding further, check whether we are satisfied. IF(ABS(EOLD-ENEW).LT.1.0E-4*(ABS(EOLD)+ABS(ENEW)))THEN IF(LDEBUG)WRITE(*,'(26X,''Change in E stop criterion'', - '' is satisfied in loop '',I2,''.'')') NSTEPS GOTO 500 ENDIF IF(ABS(XOLD-XNEW)*1.0E4.LT.ABS(XOLD)+ABS(XNEW).AND. - ABS(YOLD-YNEW)*1.0E4.LT.ABS(YOLD)+ABS(YNEW))THEN IF(LDEBUG)WRITE(*,'(26X,''Position change stop criterion'', - '' is satisfied in loop '',I2,''.'')') NSTEPS GOTO 500 ENDIF IF(ENEW.LT.EMIN)THEN IF(LDEBUG)WRITE(*,'(26X,''Absolute value of E criterion'', - '' is satisfied in loop '',I2,''.'')') NSTEPS GOTO 500 ENDIF ** Update H, calculate the gradient of the function at (XNEW,YNEW), CALL EFIELD(XNEW+1.0E-4*(ABS(XNEW)+1.0),YNEW,0.0, - EX,EY,EZ,ETOTX1,VOLT,0,ILOC) CALL EFIELD(XNEW-1.0E-4*(ABS(XNEW)+1.0),YNEW,0.0, - EX,EY,EZ,ETOTX2,VOLT,0,ILOC) CALL EFIELD(XNEW,YNEW+1.0E-4*(ABS(YNEW)+1.0),0.0, - EX,EY,EZ,ETOTY1,VOLT,0,ILOC) CALL EFIELD(XNEW,YNEW-1.0E-4*(ABS(YNEW)+1.0),0.0, - EX,EY,EZ,ETOTY2,VOLT,0,ILOC) NFC=NFC+4 G1NEW=(ETOTX1-ETOTX2)/(2.0E-4*(ABS(XNEW)+1.0)) G2NEW=(ETOTY1-ETOTY2)/(2.0E-4*(ABS(YNEW)+1.0)) IF(G1NEW.EQ.0.0.AND.G2NEW.EQ.0.0)THEN IF(LDEBUG)WRITE(*,'(26X,''Truly stationary point found in'', - '' step '',I2,''.'')') NSTEPS GOTO 500 ENDIF * prepare some auxiliary variables, P(1)=XNEW-XOLD P(2)=YNEW-YOLD Q(1)=G1NEW-G1 Q(2)=G2NEW-G2 PQ=P(1)*Q(1)+P(2)*Q(2) QHQ=Q(1)*(H(1,1)*Q(1)+H(1,2)*Q(2))+Q(2)*(H(2,1)*Q(1)+H(2,2)*Q(2)) * select ZGAMMA and ZTHETA ZGAMMA=1 ZTHETA=1 * the update itself. DO 360 K=1,2 DO 350 L=1,2 HNEW(K,L)=ZGAMMA*H(K,L)+ - (1+ZGAMMA*ZTHETA*QHQ/PQ)*P(K)*P(L)/PQ- - ZGAMMA*(1-ZTHETA)*(H(K,1)*Q(1)+H(K,2)*Q(2))* - (Q(1)*H(1,L)+Q(2)*H(2,L))/QHQ- - ZGAMMA*ZTHETA*(P(K)*Q(1)*H(1,L)+P(K)*Q(2)*H(2,L)+ - H(K,1)*Q(1)*P(L)+H(K,2)*Q(2)*P(L))/PQ 350 CONTINUE 360 CONTINUE ** Transfer variables from old to new storage places. DO 380 K=1,2 DO 370 L=1,2 H(K,L)=HNEW(K,L) 370 CONTINUE 380 CONTINUE G1=G1NEW G2=G2NEW XOLD=XNEW YOLD=YNEW EOLD=ENEW GOTO 310 *** Final printing and checking of the results. 500 CONTINUE * Check whether the point lies in the area. IF(XNEW.LT.ZXMIN.OR.XNEW.GT.ZXMAX.OR. - YMIN.LT.ZYMIN.OR.YNEW.GT.ZYMAX)THEN IF(LDEBUG)WRITE(*,'(26X,''The minimum lies outside the'', - '' area.'')') IFAIL=1 * Perhaps the point lies in the area, has E < EMIN but IFAIL=1. ELSEIF(IFAIL.NE.0.AND.ENEW.LT.EMIN)THEN IF(LDEBUG)WRITE(*,'(/26X,''Inspite of the failure'', - '' the result is E-acceptable.'')') IFAIL=0 ENDIF * Print the end result. IF(LDEBUG)WRITE(*,'(26X,''Final (X,Y) '',2F11.4,'' (Etot='', - E10.3,'').''/26X,''IFAIL for the whole search '',I2,''.'')') - XNEW,YNEW,ENEW,IFAIL *** Make sure the result is stored in the proper place. XMIN=XNEW YMIN=YNEW END +DECK,ZROARG. FUNCTION ZROARG(P,ZXMIN,ZYMIN,ZXMAX,ZYMAX,INWIRE) +SEQ,DIMENSIONS. +SEQ,ZERODATA. +SEQ,CONSTANTS. LOGICAL INWIRE *** Find the coordinates corresponding with P. IF(P.GE.0.0.AND.P.LE.1.0)THEN X=ZXMIN+ P *(ZXMAX-ZXMIN) Y=ZYMIN ELSEIF(P.GT.1.0.AND.P.LE.2.0)THEN X=ZXMAX Y=ZYMIN+(P-1.0)*(ZYMAX-ZYMIN) ELSEIF(P.GT.2.0.AND.P.LE.3.0)THEN X=ZXMAX-(P-2.0)*(ZXMAX-ZXMIN) Y=ZYMAX ELSEIF(P.GT.3.0.AND.P.LE.4.0)THEN X=ZXMIN Y=ZYMAX-(P-3.0)*(ZYMAX-ZYMIN) ELSE ZROARG=0.0 INWIRE=.TRUE. PRINT *,' ###### ZROARG ERROR : Argument P out of range', - ' (program bug); probably no serious effect.' RETURN ENDIF *** Calculate the field at (X,Y) and set inwire. INWIRE=.FALSE. CALL EFIELD(X,Y,0.0,EX,EY,EZ,ETOT,VOLT,0,ILOC) NFC=NFC+1 IF(ILOC.NE.0)THEN ZROARG=0.0 INWIRE=.TRUE. PRINT 1010,P,X,Y RETURN ENDIF *** Compute the argument. ZROARG=ACOS(EX/ETOT)/(2.0*PI) IF(EY.LT.0)ZROARG=1.0-ZROARG PRINT 1010,P,X,Y,ZROARG 1010 FORMAT(' P=',F10.3,' (X,Y)=',2F10.3:' ARG=',F10.3) END +PATCH,FIELDCAL. +DECK,SETUP. SUBROUTINE SETUP(IFAIL) *----------------------------------------------------------------------- * SETUP - Routine calling the appropriate setup routine. * (Last changed on 30/ 1/93.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,PRINTPLOT. *** Try to obtain the storage used for the capacitance matrix. CALL BOOK('BOOK','MATRIX','CELL',IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! SETUP WARNING : Unable to allocate'// - ' storage for the capacitance matrix; no charges.' IF(LDEBUG)CALL BOOK('LIST',' ',' ',IFAIL1) RETURN ENDIF *** Set a separate set of plane variables to avoid repeated loops. IF(YNPLAN(1))THEN COPLAX=COPLAN(1) YNPLAX=.TRUE. ELSEIF(YNPLAN(2))THEN COPLAX=COPLAN(2) YNPLAX=.TRUE. ELSE YNPLAX=.FALSE. ENDIF IF(YNPLAN(3))THEN COPLAY=COPLAN(3) YNPLAY=.TRUE. ELSEIF(YNPLAN(4))THEN COPLAY=COPLAN(4) YNPLAY=.TRUE. ELSE YNPLAY=.FALSE. ENDIF *** Set the correction parameters for the planes. IF(TUBE)THEN CORVTA=0.0 CORVTB=0.0 CORVTC=VTTUBE ELSEIF((YNPLAN(1).AND.YNPLAN(2)).AND. - .NOT.(YNPLAN(3).OR.YNPLAN(4)))THEN CORVTA=(VTPLAN(1)-VTPLAN(2))/(COPLAN(1)-COPLAN(2)) CORVTB=0.0 CORVTC=(VTPLAN(2)*COPLAN(1)-VTPLAN(1)*COPLAN(2))/ - (COPLAN(1)-COPLAN(2)) ELSEIF((YNPLAN(3).AND.YNPLAN(4)).AND. - .NOT.(YNPLAN(1).OR.YNPLAN(2)))THEN CORVTA=0.0 CORVTB=(VTPLAN(3)-VTPLAN(4))/(COPLAN(3)-COPLAN(4)) CORVTC=(VTPLAN(4)*COPLAN(3)-VTPLAN(3)*COPLAN(4))/ - (COPLAN(3)-COPLAN(4)) ELSE CORVTA=0 CORVTB=0 CORVTC=0 IF(YNPLAN(1))CORVTC=VTPLAN(1) IF(YNPLAN(2))CORVTC=VTPLAN(2) IF(YNPLAN(3))CORVTC=VTPLAN(3) IF(YNPLAN(4))CORVTC=VTPLAN(4) ENDIF *** Skip wire calculations if there aren't any. IF(NWIRE.LE.0)GOTO 10 *** Call the set routine appropriate for the present cell type. IF(TYPE.EQ.'A '.AND.NXMATT.EQ.0.AND.NYMATT.EQ.0)THEN CALL SETA00(IFAIL) ELSEIF(TYPE.EQ.'A ')THEN CALL EFQA00(IFAIL) ENDIF IF(TYPE.EQ.'B1X')CALL SETB1X(IFAIL) IF(TYPE.EQ.'B1Y')CALL SETB1Y(IFAIL) IF(TYPE.EQ.'B2X')CALL SETB2X(IFAIL) IF(TYPE.EQ.'B2Y')CALL SETB2Y(IFAIL) IF(TYPE.EQ.'C1 ')CALL SETC10(IFAIL) IF(TYPE.EQ.'C2X')CALL SETC2X(IFAIL) IF(TYPE.EQ.'C2Y')CALL SETC2Y(IFAIL) IF(TYPE.EQ.'C3 ')CALL SETC30(IFAIL) IF(TYPE.EQ.'D1 ')CALL SETD10(IFAIL) IF(TYPE.EQ.'D2 ')CALL SETD20(IFAIL) IF(TYPE.EQ.'D3 ')CALL SETD30(IFAIL) C IF(TYPE.EQ.'D4 ')CALL SETD40(IFAIL) *** Check the error condition. IF(IFAIL.EQ.1)PRINT *,' ###### SETUP ERROR : Preparing the'// - ' the cell for field calculations did not succeed.' 10 CONTINUE *** Release the capacitance matrix. CALL BOOK('RELEASE','MATRIX','CELL',IFAIL1) *** Register the amount of CPU time used. CALL TIMLOG('Calculating the wire charges: ') END +DECK,SETNEW. SUBROUTINE SETNEW(VNEW,VPLNEW,IFAIL) *----------------------------------------------------------------------- * SETNEW - Calculates charges when the potentials have changed. * (Last changed on 20/10/99.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,CAPACMATRIX. +SEQ,PRINTPLOT. REAL VNEW(MXWIRE),VPLNEW(5) INTEGER IFAIL,IFAIL1,I,J CHARACTER*10 USER *** Identify the routine, if requested. IF(LIDENT)PRINT *,' /// ROUTINE SETNEW ///' *** Assume the routine will be successful. IFAIL=0 *** Figure out whether the capacitance matrix is still available. CALL BOOK('INQUIRE','MATRIX',USER,IFAIL1) IF(USER.NE.'CELL ')THEN IF(LDEBUG)PRINT *,' ++++++ SETNEW DEBUG : Recalculating'// - ' the capacitance matrix.' CALL SETUP(IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' ###### SETNEW ERROR : Error computing'// - ' the charges; further cell computations useless.' NWIRE=0 RETURN ENDIF ELSEIF(LDEBUG)THEN PRINT *,' ++++++ SETNEW DEBUG : Capacitance'// - ' matrix still available.' ENDIF *** Set the correction parameters for the planes. IF(TUBE)THEN CORVTA=0.0 CORVTB=0.0 CORVTC=VPLNEW(5) ELSEIF((YNPLAN(1).AND.YNPLAN(2)).AND. - .NOT.(YNPLAN(3).OR.YNPLAN(4)))THEN CORVTA=(VPLNEW(1)-VPLNEW(2))/(COPLAN(1)-COPLAN(2)) CORVTB=0.0 CORVTC=(VPLNEW(2)*COPLAN(1)-VPLNEW(1)*COPLAN(2))/ - (COPLAN(1)-COPLAN(2)) ELSEIF((YNPLAN(3).AND.YNPLAN(4)).AND. - .NOT.(YNPLAN(1).OR.YNPLAN(2)))THEN CORVTA=0.0 CORVTB=(VPLNEW(3)-VPLNEW(4))/(COPLAN(3)-COPLAN(4)) CORVTC=(VPLNEW(4)*COPLAN(3)-VPLNEW(3)*COPLAN(4))/ - (COPLAN(3)-COPLAN(4)) ELSE CORVTA=0 CORVTB=0 CORVTC=0 IF(YNPLAN(1))CORVTC=VPLNEW(1) IF(YNPLAN(2))CORVTC=VPLNEW(2) IF(YNPLAN(3))CORVTC=VPLNEW(3) IF(YNPLAN(4))CORVTC=VPLNEW(4) ENDIF +SELF,IF=VECTOR,IF=ESSL. *** Transfer the voltages to A, correcting for the equipotential planes. DO 10 I=1,NWIRE A(I,MXWIRE+3)=VNEW(I)-(CORVTA*X(I)+CORVTB*Y(I)+CORVTC) 10 CONTINUE +SELF. *** Handle the case when the sum of the charges is zero autmatically. IF(YNPLAN(1).OR.YNPLAN(2).OR.YNPLAN(3).OR.YNPLAN(4))THEN +SELF,IF=VECTOR,IF=ESSL. CALL DGES(A,MXWIRE+1,NWIRE,A(1,MXWIRE+2),A(1,MXWIRE+3),0) +SELF. V0=0.0 *** Force sum charges =0 in case of absence of equipotential planes. ELSE +SELF,IF=VECTOR,IF=ESSL. A(NWIRE+1,MXWIRE+3)=0.0 CALL DGES(A,MXWIRE+1,NWIRE+1,A(1,MXWIRE+2),A(1,MXWIRE+3),0) V0=A(NWIRE+1,MXWIRE+3) +SELF,IF=-VECTOR,-ESSL. V0=0 DO 40 I=1,NWIRE V0=V0+A(NWIRE+1,I)*VNEW(I) 40 CONTINUE +SELF. ENDIF +SELF,IF=VECTOR,IF=ESSL. *** Copy the charges to E. DO 50 I=1,NWIRE E(I)=A(I,MXWIRE+3) 50 CONTINUE +SELF,IF=-VECTOR,-ESSL. *** Next reconstruct the charges. DO 30 I=1,NWIRE E(I)=0 DO 20 J=1,NWIRE E(I)=E(I)+A(I,J)*(VNEW(J)-V0-(CORVTA*X(J)+CORVTB*Y(J)+CORVTC)) 20 CONTINUE 30 CONTINUE +SELF. *** Replace the potentials. DO 60 I=1,NWIRE V(I)=VNEW(I) 60 CONTINUE DO 70 I=1,4 VTPLAN(I)=VPLNEW(I) 70 CONTINUE VTTUBE=VPLNEW(5) END +DECK,SETA00. SUBROUTINE SETA00(IFAIL) *----------------------------------------------------------------------- * SETA00 - Subroutine preparing the field calculations by calculating * the charges on the wires, for the cell with one charge and * not more than one plane in either x or y. * The potential used is log(r). * Variables : No local variables. *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,CAPACMATRIX. *** Loop over all wire combinations. DO 10 I=1,NWIRE A(I,I)=0.25*D(I)**2 *** Take care of the equipotential planes. IF(YNPLAX)A(I,I)=A(I,I)/(2.0*(X(I)-COPLAX))**2 IF(YNPLAY)A(I,I)=A(I,I)/(2.0*(Y(I)-COPLAY))**2 *** Take care of combinations of equipotential planes. IF(YNPLAX.AND.YNPLAY)A(I,I)=4.0*A(I,I)*((X(I)-COPLAX)**2 - +(Y(I)-COPLAY)**2) *** Define the final version of A(I,I). A(I,I)=-0.5*LOG(A(I,I)) *** Loop over all other wires for the off-diagonal elements. DO 20 J=I+1,NWIRE A(I,J)=(X(I)-X(J))**2+(Y(I)-Y(J))**2 *** Take care of equipotential planes. IF(YNPLAX)A(I,J)=A(I,J)/((X(I)+X(J)-2.*COPLAX)**2+(Y(I)-Y(J))**2) IF(YNPLAY)A(I,J)=A(I,J)/((X(I)-X(J))**2+(Y(I)+Y(J)-2.*COPLAY)**2) *** Take care of pairs of equipotential planes in different directions. IF(YNPLAX.AND.YNPLAY)A(I,J)= - A(I,J)*((X(I)+X(J)-2.*COPLAX)**2+(Y(I)+Y(J)-2.*COPLAY)**2) *** Define a final version of A(I,J). A(I,J)=-0.5*LOG(A(I,J)) *** Copy this to A(J,I) since the capacitance matrix is symmetric. A(J,I)=A(I,J) 20 CONTINUE 10 CONTINUE *** Call CHARGE to calculate the charges really. CALL CHARGE(IFAIL) END +DECK,SETB1X. SUBROUTINE SETB1X(IFAIL) *----------------------------------------------------------------------- * SETB1X - Routine preparing the field calculations by filling the * c-matrix, the potential used is re(log(sin pi/s (z-z0))). * VARIABLES : XX : Difference in x of two wires * factor. * YY : Difference in y of two wires * factor. * YYMIRR : Difference in y of one wire and the mirror * image of another * factor. * R2PLAN : Periodic length of (XX,YYMIRR) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,CONSTANTS. +SEQ,CAPACMATRIX. *** Loop over all wires and calculate the diagonal elements first. DO 10 I=1,NWIRE A(I,I)=-LOG(0.5*D(I)*PI/SX) *** Take care of a plane at constant y if it exist. IF(YNPLAY)THEN YY=(PI/SX)*2.0*(Y(I)-COPLAY) IF(ABS(YY).GT.20.0)A(I,I)=A(I,I)+ABS(YY)-CLOG2 IF(ABS(YY).LE.20.0)A(I,I)=A(I,I)+LOG(ABS(SINH(YY))) ENDIF *** Loop over all other wires to obtain off-diagonal elements. DO 20 J=I+1,NWIRE XX=(PI/SX)*(X(I)-X(J)) YY=(PI/SX)*(Y(I)-Y(J)) IF(ABS(YY).GT.20.0)A(I,J)=-ABS(YY)+CLOG2 IF(ABS(YY).LE.20.0)A(I,J)=-0.5*LOG(SINH(YY)**2+SIN(XX)**2) *** Take equipotential planes into account if they exist. IF(YNPLAY)THEN YYMIRR=(PI/SX)*(Y(I)+Y(J)-2.0*COPLAY) IF(ABS(YYMIRR).GT.20.0)R2PLAN=ABS(YYMIRR)-CLOG2 IF(ABS(YYMIRR).LE.20.0) - R2PLAN=0.5*LOG(SINH(YYMIRR)**2+SIN(XX)**2) A(I,J)=A(I,J)+R2PLAN ENDIF *** Copy A(I,J) to A(J,I), the capactance matrix is symmetric. A(J,I)=A(I,J) *** Finish the wire loops. 20 CONTINUE 10 CONTINUE *** Call routine CHARGE calculating all kinds of useful things. CALL CHARGE(IFAIL) END +DECK,SETB1Y. SUBROUTINE SETB1Y(IFAIL) *----------------------------------------------------------------------- * SETB1Y - Routine preparing the field calculations by setting the * charges. The potential used is Re log(sinh pi/sy(z-z0)). * VARIABLES : YY : Difference in y of two wires * factor. * XXMIRR : Difference in x of one wire and the mirror * image of another * factor. * R2PLAN : Periodic length of (XXMIRR,YY). *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,CONSTANTS. +SEQ,CAPACMATRIX. *** Loop over all wires and calculate the diagonal elements first. DO 10 I=1,NWIRE A(I,I)=-LOG(0.5*D(I)*PI/SY) *** Take care of planes 1 and 2 if present. IF(YNPLAX)THEN XX=(PI/SY)*2.0*(X(I)-COPLAX) IF(ABS(XX).GT.20.0)A(I,I)=A(I,I)+ABS(XX)-CLOG2 IF(ABS(XX).LE.20.0)A(I,I)=A(I,I)+LOG(ABS(SINH(XX))) ENDIF *** Loop over all other wires to obtain off-diagonal elements. DO 20 J=I+1,NWIRE XX=(PI/SY)*(X(I)-X(J)) YY=(PI/SY)*(Y(I)-Y(J)) IF(ABS(XX).GT.20.0)A(I,J)=-ABS(XX)+CLOG2 IF(ABS(XX).LE.20.0)A(I,J)=-0.5*LOG(SINH(XX)**2+SIN(YY)**2) *** Take care of a plane at constant x. IF(YNPLAX)THEN XXMIRR=(PI/SY)*(X(I)+X(J)-2.0*COPLAX) IF(ABS(XXMIRR).GT.20.0)R2PLAN=ABS(XXMIRR)-CLOG2 IF(ABS(XXMIRR).LE.20.0) - R2PLAN=0.5*LOG(SINH(XXMIRR)**2+SIN(YY)**2) A(I,J)=A(I,J)+R2PLAN ENDIF *** Copy A(I,J) to A(J,I), the capacitance matrix is symmetric. A(J,I)=A(I,J) *** Finish the wire loops. 20 CONTINUE 10 CONTINUE *** Call routine CHARGE calculating all kinds of useful things. CALL CHARGE(IFAIL) END +DECK,SETB2X. SUBROUTINE SETB2X(IFAIL) *----------------------------------------------------------------------- * SETB2X - Routine preparing the field calculations by setting the * charges. * VARIABLES : XX : Difference in x of two wires * factor. * YY : Difference in y of two wires * factor. * XXNEG : Difference in x of one wire and the mirror * image in period direction of another * fac. * YYMIRR : Difference in y of one wire and the mirror * image of another * factor. *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,CONSTANTS. +SEQ,CAPACMATRIX. *** Loop over all wires and calculate the diagonal elements first. DO 10 I=1,NWIRE XX=(PI/SX)*(X(I)-COPLAX) A(I,I)=(0.25*D(I)*PI/SX)/SIN(XX) *** Take care of a plane at constant y if it exists. IF(YNPLAY)THEN YYMIRR=(PI/SX)*(Y(I)-COPLAY) IF(ABS(YYMIRR).LE.20.0) A(I,I)=A(I,I)* - SQRT(SINH(YYMIRR)**2+SIN(XX)**2)/SINH(YYMIRR) ENDIF *** Store the true value of A(I,I). A(I,I)=-LOG(ABS(A(I,I))) *** Loop over all other wires to obtain off-diagonal elements. DO 20 J=I+1,NWIRE XX=0.5*PI*(X(I)-X(J))/SX YY=0.5*PI*(Y(I)-Y(J))/SX XXNEG=0.5*PI*(X(I)+X(J)-2.0*COPLAX)/SX IF(ABS(YY).LE.20.0) - A(I,J)=(SINH(YY)**2+SIN(XX)**2)/(SINH(YY)**2+SIN(XXNEG)**2) IF(ABS(YY).GT.20.0)A(I,J)=1.0 *** Take an equipotential plane at constant y into account. IF(YNPLAY)THEN YYMIRR=0.5*PI*(Y(I)+Y(J)-2.0*COPLAY)/SX IF(ABS(YYMIRR).LE.20.0) A(I,J)=A(I,J)* - (SINH(YYMIRR)**2+SIN(XXNEG)**2)/(SINH(YYMIRR)**2+SIN(XX)**2) ENDIF *** Store the true value of A(I,J) in both A(I,J) and A(J,I). A(I,J)=-0.5*LOG(A(I,J)) A(J,I)=A(I,J) *** Finish the wire loops. 20 CONTINUE *** Set the B2SIN vector. B2SIN(I)=SIN(PI*(COPLAX-X(I))/SX) 10 CONTINUE *** Call routine CHARGE calculating all kinds of useful things. CALL CHARGE(IFAIL) END +DECK,SETB2Y. SUBROUTINE SETB2Y(IFAIL) *----------------------------------------------------------------------- * SETB2Y - Routine preparing the field calculations by setting the * charges. * VARIABLES : XX : Difference in x of two wires * factor. * YY : Difference in y of two wires * factor. * XXMIRR : Difference in x of one wire and the mirror * image of another * factor. * YYNEG : Difference in y of one wire and the mirror * image in period direction of another * fac. *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,CONSTANTS. +SEQ,CAPACMATRIX. *** Loop over all wires and calculate the diagonal elements first. DO 10 I=1,NWIRE YY=(PI/SY)*(Y(I)-COPLAY) A(I,I)=(0.25*D(I)*PI/SY)/SIN(YY) *** Take care of a plane at constant x if present. IF(YNPLAX)THEN XXMIRR=(PI/SY)*(X(I)-COPLAX) IF(ABS(XXMIRR).LE.20.0)A(I,I)=A(I,I)* - SQRT(SINH(XXMIRR)**2+SIN(YY)**2)/SINH(XXMIRR) ENDIF *** Store the true value of A(I,I). A(I,I)=-LOG(ABS(A(I,I))) *** Loop over all other wires to obtain off-diagonal elements. DO 20 J=I+1,NWIRE XX=0.5*PI*(X(I)-X(J))/SY YY=0.5*PI*(Y(I)-Y(J))/SY YYNEG=0.5*PI*(Y(I)+Y(J)-2.0*COPLAY)/SY IF(ABS(XX).LE.20.0) - A(I,J)=(SINH(XX)**2+SIN(YY)**2)/(SINH(XX)**2+SIN(YYNEG)**2) IF(ABS(XX).GT.20.0)A(I,J)=1.0 *** Take an equipotential plane at constant x into account. IF(YNPLAX)THEN XXMIRR=0.5*PI*(X(I)+X(J)-2.0*COPLAX)/SY IF(ABS(XXMIRR).LE.20.0)A(I,J)=A(I,J)* - (SINH(XXMIRR)**2+SIN(YYNEG)**2)/(SINH(XXMIRR)**2+SIN(YY)**2) ENDIF *** Store the true value of A(I,J) in both A(I,J) and A(J,I). A(I,J)=-0.5*LOG(A(I,J)) A(J,I)=A(I,J) *** Finish the wire loops. 20 CONTINUE *** Set the B2SIN vector. B2SIN(I)=SIN(PI*(COPLAY-Y(I))/SY) 10 CONTINUE *** Call routine CHARGE calculating all kinds of useful things. CALL CHARGE(IFAIL) END +DECK,SETC10. SUBROUTINE SETC10(IFAIL) *----------------------------------------------------------------------- * SETC10 - This initialising routine computes the wire charges E and * sets certain constants in common. The wire are located at * (X(J),Y(J))+(LX*SX,LY*SY), J=1(1)NWIRE, * LX=-infinity(1)infinity, LY=-infinity(1)infinity. * Use is made of the routine PH2. * * (Written by G.A.Erskine/DD, 14.8.1984 modified to some extent) *----------------------------------------------------------------------- IMPLICIT COMPLEX (W,Z) +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,CAPACMATRIX. +SEQ,CONSTANTS. *** Statement function returning XX if mode is 0, YY else. UTYPE(XX,YY)=(1-MODE)*XX+MODE*YY *** Set some of the constants used by PH2 and E2SUM. CONST=2.*PI/(SX*SY) IF(SX.LE.SY)THEN MODE=1 IF(SY/SX.LT.8.0)THEN P=EXP(-PI*SY/SX) ELSE P=0.0 ENDIF ZMULT=CMPLX(PI/SX,0.0) ELSE MODE=0 IF(SX/SY.LT.8.0)THEN P=EXP(-PI*SX/SY) ELSE P=0.0 ENDIF ZMULT=CMPLX(0.0,PI/SY) ENDIF P1=P**2 P2=P**6 *** Store the capacitance matrix. DO 20 I=1,NWIRE DO 10 J=1,NWIRE TEMP=CONST*UTYPE(X(I),Y(I))*UTYPE(X(J),Y(J)) IF(I.EQ.J)THEN A(I,I)=PH2LIM(0.5*D(I))-TEMP ELSE A(I,J)=PH2(X(I)-X(J),Y(I)-Y(J))-TEMP ENDIF 10 CONTINUE 20 CONTINUE *** Call CHARGE to find the charges. CALL CHARGE(IFAIL) IF(IFAIL.EQ.1)RETURN *** Calculate the non-logarithmic term in the potential. S=0.0 DO 30 J=1,NWIRE S=S+E(J)*UTYPE(X(J),Y(J)) 30 CONTINUE C1=-CONST*S END +DECK,SETC2X. SUBROUTINE SETC2X(IFAIL) *----------------------------------------------------------------------- * SETC2X - This initializing subroutine stores the capacitance matrix * for the configuration: * wires at zw(j)+cmplx(lx*2*sx,ly*sy), * j=1(1)n, lx=-infinity(1)infinity, ly=-infinity(1)infinity. * but the signs of the charges alternate in the x-direction *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,CAPACMATRIX. +SEQ,CONSTANTS. +SEQ,PRINTPLOT. *** Initialise the constants. P=0.0 P1=0.0 P2=0.0 IF(2.0*SX.LE.SY)THEN MODE=1 IF(SY/SX.LT.25.0)P=EXP(-0.5*PI*SY/SX) ZMULT=CMPLX(0.5*PI/SX,0.0) ELSE MODE=0 IF(SX/SY.LT.6.0)P=EXP(-2.0*PI*SX/SY) ZMULT=CMPLX(0.0,PI/SY) ENDIF P1=P**2 IF(P1.GT.1.0E-10)P2=P**6 *** Produce some debugging output. IF(LDEBUG)THEN PRINT *,' ++++++ SETC2X DEBUG : P, P1, P2=',P,P1,P2 PRINT *,' ZMULT=',ZMULT PRINT *,' MODE=',MODE ENDIF *** Fill the capacitance matrix. DO 10 I=1,NWIRE CX=COPLAX-SX*ANINT((COPLAX-X(I))/SX) DO 20 J=1,NWIRE IF(MODE.EQ.0)THEN TEMP=(X(I)-CX)*(X(J)-CX)*2.0*PI/(SX*SY) ELSE TEMP=0.0 ENDIF IF(I.EQ.J)THEN A(I,I)=PH2LIM(0.5*D(I))- - PH2(2.0*(X(I)-CX),0.0)-TEMP ELSE A(I,J)=PH2(X(I)-X(J),Y(I)-Y(J))- - PH2(X(I)+X(J)-2.0*CX,Y(I)-Y(J))-TEMP ENDIF 20 CONTINUE 10 CONTINUE *** Call CHARGE to find the wire charges. CALL CHARGE(IFAIL) IF(IFAIL.EQ.1)RETURN *** Determine the non-logaritmic part of the potential (0 if MODE=1). IF(MODE.EQ.0)THEN S=0.0 DO 30 I=1,NWIRE CX=COPLAX-SX*ANINT((COPLAX-X(I))/SX) S=S+E(I)*(X(I)-CX) 30 CONTINUE C1=-S*2.0*PI/(SX*SY) ELSE C1=0.0 ENDIF RETURN END +DECK,SETC2Y. SUBROUTINE SETC2Y(IFAIL) *----------------------------------------------------------------------- * SETC2Y - This initializing subroutine stores the capacitance matrix * for the configuration: * wires at zw(j)+cmplx(lx*sx,ly*2*sy), * j=1(1)n, lx=-infinity(1)infinity, ly=-infinity(1)infinity. * but the signs of the charges alternate in the y-direction *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,CAPACMATRIX. +SEQ,CONSTANTS. +SEQ,PRINTPLOT. *** Initialise the constants. P=0 P1=0 P2=0 IF(SX.LE.2.0*SY)THEN MODE=1 IF(SY/SX.LE.6.0)P=EXP(-2.0*PI*SY/SX) ZMULT=CMPLX(PI/SX,0.0) ELSE MODE=0 IF(SX/SY.LE.25.0)P=EXP(-0.5*PI*SX/SY) ZMULT=CMPLX(0.0,0.5*PI/SY) ENDIF P1=P**2 IF(P1.GT.1.0E-10)P2=P**6 *** Produce some debugging output. IF(LDEBUG)THEN PRINT *,' ++++++ SETC2Y DEBUG : P, P1, P2=',P,P1,P2 PRINT *,' ZMULT=',ZMULT PRINT *,' MODE=',MODE ENDIF *** Fill the capacitance matrix. DO 10 I=1,NWIRE CY=COPLAY-SY*ANINT((COPLAY-Y(I))/SY) DO 20 J=1,NWIRE IF(MODE.EQ.0)THEN TEMP=0.0 ELSE TEMP=(Y(I)-CY)*(Y(J)-CY)*2.0*PI/(SX*SY) ENDIF IF(I.EQ.J)THEN A(I,I)=PH2LIM(0.5*D(I))- - PH2(0.0,2.0*(Y(J)-CY))-TEMP ELSE A(I,J)=PH2(X(I)-X(J),Y(I)-Y(J))- - PH2(X(I)-X(J),Y(I)+Y(J)-2.0*CY)-TEMP ENDIF 20 CONTINUE 10 CONTINUE *** Call CHARGE to find the wire charges. CALL CHARGE(IFAIL) IF(IFAIL.EQ.1)RETURN *** The non-logarithmic part of the potential is zero if MODE=0. IF(MODE.EQ.1)THEN S=0.0 DO 30 I=1,NWIRE CY=COPLAY-SY*ANINT((COPLAY-Y(I))/SY) S=S+E(I)*(Y(I)-CY) 30 CONTINUE C1=-S*2.0*PI/(SX*SY) ELSE C1=0.0 ENDIF END +DECK,SETC30. SUBROUTINE SETC30(IFAIL) *----------------------------------------------------------------------- * SETC30 - This initializing subroutine stores the capacitance matrix * for a configuration with * wires at zw(j)+cmplx(lx*2*sx,ly*2*sy), * j=1(1)n, lx=-infinity(1)infinity, ly=-infinity(1)infinity. * but the signs of the charges alternate in both directions. *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,CAPACMATRIX. +SEQ,PRINTPLOT. +SEQ,CONSTANTS. *** Initialise the constants. P=0.0 P1=0.0 P2=0.0 IF(SX.LE.SY)THEN MODE=1 IF(SY/SX.LE.13.0)P=EXP(-PI*SY/SX) ZMULT=CMPLX(0.5*PI/SX,0.0) ELSE MODE=0 IF(SX/SY.LE.13.0)P=EXP(-PI*SX/SY) ZMULT=CMPLX(0.0,0.5*PI/SY) ENDIF P1=P**2 IF(P1.GT.1.0E-10)P2=P**6 *** Produce some debugging output. IF(LDEBUG)THEN PRINT *,' ++++++ SETC30 DEBUG : P, P1, P2=',P,P1,P2 PRINT *,' ZMULT=',ZMULT PRINT *,' MODE=',MODE ENDIF *** Fill the capacitance matrix. DO 10 I=1,NWIRE CX=COPLAX-SX*ANINT((COPLAX-X(I))/SX) CY=COPLAY-SY*ANINT((COPLAY-Y(I))/SY) DO 20 J=1,NWIRE IF(I.EQ.J)THEN A(I,I)=PH2LIM(0.5*D(I))- - PH2(0.0,2.0*(Y(I)-CY))- - PH2(2.0*(X(I)-CX),0.0)+ - PH2(2.0*(X(I)-CX),2.0*(Y(I)-CY)) ELSE A(I,J)=PH2(X(I)-X(J),Y(I)-Y(J))- - PH2(X(I)-X(J),Y(I)+Y(J)-2.0*CY)- - PH2(X(I)+X(J)-2.0*CX,Y(I)-Y(J))+ - PH2(X(I)+X(J)-2.0*CX,Y(I)+Y(J)-2.0*CY) ENDIF 20 CONTINUE 10 CONTINUE *** Call CHARGE to find the wire charges. CALL CHARGE(IFAIL) IF(IFAIL.EQ.1)RETURN *** The non-logarithmic part of the potential is zero in this case. C1=0.0 END +DECK,SETD10,IF=NEVER. SUBROUTINE SETD10(IFAIL) *----------------------------------------------------------------------- * SETD10 - Subroutine preparing the field calculations by calculating * the charges on the wires, for cells with a tube. * VARIABLES : * (Last changed on 30/ 1/93.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,CAPACMATRIX. COMPLEX ZI,ZJ *** Loop over all wires. DO 10 I=1,NWIRE * Set the diagonal terms. A(I,I)=-LOG(0.5*D(I)/(COTUBE-(X(I)**2+Y(I)**2)/COTUBE)) * Set a complex wire-coordinate to make things a little easier. ZI=CMPLX(X(I),Y(I)) *** Loop over all other wires for the off-diagonal elements. DO 20 J=I+1,NWIRE * Set a complex wire-coordinate to make things a little easier. ZJ=CMPLX(X(J),Y(J)) A(I,J)=-LOG(ABS((1/COTUBE)*(ZI-ZJ)/(1-CONJG(ZI)*ZJ/COTUBE**2))) *** Copy this to A(J,I) since the capacitance matrix is symmetric. A(J,I)=A(I,J) 20 CONTINUE 10 CONTINUE *** Call CHARGE to calculate the charges really. CALL CHARGE(IFAIL) END +DECK,SETD10. SUBROUTINE SETD10(IFAIL) *----------------------------------------------------------------------- * SETD10 - Subroutine preparing the field calculations by calculating * the charges on the wires, for cells with a tube. * VARIABLES : * (Last changed on 4/ 9/95.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,CAPACMATRIX. COMPLEX ZI,ZJ *** Loop over all wires. DO 10 I=1,NWIRE * Set the diagonal terms. A(I,I)=-LOG(0.5*D(I)*COTUBE/(COTUBE**2-(X(I)**2+Y(I)**2))) * Set a complex wire-coordinate to make things a little easier. ZI=CMPLX(X(I),Y(I)) *** Loop over all other wires for the off-diagonal elements. DO 20 J=I+1,NWIRE * Set a complex wire-coordinate to make things a little easier. ZJ=CMPLX(X(J),Y(J)) A(I,J)=-LOG(ABS(COTUBE*(ZI-ZJ)/(COTUBE**2-CONJG(ZI)*ZJ))) *** Copy this to A(J,I) since the capacitance matrix is symmetric. A(J,I)=A(I,J) 20 CONTINUE 10 CONTINUE *** Call CHARGE to calculate the charges really. CALL CHARGE(IFAIL) END +DECK,SETD20. SUBROUTINE SETD20(IFAIL) *----------------------------------------------------------------------- * SETD20 - Subroutine preparing the field calculations by calculating * the charges on the wires, for cells with a tube and a * phi periodicity. Assymetric capacitance matrix ! * VARIABLES : * (Last changed on 18/ 2/93.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,CAPACMATRIX. COMPLEX ZI,ZJ *** Loop over all wires. DO 10 I=1,NWIRE * Set a complex wire-coordinate to make things a little easier. ZI=CMPLX(X(I),Y(I)) *** Case of a wire near the centre. IF(ABS(ZI).LT.D(I)/2)THEN * Inner loop over the wires. DO 20 J=1,NWIRE * Set the diagonal terms. IF(I.EQ.J)THEN A(I,I)=-LOG(0.5*D(I)/ - (COTUBE-(X(I)**2+Y(I)**2)/COTUBE)) * Off-diagonal terms. ELSE ZJ=CMPLX(X(J),Y(J)) A(J,I)=-LOG(ABS((1/COTUBE)*(ZI-ZJ)/ - (1-CONJG(ZI)*ZJ/COTUBE**2))) ENDIF 20 CONTINUE *** Normal case. ELSE * Inner wire loop. DO 30 J=1,NWIRE * Diagonal elements. IF(I.EQ.J)THEN A(I,I)=-LOG(ABS(0.5*D(I)*MTUBE*ZI**(MTUBE-1)/ - ((COTUBE**MTUBE)*(1-(ABS(ZI)/COTUBE)** - (2*MTUBE))))) * Off-diagonal terms. ELSE ZJ=CMPLX(X(J),Y(J)) A(J,I)=-LOG(ABS((1/COTUBE**MTUBE)* - (ZJ**MTUBE-ZI**MTUBE)/ - (1-(ZJ*CONJG(ZI)/COTUBE**2)**MTUBE))) ENDIF 30 CONTINUE ENDIF *** Next wire. 10 CONTINUE *** Call CHARGE to calculate the charges really. CALL CHARGE(IFAIL) END +DECK,SETD30. SUBROUTINE SETD30(IFAIL) *----------------------------------------------------------------------- * SETD30 - Subroutine preparing the field calculations by calculating * the charges on the wires, for cells with wires inside a * polygon. * Variables : No local variables. * (Last changed on 21/ 2/94.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,CAPACMATRIX. COMPLEX WD *** Evaluate kappa, a constant needed by EFCMAP. KAPPA=GAMMA(REAL(NTUBE+1)/REAL(NTUBE))* - GAMMA(REAL(NTUBE-2)/REAL(NTUBE))/ - GAMMA(REAL(NTUBE-1)/REAL(NTUBE)) *** Loop over all wire combinations. DO 10 I=1,NWIRE *** Compute wire mappings only once. CALL EFCMAP(CMPLX(X(I),Y(I))/COTUBE,WMAP(I),WD) * Diagonal elements. A(I,I)=-LOG(ABS((0.5*D(I)/COTUBE)*WD/(1-ABS(WMAP(I))**2))) *** Loop over all other wires for the off-diagonal elements. DO 20 J=1,I-1 A(I,J)=-LOG(ABS((WMAP(I)-WMAP(J))/(1-CONJG(WMAP(I))*WMAP(J)))) *** Copy this to A(J,I) since the capacitance matrix is symmetric. A(J,I)=A(I,J) 20 CONTINUE 10 CONTINUE *** Call CHARGE to calculate the charges really. CALL CHARGE(IFAIL) END +DECK,CHARGE. SUBROUTINE CHARGE(IFAIL) *----------------------------------------------------------------------- * CHARGE - Routine actually inverting the capacitance matrix filled in * the SET... routines thereby providing the charges. * (Last changed on 30/ 1/93.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,CAPACMATRIX. +SEQ,PRINTPLOT. DOUBLE PRECISION T *** Identify the routine, if requested. IF(LIDENT)PRINT *,' /// ROUTINE CHARGE ///' *** Dump the capacitance matrix before inversion, if DEBUG is requested. IF(LDEBUG)THEN WRITE(LUNOUT,'(/'' ++++++ CHARGE DEBUG : Dump of the'', - '' capacitance matrix before inversion follows:''/)') DO 160 I=0,NWIRE-1,10 DO 170 J=0,NWIRE-1,10 WRITE(LUNOUT,'(''1 Block '',I2,''.'',I2/)') I/10,J/10 DO 180 II=1,10 IF(I+II.GT.NWIRE)GOTO 180 WRITE(LUNOUT,'(2X,10(E12.5,1X:))') - (A(I+II,J+JJ),JJ=1,MIN(NWIRE-J,10)) 180 CONTINUE 170 CONTINUE 160 CONTINUE WRITE(LUNOUT,'(/'' ++++++ CHARGE DEBUG : End of the'', - '' uninverted capacitance matrix dump.''/)') ENDIF *** Transfer the voltages to A, correcting for the equipotential planes. DO 10 I=1,NWIRE A(I,MXWIRE+3)=V(I)-(CORVTA*X(I)+CORVTB*Y(I)+CORVTC) 10 CONTINUE *** Force sum charges =0 in case of absence of equipotential planes. IF(.NOT.(YNPLAN(1).OR.YNPLAN(2).OR. - YNPLAN(3).OR.YNPLAN(4).OR.TUBE))THEN * Add extra elements to A, acting as constraints. A(NWIRE+1,MXWIRE+3)=0.0 DO 20 I=1,NWIRE A(I,NWIRE+1)=1.0 A(NWIRE+1,I)=1.0 20 CONTINUE A(NWIRE+1,NWIRE+1)=0.0 +SELF,IF=VECTOR,IF=ESSL. * Solve equations to yield charges, using ESSL (IBM Vector). CALL DGEF(A,MXWIRE+1,NWIRE+1,A(1,MXWIRE+2)) CALL DGES(A,MXWIRE+1,NWIRE+1,A(1,MXWIRE+2),A(1,MXWIRE+3),0) +SELF,IF=-VECTOR,-ESSL. * Solve equations to yield charges, using KERNLIB (scalar). CALL DEQINV(NWIRE+1,A,MXWIRE+1,A(1,NWIRE+2),IFAIL,1, - A(1,MXWIRE+3)) * Modify A to give true inverse of capacitance matrix. IF(A(NWIRE+1,NWIRE+1).NE.0.0)THEN T=1.0/A(NWIRE+1,NWIRE+1) DO 40 I=1,NWIRE DO 30 J=1,NWIRE A(I,J)=A(I,J)-T*A(I,NWIRE+1)*A(NWIRE+1,J) 30 CONTINUE 40 CONTINUE ELSE PRINT *,' !!!!!! CHARGE WARNING : True inverse of'// - ' the capacitance matrix could not be calculated.' PRINT *,' Use of the FACTOR'// - ' instruction should be avoided.' ENDIF +SELF. * Store reference potential. V0=A(NWIRE+1,MXWIRE+3) ELSE *** Handle the case when the sum of the charges is zero automatically. +SELF,IF=VECTOR,IF=ESSL. CALL DGEF(A,MXWIRE+1,NWIRE,A(1,MXWIRE+2)) CALL DGES(A,MXWIRE+1,NWIRE,A(1,MXWIRE+2),A(1,MXWIRE+3),0) +SELF,IF=-VECTOR,-ESSL. CALL DEQINV(NWIRE,A,MXWIRE+1,A(1,NWIRE+2),IFAIL,1, - A(1,MXWIRE+3)) +SELF. * Reference potential chosen to be zero. V0=0.0 ENDIF *** Check the error condition flag. IF(IFAIL.NE.0)THEN PRINT *,' ###### CHARGE ERROR : Failure to solve the'// - ' capacitance equations; no charges are available.' IFAIL=1 RETURN ENDIF *** Copy the charges to E. DO 50 I=1,NWIRE E(I)=A(I,MXWIRE+3) 50 CONTINUE *** If LDEBUG is on, print the capacitance matrix. IF(LDEBUG)THEN WRITE(LUNOUT,'(/'' ++++++ CHARGE DEBUG : Dump of the'', - '' capacitance matrix follows:''/)') DO 60 I=0,NWIRE-1,10 DO 70 J=0,NWIRE-1,10 WRITE(LUNOUT,'(''1 Block '',I2,''.'',I2/)') I/10,J/10 DO 80 II=1,10 IF(I+II.GT.NWIRE)GOTO 80 WRITE(LUNOUT,'(2X,10(E12.5,1X:))') - (A(I+II,J+JJ),JJ=1,MIN(NWIRE-J,10)) 80 CONTINUE 70 CONTINUE 60 CONTINUE WRITE(LUNOUT,'(/'' ++++++ CHARGE DEBUG : End of the'', - '' capacitance matrix.''/)') ENDIF +SELF,IF=-VECTOR,-ESSL. * And also check the quality of the matrix inversion. IF(LCHGCH)THEN WRITE(LUNOUT,'(/'' QUALITY CHECK'', - '' OF THE CHARGE CALCULATION.''// - '' wire E as obtained'', - '' E reconstructed''/)') DO 100 I=1,NWIRE A(I,MXWIRE+2)=0 DO 110 J=1,NWIRE A(I,MXWIRE+2)=A(I,MXWIRE+2)+ - A(I,J)*(V(J)-V0-(CORVTA*X(J)+CORVTB*Y(J)+CORVTC)) 110 CONTINUE WRITE(LUNOUT,'(26X,I4,5X,E15.8,5X,E15.8)') - I,E(I),A(I,MXWIRE+2) 100 CONTINUE WRITE(LUNOUT,'('' '')') ENDIF +SELF. END +DECK,EFIELD. SUBROUTINE EFIELD(XIN,YIN,ZIN,EX,EY,EZ,ETOT,VOLT,IOPT,ILOC) *----------------------------------------------------------------------- * EFIELD - Subroutine calculating the electric field and the potential * at a given place. It makes use of the routines POT..., * depending on the type of the cell. * VARIABLES : XPOS : x-coordinate of the place where the field * is to be calculated. * YPOS, ZPOS : y- and z-coordinates * EX, EY, EZ : x-, y-, z-component of the electric field. * VOLT : potential at (XPOS,YPOS). * IOPT : 1 if both E and V are required, 0 if only E * is to be computed. * ILOC : Tells where the point is located (0: normal * I > 0: in wire I, -1: outside a plane, * -5: in a material, -6: outside the mesh, * -10: unknown potential). * (Last changed on 3/ 6/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PARAMETERS. +SEQ,CELLDATA. +SEQ,PRINTPLOT. +SEQ,CONSTANTS. REAL XIN,YIN,ZIN,EX,EY,EZ,ETOT,VOLT,XPOS,YPOS,ZPOS,DXWIR,DYWIR, - AROT,EX3D,EY3D,EZ3D,V3D,EXBGF,EYBGF,EZBGF,VBGF,XAUX,YAUX INTEGER IOUT,ILOC,IOPT,I *** Initialise the field for returns without actual calculations. EX=0.0 EY=0.0 EZ=0.0 ETOT=0.0 VOLT=0.0 ILOC=0 *** In case of periodicity, move the point into the basic cell. IF(ICTYPE.NE.0)THEN IF(PERX)THEN XPOS=XIN-SX*ANINT(XIN/SX) ELSE XPOS=XIN ENDIF IF(PERY.AND.TUBE)THEN CALL CFMCTP(XIN,YIN,XPOS,YPOS,1) AROT=180*SY*ANINT((PI*YPOS)/(SY*180.0))/PI YPOS=YPOS-AROT CALL CFMPTC(XPOS,YPOS,XPOS,YPOS,1) ELSEIF(PERY)THEN YPOS=YIN-SY*ANINT(YIN/SY) ELSE YPOS=YIN ENDIF *** Move the point to the correct side of the plane. IF(PERX.AND.YNPLAN(1).AND.XPOS.LE.COPLAN(1))XPOS=XPOS+SX IF(PERX.AND.YNPLAN(2).AND.XPOS.GE.COPLAN(2))XPOS=XPOS-SX IF(PERY.AND.YNPLAN(3).AND.YPOS.LE.COPLAN(3))YPOS=YPOS+SY IF(PERY.AND.YNPLAN(4).AND.YPOS.GE.COPLAN(4))YPOS=YPOS-SY *** In case (XPOS,YPOS) is located behind a plane there is no field. IOUT=0 IF(TUBE)THEN CALL INTUBE(XPOS,YPOS,COTUBE,NTUBE,IOUT) IF(IOUT.NE.0)VOLT=VTTUBE ELSE IF(YNPLAN(1).AND.XPOS.LT.COPLAN(1))IOUT=1 IF(YNPLAN(2).AND.XPOS.GT.COPLAN(2))IOUT=2 IF(YNPLAN(3).AND.YPOS.LT.COPLAN(3))IOUT=3 IF(YNPLAN(4).AND.YPOS.GT.COPLAN(4))IOUT=4 IF(IOUT.EQ.1)VOLT=VTPLAN(1) IF(IOUT.EQ.2)VOLT=VTPLAN(2) IF(IOUT.EQ.3)VOLT=VTPLAN(3) IF(IOUT.EQ.4)VOLT=VTPLAN(4) ENDIF IF(IOUT.NE.0)THEN ILOC=-4 RETURN ENDIF *** If (XPOS,YPOS) is within a wire, there is no field either. DO 10 I=1,NWIRE * Correct for x-periodicity. IF(PERX)THEN DXWIR=(XPOS-X(I))-SX*ANINT((XPOS-X(I))/SX) ELSE DXWIR=XPOS-X(I) ENDIF * Correct for y-periodicity. IF(PERY.AND..NOT.TUBE)THEN DYWIR=(YPOS-Y(I))-SY*ANINT((YPOS-Y(I))/SY) ELSE DYWIR=YPOS-Y(I) ENDIF * Check the actual position. IF(DXWIR**2+DYWIR**2.LT.0.25*D(I)**2)THEN VOLT=V(I) ILOC=I RETURN ENDIF * Next wire. 10 CONTINUE ELSE XPOS=XIN YPOS=YIN ZPOS=ZIN ENDIF *** Call the appropriate potential calculation function. IF(ICTYPE.EQ.0)THEN CALL EFCFMP(XPOS,YPOS,ZPOS,EX,EY,EZ,VOLT,IOPT,ILOC) IF(ILOC.NE.0.AND.ILOC.NE.-5)RETURN ELSEIF(ICTYPE.EQ.1.AND.NXMATT.EQ.0.AND.NYMATT.EQ.0)THEN CALL EFCA00(XPOS,YPOS,EX,EY,VOLT,IOPT) ELSEIF(ICTYPE.EQ.1)THEN CALL EFDA00(XPOS,YPOS,EX,EY,VOLT,IOPT) ELSEIF(ICTYPE.EQ.2)THEN CALL EFCB1X(XPOS,YPOS,EX,EY,VOLT,IOPT) ELSEIF(ICTYPE.EQ.3)THEN CALL EFCB1Y(XPOS,YPOS,EX,EY,VOLT,IOPT) ELSEIF(ICTYPE.EQ.4)THEN CALL EFCB2X(XPOS,YPOS,EX,EY,VOLT,IOPT) ELSEIF(ICTYPE.EQ.5)THEN CALL EFCB2Y(XPOS,YPOS,EX,EY,VOLT,IOPT) ELSEIF(ICTYPE.EQ.6)THEN CALL EFCC10(XPOS,YPOS,EX,EY,VOLT,IOPT) ELSEIF(ICTYPE.EQ.7)THEN CALL EFCC2X(XPOS,YPOS,EX,EY,VOLT,IOPT) ELSEIF(ICTYPE.EQ.8)THEN CALL EFCC2Y(XPOS,YPOS,EX,EY,VOLT,IOPT) ELSEIF(ICTYPE.EQ.9)THEN CALL EFCC30(XPOS,YPOS,EX,EY,VOLT,IOPT) ELSEIF(ICTYPE.EQ.10)THEN CALL EFCD10(XPOS,YPOS,EX,EY,VOLT,IOPT) ELSEIF(ICTYPE.EQ.11)THEN CALL EFCD20(XPOS,YPOS,EX,EY,VOLT,IOPT) ELSEIF(ICTYPE.EQ.12)THEN CALL EFCD30(XPOS,YPOS,EX,EY,VOLT,IOPT) C ELSEIF(ICTYPE.EQ.13)THEN C CALL EFCD40(XPOS,YPOS,EX,EY,VOLT,IOPT) ELSE ILOC=-10 RETURN ENDIF *** Rotate the field in some special cases. IF(ICTYPE.NE.0)THEN IF(PERY.AND.TUBE)THEN CALL CFMCTP(EX,EY,XAUX,YAUX,1) YAUX=YAUX+AROT CALL CFMPTC(XAUX,YAUX,EX,EY,1) ENDIF *** Correct for the equipotential planes. EX=EX-CORVTA EY=EY-CORVTB VOLT=VOLT+CORVTA*XPOS+CORVTB*YPOS+CORVTC ENDIF *** Add three dimensional point charges. IF(N3D.GT.0)THEN IF(ICTYPE.EQ.1.OR.ICTYPE.EQ.2.OR.ICTYPE.EQ.3)THEN CALL E3DA00(XIN,YIN,ZIN,EX3D,EY3D,EZ3D,V3D) ELSEIF(ICTYPE.EQ.4)THEN CALL E3DB2X(XIN,YIN,ZIN,EX3D,EY3D,EZ3D,V3D) ELSEIF(ICTYPE.EQ.5)THEN CALL E3DB2Y(XIN,YIN,ZIN,EX3D,EY3D,EZ3D,V3D) ELSEIF(ICTYPE.EQ.10)THEN CALL E3DD10(XIN,YIN,ZIN,EX3D,EY3D,EZ3D,V3D) ELSE EX3D=0.0 EY3D=0.0 EZ3D=0.0 V3D=0.0 CALL E3DA00(XIN,YIN,ZIN,EX3D,EY3D,EZ3D,V3D) ENDIF EX=EX+EX3D EY=EY+EY3D EZ=EZ+EZ3D VOLT=VOLT+V3D ENDIF *** Add a background field if present. IF(IENBGF.GT.0)THEN CALL EFCBGF(XIN,YIN,ZIN,EXBGF,EYBGF,EZBGF,VBGF) EX=EX+EXBGF EY=EY+EYBGF EZ=EZ+EZBGF VOLT=VOLT+VBGF ENDIF *** Finally calculate the value of ETOT (magnitude of the E-field). ETOT=SQRT(EX**2+EY**2+EZ**2) END +DECK,EFCA00SC,IF=-VECTOR. SUBROUTINE EFCA00(XPOS,YPOS,EX,EY,VOLT,IOPT) *----------------------------------------------------------------------- * EFCA00 - Subroutine performing the actual field calculations in case * only one charge and not more than 1 mirror-charge in either * x or y is present. * The potential used is 1/2*pi*eps0 log(r). * VARIABLES : R2 : Potential before taking -log(sqrt(...)) * EX, EY : x,y-component of the electric field. * ETOT : Magnitude of electric field. * VOLT : Potential. * EXHELP etc : One term in the series to be summed. * (XPOS,YPOS): The position where the field is calculated. * (Last changed on 25/ 1/96.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,CELLDATA. *** Initialise the potential and the electric field. EX=0.0 EY=0.0 VOLT=V0 *** Loop over all wires. DO 10 I=1,NWIRE *** Calculate the field in case there are no planes. R2=(XPOS-X(I))**2+(YPOS-Y(I))**2 EXHELP=(XPOS-X(I))/R2 EYHELP=(YPOS-Y(I))/R2 *** Take care of a plane at constant x. IF(YNPLAX)THEN XXMIRR=X(I)+(XPOS-2.0*COPLAX) R2PLAN=XXMIRR**2+(YPOS-Y(I))**2 EXHELP=EXHELP-XXMIRR/R2PLAN EYHELP=EYHELP-(YPOS-Y(I))/R2PLAN R2=R2/R2PLAN ENDIF *** Take care of a plane at constant y. IF(YNPLAY)THEN YYMIRR=Y(I)+(YPOS-2.0*COPLAY) R2PLAN=(XPOS-X(I))**2+YYMIRR**2 EXHELP=EXHELP-(XPOS-X(I))/R2PLAN EYHELP=EYHELP-YYMIRR/R2PLAN R2=R2/R2PLAN ENDIF *** Take care of pairs of planes. IF(YNPLAX.AND.YNPLAY)THEN R2PLAN=XXMIRR**2+YYMIRR**2 EXHELP=EXHELP+XXMIRR/R2PLAN EYHELP=EYHELP+YYMIRR/R2PLAN R2=R2*R2PLAN ENDIF *** Calculate the electric field and the potential. IF(IOPT.NE.0)VOLT=VOLT-0.5*E(I)*LOG(R2) EX=EX+E(I)*EXHELP EY=EY+E(I)*EYHELP *** Finish the loop over the wires. 10 CONTINUE END +DECK,EFCA00VF,IF=VECTOR. SUBROUTINE EFCA00(XPOS,YPOS,EX,EY,VOLT,IOPT) *----------------------------------------------------------------------- * EFCA00 - Subroutine performing the actual field calculations in case * only one charge and not more than 1 mirror-charge in either * x or y is present. * IBM and Cray vectorisable version - IOPT ignored. * * VARIABLES : R2 : Potential before taking -log(sqrt(...)) * EX, EY : x,y-component of the electric field. * ETOT : Magnitude of electric field. * VOLT : Potential. * EXHELP etc : One term in the series to be summed. * (XPOS,YPOS): The position where the field is calculated. * (Last changed on 23/ 2/94.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,CELLDATA. DOUBLE PRECISION EXS,EYS,VOLTS,R2,R2PLX,R2PLY,R2PLXY,R2PLAN *** Initialise the potential and the electric field. EXS=0.0 EYS=0.0 VOLTS=V0 *** Both an x and a y plane. IF(YNPLAX.AND.YNPLAY)THEN DO 10 I=1,NWIRE R2= (XPOS-X(I))**2+ (YPOS-Y(I))**2 R2PLX= (XPOS+X(I)-2*COPLAX)**2+(YPOS-Y(I))**2 R2PLY= (XPOS-X(I))**2+ (YPOS+Y(I)-2*COPLAY)**2 R2PLXY=(XPOS+X(I)-2*COPLAX)**2+(YPOS+Y(I)-2*COPLAY)**2 VOLTS=VOLTS-0.5*E(I)*LOG(R2*R2PLXY/(R2PLX*R2PLY)) EXS=EXS+E(I)*((XPOS-X(I))/R2-(XPOS+X(I)-2*COPLAX)/R2PLX- - (XPOS-X(I))/R2PLY+(XPOS+X(I)-2*COPLAX)/R2PLXY) EYS=EYS+E(I)*((YPOS-Y(I))/R2-(YPOS-Y(I))/R2PLX- - (YPOS+Y(I)-2*COPLAY)/R2PLY+(YPOS+Y(I)-2*COPLAY)/R2PLXY) 10 CONTINUE *** Only an x plane. ELSEIF(YNPLAX)THEN DO 20 I=1,NWIRE R2=(XPOS-X(I))**2+(YPOS-Y(I))**2 R2PLAN=(X(I)+(XPOS-2*COPLAX))**2+(YPOS-Y(I))**2 VOLTS=VOLTS-0.5*E(I)*LOG(R2/R2PLAN) EXS=EX+E(I)*((XPOS-X(I))/R2-(X(I)+(XPOS-2*COPLAX))/R2PLAN) EYS=EY+E(I)*((YPOS-Y(I))/R2-(YPOS-Y(I))/R2PLAN) 20 CONTINUE *** Only an y plane. ELSEIF(YNPLAY)THEN DO 30 I=1,NWIRE R2=(XPOS-X(I))**2+(YPOS-Y(I))**2 R2PLAN=(XPOS-X(I))**2+(Y(I)+(YPOS-2*COPLAY))**2 VOLTS=VOLTS-0.5*E(I)*LOG(R2/R2PLAN) EXS=EXS+E(I)*((XPOS-X(I))/R2-(XPOS-X(I))/R2PLAN) EYS=EYS+E(I)*((YPOS-Y(I))/R2-(Y(I)+(YPOS-2*COPLAY))/R2PLAN) 30 CONTINUE *** No planes at all. ELSE DO 40 I=1,NWIRE R2=(XPOS-X(I))**2+(YPOS-Y(I))**2 VOLTS=VOLTS-0.5*E(I)*LOG(R2) EXS=EXS+E(I)*(XPOS-X(I))/R2 EYS=EYS+E(I)*(YPOS-Y(I))/R2 40 CONTINUE ENDIF *** Reduce to single precision. EX=REAL(EXS) EY=REAL(EYS) VOLT=REAL(VOLTS) END +DECK,E3DA00. SUBROUTINE E3DA00(XPOS,YPOS,ZPOS,EX,EY,EZ,VOLT) *----------------------------------------------------------------------- * E3DA00 - Subroutine adding 3-dimensional charges for A cells. * The potential used is 1/2*pi*eps0 1/r * VARIABLES : EX, EY : x,y-component of the electric field. * ETOT : Magnitude of electric field. * VOLT : Potential. * EXHELP etc : One term in the series to be summed. * (XPOS,YPOS): The position where the field is calculated. * (Last changed on 5/12/94.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,CELLDATA. *** Initialise the potential and the electric field. EX=0.0 EY=0.0 EZ=0.0 VOLT=0.0 *** Loop over all charges. DO 10 I=1,N3D *** Calculate the field in case there are no planes. R=SQRT((XPOS-X3D(I))**2+(YPOS-Y3D(I))**2+(ZPOS-Z3D(I))**2) IF(R.EQ.0)GOTO 10 EXHELP=-(XPOS-X3D(I))/R**3 EYHELP=-(YPOS-Y3D(I))/R**3 EZHELP=-(ZPOS-Z3D(I))/R**3 VHELP =1/R *** Take care of a plane at constant x. IF(YNPLAX)THEN XXMIRR=X3D(I)+(XPOS-2*COPLAX) RPLAN=SQRT(XXMIRR**2+(YPOS-Y3D(I))**2) IF(RPLAN.EQ.0)GOTO 10 EXHELP=EXHELP+XXMIRR/RPLAN**3 EYHELP=EYHELP+(YPOS-Y3D(I))/RPLAN**3 EZHELP=EZHELP+(ZPOS-Z3D(I))/RPLAN**3 VHELP =VHELP-1/RPLAN ENDIF *** Take care of a plane at constant y. IF(YNPLAY)THEN YYMIRR=Y3D(I)+(YPOS-2*COPLAY) RPLAN=SQRT((XPOS-X3D(I))**2+YYMIRR**2) IF(RPLAN.EQ.0)GOTO 10 EXHELP=EXHELP+(XPOS-X3D(I))/RPLAN**3 EYHELP=EYHELP+YYMIRR/RPLAN**3 EZHELP=EZHELP+(ZPOS-Z3D(I))/RPLAN**3 VHELP =VHELP-1/RPLAN ENDIF *** Take care of pairs of planes. IF(YNPLAX.AND.YNPLAY)THEN RPLAN=SQRT(XXMIRR**2+YYMIRR**2) IF(RPLAN.EQ.0)GOTO 10 EXHELP=EXHELP-XXMIRR/RPLAN**3 EYHELP=EYHELP-YYMIRR/RPLAN**3 EZHELP=EZHELP-(ZPOS-Z3D(I))/RPLAN**3 VHELP =VHELP+1/RPLAN ENDIF *** Add the terms to the electric field and the potential. EX=EX-E3D(I)*EXHELP EY=EY-E3D(I)*EYHELP EZ=EZ-E3D(I)*EZHELP VOLT=VOLT+E3D(I)*VHELP *** Finish the loop over the charges. 10 CONTINUE END +DECK,EFCB1XSC,IF=-VECTOR. SUBROUTINE EFCB1X(XPOS,YPOS,EX,EY,VOLT,IOPT) *----------------------------------------------------------------------- * EFCB1X - Routine calculating the potential for a row of positive * charges. The potential used is Re(Log(sin pi/s (z-z0))). * VARIABLES : See routine EFCA00 for most of the variables. * Z,ZZMIRR : X + I*Y , XXMIRR + I*YYMIRR ; I**2=-1 * ECOMPL : EX + I*EY ; I**2=-1 *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,CONSTANTS. COMPLEX ZZ,ECOMPL,ZZMIRR *** Initialise EX, EY and VOLT. EX=0.0 EY=0.0 VOLT=V0 *** Loop over all wires. DO 10 I=1,NWIRE XX=(PI/SX)*(XPOS-X(I)) YY=(PI/SX)*(YPOS-Y(I)) ZZ=CMPLX(XX,YY) *** Calculate the field in case there are no equipotential planes. IF( YY.GT.+20.0)ECOMPL=-ICONS IF(ABS(YY).LE.20.0)ECOMPL= - ICONS*(EXP(2.0*ICONS*ZZ)+1.0)/(EXP(2.0*ICONS*ZZ)-1.0) IF( YY.LT.-20.0)ECOMPL=+ICONS IF(IOPT.NE.0)THEN IF(ABS(YY).GT.20.0)R2=-ABS(YY)+CLOG2 IF(ABS(YY).LE.20.0)R2=-0.5*LOG(SINH(YY)**2+SIN(XX)**2) ENDIF *** Take care of a plane at constant y. IF(YNPLAY)THEN YYMIRR=(PI/SX)*(YPOS+Y(I)-2.0*COPLAY) ZZMIRR=CMPLX(XX,YYMIRR) IF( YYMIRR.GT.+20.0)ECOMPL=ECOMPL+ICONS IF(ABS(YYMIRR).LE.20.0)ECOMPL=ECOMPL-ICONS* - (EXP(2.0*ICONS*ZZMIRR)+1.0)/(EXP(2.0*ICONS*ZZMIRR)-1.0) IF( YYMIRR.LT.-20.0)ECOMPL=ECOMPL-ICONS IF(IOPT.NE.0.AND.ABS(YYMIRR).GT.20.0) - R2=R2+ABS(YYMIRR)-CLOG2 IF(IOPT.NE.0.AND.ABS(YYMIRR).LE.20.0) - R2=R2+0.5*LOG(SINH(YYMIRR)**2+SIN(XX)**2) ENDIF *** Calculate the electric field and the potential. EX=EX+E(I)*(PI/SX)*REAL(ECOMPL) EY=EY-E(I)*(PI/SX)*AIMAG(ECOMPL) IF(IOPT.NE.0)VOLT=VOLT+E(I)*R2 *** Finish loop over all wires. 10 CONTINUE END +DECK,EFCB1XVF,IF=VECTOR. SUBROUTINE EFCB1X(XPOS,YPOS,EX,EY,VOLT,IOPT) *----------------------------------------------------------------------- * EFCB1X - Routine calculating the potential for a row of positive * charges. The potential used is Re(Log(sin pi/s (z-z0))). * VARIABLES : See routine EFCA00 for most of the variables. * Z,ZZMIRR : X + I*Y , XXMIRR + I*YYMIRR ; I**2=-1 * ECOMPL : EX + I*EY ; I**2=-1 * (IBM and Cray vectorisable version - IOPT ignored.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,CONSTANTS. COMPLEX ZZ,ECOMPL,ZZMIRR *** Initialise EX, EY and VOLT. EX=0.0 EY=0.0 VOLT=V0 *** With a y plane. IF(YNPLAY)THEN DO 10 I=1,NWIRE XX=(PI/SX)*(XPOS-X(I)) YY=(PI/SX)*(YPOS-Y(I)) ZZ=CMPLX(XX,YY) IF(YY.GT.+20.0)THEN ECOMPL=-ICONS R2=-ABS(YY)+CLOG2 ELSEIF(YY.LT.-20.0)THEN ECOMPL=+ICONS R2=-ABS(YY)+CLOG2 ELSE ECOMPL=ICONS*(EXP(2*ICONS*ZZ)+1)/ - (EXP(2*ICONS*ZZ)-1) R2=-LOG(SINH(YY)**2+SIN(XX)**2)/2 ENDIF YYMIRR=(PI/SX)*(YPOS+Y(I)-2*COPLAY) ZZMIRR=CMPLX(XX,YYMIRR) IF(YYMIRR.GT.+20.0)THEN ECOMPL=ECOMPL+ICONS R2=R2+ABS(YYMIRR)-CLOG2 ELSEIF(YYMIRR.LT.-20.0)THEN ECOMPL=ECOMPL-ICONS R2=R2+ABS(YYMIRR)-CLOG2 ELSE ECOMPL=ECOMPL-ICONS*(EXP(2*ICONS*ZZMIRR)+1)/ - (EXP(2*ICONS*ZZMIRR)-1) R2=R2+LOG(SINH(YYMIRR)**2+SIN(XX)**2)/2 ENDIF * Update the field. EX=EX+E(I)*(PI/SX)*REAL(ECOMPL) EY=EY-E(I)*(PI/SX)*AIMAG(ECOMPL) VOLT=VOLT+E(I)*R2 10 CONTINUE *** Without y plane. ELSE DO 20 I=1,NWIRE XX=(PI/SX)*(XPOS-X(I)) YY=(PI/SX)*(YPOS-Y(I)) ZZ=CMPLX(XX,YY) IF(YY.GT.+20.0)THEN ECOMPL=-ICONS R2=-ABS(YY)+CLOG2 ELSEIF(YY.LT.-20.0)THEN ECOMPL=+ICONS R2=-ABS(YY)+CLOG2 ELSE ECOMPL=ICONS*(EXP(2*ICONS*ZZ)+1)/ - (EXP(2*ICONS*ZZ)-1) R2=-LOG(SINH(YY)**2+SIN(XX)**2)/2 ENDIF EX=EX+E(I)*(PI/SX)*REAL(ECOMPL) EY=EY-E(I)*(PI/SX)*AIMAG(ECOMPL) VOLT=VOLT+E(I)*R2 20 CONTINUE ENDIF END +DECK,EFCB1YSC,IF=-VECTOR. SUBROUTINE EFCB1Y(XPOS,YPOS,EX,EY,VOLT,IOPT) *----------------------------------------------------------------------- * EFCB1Y - Routine calculating the potential for a row of positive * charges. The potential used is Re(Log(sinh pi/sy(z-z0)). * VARIABLES : See routine EFCA00 for most of the variables. * Z,ZZMIRR : X + I*Y , XXMIRR + I*YYMIRR ; I**2=-1 * ECOMPL : EX + I*EY ; I**2=-1 *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,CONSTANTS. COMPLEX ZZ,ECOMPL,ZZMIRR *** Initialise EX, EY and VOLT. EX=0.0 EY=0.0 VOLT=V0 *** Loop over all wires. DO 10 I=1,NWIRE XX=(PI/SY)*(XPOS-X(I)) YY=(PI/SY)*(YPOS-Y(I)) ZZ=CMPLX(XX,YY) *** Calculate the field in case there are no equipotential planes. IF( XX.GT.+20.0)ECOMPL=+1.0 IF(ABS(XX).LE.20.0)ECOMPL=(EXP(2.0*ZZ)+1.0)/(EXP(2.0*ZZ)-1.0) IF( XX.LT.-20.0)ECOMPL=-1.0 IF(IOPT.NE.0)THEN IF(ABS(XX).GT.20.0)R2=-ABS(XX)+CLOG2 IF(ABS(XX).LE.20.0)R2=-0.5*LOG(SINH(XX)**2+SIN(YY)**2) ENDIF *** Take care of a plane at constant x. IF(YNPLAX)THEN XXMIRR=(PI/SY)*(XPOS+X(I)-2.0*COPLAX) ZZMIRR=CMPLX(XXMIRR,YY) IF(XXMIRR.GT.+20.0)ECOMPL=ECOMPL-1.0 IF(XXMIRR.LT.-20.0)ECOMPL=ECOMPL+1.0 IF(ABS(XXMIRR).LE.20.0)ECOMPL=ECOMPL- - (EXP(2.0*ZZMIRR)+1.0)/(EXP(2.0*ZZMIRR)-1.0) IF(IOPT.NE.0.AND.ABS(XXMIRR).GT.20.0) - R2=R2+ABS(XXMIRR)-CLOG2 IF(IOPT.NE.0.AND.ABS(XXMIRR).LE.20.0) - R2=R2+0.5*LOG(SINH(XXMIRR)**2+SIN(YY)**2) ENDIF *** Calculate the electric field and the potential. EX=EX+E(I)*(PI/SY)*REAL(ECOMPL) EY=EY-E(I)*(PI/SY)*AIMAG(ECOMPL) IF(IOPT.NE.0)VOLT=VOLT+E(I)*R2 *** Finish loop over the wires. 10 CONTINUE END +DECK,EFCB1YVF,IF=VECTOR. SUBROUTINE EFCB1Y(XPOS,YPOS,EX,EY,VOLT,IOPT) *----------------------------------------------------------------------- * EFCB1Y - Routine calculating the potential for a row of positive * charges. The potential used is Re(Log(sinh pi/sy(z-z0)). * VARIABLES : See routine EFCA00 for most of the variables. * Z,ZZMIRR : X + I*Y , XXMIRR + I*YYMIRR ; I**2=-1 * ECOMPL : EX + I*EY ; I**2=-1 * (IBM and Cray vectorisable version.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,CONSTANTS. COMPLEX ZZ,ECOMPL,ZZMIRR *** Initialise EX, EY and VOLT. EX=0.0 EY=0.0 VOLT=V0 *** First the situation there is an x-plane. IF(YNPLAX)THEN DO 10 I=1,NWIRE XX=(PI/SY)*(XPOS-X(I)) YY=(PI/SY)*(YPOS-Y(I)) ZZ=CMPLX(XX,YY) IF(XX.GT.+20.0)THEN ECOMPL=+1.0 R2=-ABS(XX)+CLOG2 ELSEIF(XX.LT.-20.0)THEN ECOMPL=-1.0 R2=-ABS(XX)+CLOG2 ELSE ECOMPL=(EXP(2*ZZ)+1)/(EXP(2*ZZ)-1) R2=-LOG(SINH(XX)**2+SIN(YY)**2)/2 ENDIF XXMIRR=(PI/SY)*(XPOS+X(I)-2.0*COPLAX) ZZMIRR=CMPLX(XXMIRR,YY) IF(XXMIRR.GT.+20.0)THEN ECOMPL=ECOMPL-1.0 R2=R2+ABS(XXMIRR)-CLOG2 ELSEIF(XXMIRR.LT.-20.0)THEN ECOMPL=ECOMPL+1.0 R2=R2+ABS(XXMIRR)-CLOG2 ELSE ECOMPL=ECOMPL-(EXP(2*ZZMIRR)+1)/(EXP(2*ZZMIRR)-1) R2=R2+LOG(SINH(XXMIRR)**2+SIN(YY)**2)/2 ENDIF EX=EX+E(I)*(PI/SY)*REAL(ECOMPL) EY=EY-E(I)*(PI/SY)*AIMAG(ECOMPL) VOLT=VOLT+E(I)*R2 10 CONTINUE *** Case the is no plane. ELSE DO 20 I=1,NWIRE XX=(PI/SY)*(XPOS-X(I)) YY=(PI/SY)*(YPOS-Y(I)) ZZ=CMPLX(XX,YY) IF(XX.GT.+20.0)THEN ECOMPL=+1.0 R2=-ABS(XX)+CLOG2 ELSEIF(XX.LT.-20.0)THEN ECOMPL=-1.0 R2=-ABS(XX)+CLOG2 ELSE ECOMPL=(EXP(2*ZZ)+1)/(EXP(2*ZZ)-1) R2=-LOG(SINH(XX)**2+SIN(YY)**2)/2 ENDIF EX=EX+E(I)*(PI/SY)*REAL(ECOMPL) EY=EY-E(I)*(PI/SY)*AIMAG(ECOMPL) VOLT=VOLT+E(I)*R2 20 CONTINUE ENDIF END +DECK,EFCB2X. SUBROUTINE EFCB2X(XPOS,YPOS,EX,EY,VOLT,IOPT) *----------------------------------------------------------------------- * EFCB2X - Routine calculating the potential for a row of alternating * + - charges. The potential used is re log(sin pi/sx (z-z0)) * VARIABLES : See routine EFCA00 for most of the variables. * Z, ZZMRR : X + i*Y , XXMIRR + i*YYMIRR ; i**2=-1 * ECOMPL : EX + i*EY ; i**2=-1 * (Cray vectorisable) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,CONSTANTS. COMPLEX ZZ,ECOMPL,ZZMIRR,ZZNEG,ZZNMIR *** Initialise EX, EY and VOLT. EX=0.0 EY=0.0 VOLT=V0 *** Loop over all wires. DO 10 I=1,NWIRE XX=(0.5*PI/SX)*(XPOS-X(I)) YY=(0.5*PI/SX)*(YPOS-Y(I)) XXNEG=(0.5*PI/SX)*(XPOS+X(I)-2.0*COPLAX) ZZ=CMPLX(XX,YY) ZZNEG=CMPLX(XXNEG,YY) *** Calculate the field in case there are no equipotential planes. ECOMPL=0.0 R2=1.0 IF(ABS(YY).LE.20)ECOMPL=-B2SIN(I)/(SIN(ZZ)*SIN(ZZNEG)) IF(IOPT.NE.0.AND.ABS(YY).LE.20.0) - R2=(SINH(YY)**2+SIN(XX)**2)/(SINH(YY)**2+SIN(XXNEG)**2) *** Take care of a planes at constant y. IF(YNPLAY)THEN YYMIRR=(0.5*PI/SX)*(YPOS+Y(I)-2.0*COPLAY) ZZMIRR=CMPLX(XX,YYMIRR) ZZNMIR=CMPLX(XXNEG,YYMIRR) IF(ABS(YYMIRR).LE.20.0) - ECOMPL=ECOMPL+B2SIN(I)/(SIN(ZZMIRR)*SIN(ZZNMIR)) IF(IOPT.NE.0.AND.ABS(YYMIRR).LE.20.0)THEN R2PLAN=(SINH(YYMIRR)**2+SIN(XX)**2)/ - (SINH(YYMIRR)**2+SIN(XXNEG)**2) R2=R2/R2PLAN ENDIF ENDIF *** Calculate the electric field and the potential. EX=EX+E(I)*(0.5*PI/SX)*REAL(ECOMPL) EY=EY-E(I)*(0.5*PI/SX)*AIMAG(ECOMPL) IF(IOPT.NE.0)VOLT=VOLT-0.5*E(I)*LOG(R2) *** Finish the wire loop. 10 CONTINUE END +DECK,E3DB2X. SUBROUTINE E3DB2X(XPOS,YPOS,ZPOS,EX,EY,EZ,VOLT) *----------------------------------------------------------------------- * E3DB2X - Routine calculating the potential for a 3 dimensional point * charge between two plates at constant x. * The series expansions for the modified Bessel functions * have been taken from Abramowitz and Stegun. * VARIABLES : See routine E3DA00 for most of the variables. * (Last changed on 5/12/94.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,CONSTANTS. DOUBLE PRECISION EXSUM,EYSUM,EZSUM,VSUM, - I0S,I1S,K0S,K0L,K1S,K1L,K0R,K1R,K0RM,K1RM, - XX,RR,RRM,ZZP,ZZN,RR1,RR2,RM1,RM2,ERR,EZZ REAL XPOS,YPOS,ZPOS,EX,EY,EZ,VOLT,RCUT PARAMETER(RCUT=1.0) *** Statement functions for the modified Bessel functions: I0S(XX)=1 - +3.5156229*(XX/3.75)**2 - +3.0899424*(XX/3.75)**4 - +1.2067492*(XX/3.75)**6 - +0.2659732*(XX/3.75)**8 - +0.0360768*(XX/3.75)**10 - +0.0045813*(XX/3.75)**12 I1S(XX)=XX*( - +0.5 - +0.87890594*(XX/3.75)**2 - +0.51498869*(XX/3.75)**4 - +0.15084934*(XX/3.75)**6 - +0.02658733*(XX/3.75)**8 - +0.00301532*(XX/3.75)**10 - +0.00032411*(XX/3.75)**12) K0S(XX)=-LOG(XX/2)*I0S(XX) - -0.57721566 - +0.42278420*(XX/2)**2 - +0.23069756*(XX/2)**4 - +0.03488590*(XX/2)**6 - +0.00262698*(XX/2)**8 - +0.00010750*(XX/2)**10 - +0.00000740*(XX/2)**12 K0L(XX)=(EXP(-XX)/SQRT(XX))*( - +1.25331414 - -0.07832358*(2/XX) - +0.02189568*(2/XX)**2 - -0.01062446*(2/XX)**3 - +0.00587872*(2/XX)**4 - -0.00251540*(2/XX)**5 - +0.00053208*(2/XX)**6) K1S(XX)=LOG(XX/2)*I1S(XX)+(1/XX)*( - +1 - +0.15443144*(XX/2)**2 - -0.67278579*(XX/2)**4 - -0.18156897*(XX/2)**6 - -0.01919402*(XX/2)**8 - -0.00110404*(XX/2)**10 - -0.00004686*(XX/2)**12) K1L(XX)=(EXP(-XX)/SQRT(XX))*( - +1.25331414 - +0.23498619*(2/XX) - -0.03655620*(2/XX)**2 - +0.01504268*(2/XX)**3 - -0.00780353*(2/XX)**4 - +0.00325614*(2/XX)**5 - -0.00068245*(2/XX)**6) *** Initialise the sums for the field components. EX=0.0 EY=0.0 EZ=0.0 VOLT=0.0 *** Loop over all wires. DO 10 I=1,N3D * Skip wires that are on the charge. IF(XPOS.EQ.X3D(I).AND.YPOS.EQ.Y3D(I).AND.ZPOS.EQ.Z3D(I))GOTO 10 *** In the far away zone, sum the modified Bessel function series. IF((YPOS-Y3D(I))**2+(ZPOS-Z3D(I))**2.GT.(RCUT*2*SX)**2)THEN * Initialise the per-wire sum. EXSUM=0.0 EYSUM=0.0 EZSUM=0.0 VSUM=0.0 * Loop over the terms in the series. DO 20 J=1,NTERMB * Obtain reduced coordinates. RR=PI*J*SQRT((YPOS-Y3D(I))**2+(ZPOS-Z3D(I))**2)/SX ZZP=PI*J*(XPOS-X3D(I))/SX ZZN=PI*J*(XPOS+X3D(I)-2*COPLAX)/SX * Evaluate the Bessel functions for this R. IF(RR.LT.2)THEN K0R=K0S(RR) K1R=K1S(RR) ELSE K0R=K0L(RR) K1R=K1L(RR) ENDIF * Get the field components. VSUM=VSUM+(1/SX)*K0R*(COS(ZZP)-COS(ZZN)) ERR=(2*J*PI/SX**2)*K1R*(COS(ZZP)-COS(ZZN)) EZZ=(2*J*PI/SX**2)*K0R*(SIN(ZZP)-SIN(ZZN)) EXSUM=EXSUM+EZZ EYSUM=EYSUM+ERR*(YPOS-Y3D(I))/ - SQRT((YPOS-Y3D(I))**2+(ZPOS-Z3D(I))**2) EZSUM=EZSUM+ERR*(ZPOS-Z3D(I))/ - SQRT((YPOS-Y3D(I))**2+(ZPOS-Z3D(I))**2) 20 CONTINUE *** Direct polynomial summing, obtain reduced coordinates. ELSE * Loop over the terms. DO 30 J=0,NTERMP * Simplify the references to the distances. RR1=SQRT((XPOS-X3D(I)+J*2*SX)**2+(YPOS-Y3D(I))**2+ - (ZPOS-Z3D(I))**2) RR2=SQRT((XPOS-X3D(I)-J*2*SX)**2+(YPOS-Y3D(I))**2+ - (ZPOS-Z3D(I))**2) RM1=SQRT((XPOS+X3D(I)-J*2*SX-2*COPLAX)**2+ - (YPOS-Y3D(I))**2+(ZPOS-Z3D(I))**2) RM2=SQRT((XPOS+X3D(I)+J*2*SX-2*COPLAX)**2+ - (YPOS-Y3D(I))**2+(ZPOS-Z3D(I))**2) * Initialisation of the sum: only a charge and a mirror charge. IF(J.EQ.0)THEN VSUM=1/RR1-1/RM1 EXSUM=(XPOS-X3D(I))/RR1**3- - (XPOS+X3D(I)-2*COPLAX)/RM1**3 EYSUM=(YPOS-Y3D(I))*(1/RR1**3-1/RM1**3) EZSUM=(ZPOS-Z3D(I))*(1/RR1**3-1/RM1**3) * Further terms in the series: 2 charges and 2 mirror charges. ELSE VSUM=VSUM+1/RR1+1/RR2-1/RM1-1/RM2 EXSUM=EXSUM+ - (XPOS-X3D(I)+J*2*SX)/RR1**3+ - (XPOS-X3D(I)-J*2*SX)/RR2**3- - (XPOS+X3D(I)-J*2*SX-2*COPLAX)/RM1**3- - (XPOS+X3D(I)+J*2*SX-2*COPLAX)/RM2**3 EYSUM=EYSUM+(YPOS-Y3D(I))* - (1/RR1**3+1/RR2**3-1/RM1**3-1/RM2**3) EZSUM=EZSUM+(ZPOS-Z3D(I))* - (1/RR1**3+1/RR2**3-1/RM1**3-1/RM2**3) ENDIF 30 CONTINUE ENDIF *** Take care of a planes at constant y. IF(YNPLAY)THEN *** Bessel function series. IF((YPOS+Y3D(I)-2*COPLAY)**2+(ZPOS-Z3D(I))**2.GT. - (RCUT*2*SX)**2)THEN * Loop over the terms in the series. DO 40 J=1,NTERMB * Obtain reduced coordinates. RRM=PI*J*SQRT((YPOS+Y3D(I)-2*COPLAY)**2+ - (ZPOS-Z3D(I))**2)/SX ZZP=PI*J*(XPOS-X3D(I))/SX ZZN=PI*J*(XPOS+X3D(I)-2*COPLAX)/SX * Evaluate the Bessel functions for this R. IF(RRM.LT.2)THEN K0RM=K0S(RRM) K1RM=K1S(RRM) ELSE K0RM=K0L(RRM) K1RM=K1L(RRM) ENDIF * Get the field components. VSUM=VSUM+(1/SX)*K0RM*(COS(ZZP)-COS(ZZN)) ERR=(2*PI/SX**2)*K1RM*(COS(ZZP)-COS(ZZN)) EZZ=(2*PI/SX**2)*K0RM*(SIN(ZZP)-SIN(ZZN)) EXSUM=EXSUM+EZZ EYSUM=EYSUM+ERR*(YPOS+Y3D(I)-2*COPLAY)/ - SQRT((YPOS+Y3D(I)-2*COPLAY)**2+(ZPOS-Z3D(I))**2) EZSUM=EZSUM+ERR*(ZPOS-Z3D(I))/ - SQRT((YPOS+Y3D(I)-2*COPLAY)**2+(ZPOS-Z3D(I))**2) 40 CONTINUE *** Polynomial sum. ELSE * Loop over the terms. DO 50 J=0,NTERMP * Simplify the references to the distances. RR1=SQRT((XPOS-X3D(I)+J*2*SX)**2+ - (YPOS+Y3D(I)-2*COPLAY)**2+(ZPOS-Z3D(I))**2) RR2=SQRT((XPOS-X3D(I)-J*2*SX)**2+ - (YPOS+Y3D(I)-2*COPLAY)**2+(ZPOS-Z3D(I))**2) RM1=SQRT((XPOS+X3D(I)-J*2*SX-2*COPLAX)**2+ - (YPOS+Y3D(I)-2*COPLAY)**2+(ZPOS-Z3D(I))**2) RM2=SQRT((XPOS+X3D(I)+J*2*SX-2*COPLAX)**2+ - (YPOS+Y3D(I)-2*COPLAY)**2+(ZPOS-Z3D(I))**2) * Initialisation of the sum: only a charge and a mirror charge. IF(J.EQ.0)THEN VSUM=VSUM-1/RR1+1/RM1 EXSUM=EXSUM-(XPOS-X3D(I))/RR1**3+ - (XPOS+X3D(I)-2*COPLAX)/RM1**3 EYSUM=EYSUM-(YPOS+Y3D(I)-2*COPLAY)* - (1/RR1**3-1/RM1**3) EZSUM=EZSUM-(ZPOS-Z3D(I))*(1/RR1**3-1/RM1**3) * Further terms in the series: 2 charges and 2 mirror charges. ELSE VSUM=VSUM-1/RR1-1/RR2+1/RM1+1/RM2 EXSUM=EXSUM- - (XPOS-X3D(I)+J*2*SX)/RR1**3- - (XPOS-X3D(I)-J*2*SX)/RR2**3+ - (XPOS+X3D(I)-J*2*SX-2*COPLAX)/RM1**3+ - (XPOS+X3D(I)+J*2*SX-2*COPLAX)/RM2**3 EYSUM=EYSUM-(YPOS+Y3D(I)-2*COPLAY)* - (1/RR1**3+1/RR2**3-1/RM1**3-1/RM2**3) EZSUM=EZSUM-(ZPOS-Z3D(I))* - (1/RR1**3+1/RR2**3-1/RM1**3-1/RM2**3) ENDIF 50 CONTINUE ENDIF ENDIF *** Convert the double precision sum to single precision. EX=EX+E3D(I)*REAL(EXSUM) EY=EY+E3D(I)*REAL(EYSUM) EZ=EZ+E3D(I)*REAL(EZSUM) VOLT=VOLT+E3D(I)*REAL(VSUM) *** Finish the loop over the charges. 10 CONTINUE END +DECK,EFCB2Y. SUBROUTINE EFCB2Y(XPOS,YPOS,EX,EY,VOLT,IOPT) *----------------------------------------------------------------------- * EFCB2Y - Routine calculating the potential for a row of alternating * + - charges. The potential used is re log(sin pi/sx (z-z0)) * VARIABLES : See routine EFCA00 for most of the variables. * Z, ZMIRR : X + i*Y , XXMIRR + i*YYMIRR ; i**2=-1 * ECOMPL : EX + i*EY ; i**2=-1 * (Cray vectorisable) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,CONSTANTS. COMPLEX ZZ,ECOMPL,ZZMIRR,ZZNEG,ZZNMIR *** Initialise EX, EY and VOLT. EX=0.0 EY=0.0 VOLT=V0 *** Loop over all wires. DO 10 I=1,NWIRE XX=(0.5*PI/SY)*(XPOS-X(I)) YY=(0.5*PI/SY)*(YPOS-Y(I)) YYNEG=(0.5*PI/SY)*(YPOS+Y(I)-2.0*COPLAY) ZZ=CMPLX(XX,YY) ZZNEG=CMPLX(XX,YYNEG) *** Calculate the field in case there are no equipotential planes. ECOMPL=0.0 R2=1.0 IF(ABS(XX).LE.20.0) - ECOMPL=ICONS*B2SIN(I)/(SIN(ICONS*ZZ)*SIN(ICONS*ZZNEG)) IF(IOPT.NE.0.AND.ABS(XX).LE.20.0) - R2=(SINH(XX)**2+SIN(YY)**2)/(SINH(XX)**2+SIN(YYNEG)**2) *** Take care of a plane at constant x. IF(YNPLAX)THEN XXMIRR=(0.5*PI/SY)*(XPOS+X(I)-2.0*COPLAX) ZZMIRR=CMPLX(XXMIRR,YY) ZZNMIR=CMPLX(XXMIRR,YYNEG) IF(ABS(XXMIRR).LE.20.0)ECOMPL=ECOMPL- - ICONS*B2SIN(I)/(SIN(ICONS*ZZMIRR)*SIN(ICONS*ZZNMIR)) IF(IOPT.NE.0.AND.ABS(XXMIRR).LE.20.0)THEN R2PLAN=(SINH(XXMIRR)**2+SIN(YY)**2)/ - (SINH(XXMIRR)**2+SIN(YYNEG)**2) R2=R2/R2PLAN ENDIF ENDIF *** Calculate the electric field and the potential. EX=EX+E(I)*(0.5*PI/SY)*REAL(ECOMPL) EY=EY-E(I)*(0.5*PI/SY)*AIMAG(ECOMPL) IF(IOPT.NE.0)VOLT=VOLT-0.5*E(I)*LOG(R2) *** Finish the wire loop. 10 CONTINUE END +DECK,E3DB2Y. SUBROUTINE E3DB2Y(XPOS,YPOS,ZPOS,EX,EY,EZ,VOLT) *----------------------------------------------------------------------- * E3DB2Y - Routine calculating the potential for a 3 dimensional point * charge between two plates at constant y. * The series expansions for the modified Bessel functions * have been taken from Abramowitz and Stegun. * VARIABLES : See routine E3DA00 for most of the variables. * (Last changed on 5/12/94.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,CONSTANTS. DOUBLE PRECISION EXSUM,EYSUM,EZSUM,VSUM, - I0S,I1S,K0S,K0L,K1S,K1L,K0R,K1R,K0RM,K1RM, - XX,RR,RRM,ZZP,ZZN,RR1,RR2,RM1,RM2,ERR,EZZ REAL XPOS,YPOS,ZPOS,EX,EY,EZ,VOLT,RCUT PARAMETER(RCUT=1.0) *** Statement functions for the modified Bessel functions: I0S(XX)=1 - +3.5156229*(XX/3.75)**2 - +3.0899424*(XX/3.75)**4 - +1.2067492*(XX/3.75)**6 - +0.2659732*(XX/3.75)**8 - +0.0360768*(XX/3.75)**10 - +0.0045813*(XX/3.75)**12 I1S(XX)=XX*( - +0.5 - +0.87890594*(XX/3.75)**2 - +0.51498869*(XX/3.75)**4 - +0.15084934*(XX/3.75)**6 - +0.02658733*(XX/3.75)**8 - +0.00301532*(XX/3.75)**10 - +0.00032411*(XX/3.75)**12) K0S(XX)=-LOG(XX/2)*I0S(XX) - -0.57721566 - +0.42278420*(XX/2)**2 - +0.23069756*(XX/2)**4 - +0.03488590*(XX/2)**6 - +0.00262698*(XX/2)**8 - +0.00010750*(XX/2)**10 - +0.00000740*(XX/2)**12 K0L(XX)=(EXP(-XX)/SQRT(XX))*( - +1.25331414 - -0.07832358*(2/XX) - +0.02189568*(2/XX)**2 - -0.01062446*(2/XX)**3 - +0.00587872*(2/XX)**4 - -0.00251540*(2/XX)**5 - +0.00053208*(2/XX)**6) K1S(XX)=LOG(XX/2)*I1S(XX)+(1/XX)*( - +1 - +0.15443144*(XX/2)**2 - -0.67278579*(XX/2)**4 - -0.18156897*(XX/2)**6 - -0.01919402*(XX/2)**8 - -0.00110404*(XX/2)**10 - -0.00004686*(XX/2)**12) K1L(XX)=(EXP(-XX)/SQRT(XX))*( - +1.25331414 - +0.23498619*(2/XX) - -0.03655620*(2/XX)**2 - +0.01504268*(2/XX)**3 - -0.00780353*(2/XX)**4 - +0.00325614*(2/XX)**5 - -0.00068245*(2/XX)**6) *** Initialise the sums for the field components. EX=0.0 EY=0.0 EZ=0.0 VOLT=0.0 *** Loop over all wires. DO 10 I=1,N3D * Skip wires that are on the charge. IF(XPOS.EQ.X3D(I).AND.YPOS.EQ.Y3D(I).AND.ZPOS.EQ.Z3D(I))GOTO 10 *** In the far away zone, sum the modified Bessel function series. IF((XPOS-X3D(I))**2+(ZPOS-Z3D(I))**2.GT.(RCUT*2*SY)**2)THEN * Initialise the per-wire sum. EXSUM=0.0 EYSUM=0.0 EZSUM=0.0 VSUM=0.0 * Loop over the terms in the series. DO 20 J=1,NTERMB * Obtain reduced coordinates. RR=PI*J*SQRT((XPOS-X3D(I))**2+(ZPOS-Z3D(I))**2)/SY ZZP=PI*J*(YPOS-Y3D(I))/SY ZZN=PI*J*(YPOS+Y3D(I)-2*COPLAY)/SY * Evaluate the Bessel functions for this R. IF(RR.LT.2)THEN K0R=K0S(RR) K1R=K1S(RR) ELSE K0R=K0L(RR) K1R=K1L(RR) ENDIF * Get the field components. VSUM=VSUM+(1/SY)*K0R*(COS(ZZP)-COS(ZZN)) ERR=(2*J*PI/SY**2)*K1R*(COS(ZZP)-COS(ZZN)) EZZ=(2*J*PI/SY**2)*K0R*(SIN(ZZP)-SIN(ZZN)) EXSUM=EXSUM+ERR*(XPOS-X3D(I))/ - SQRT((XPOS-X3D(I))**2+(ZPOS-Z3D(I))**2) EYSUM=EYSUM+EZZ EZSUM=EZSUM+ERR*(ZPOS-Z3D(I))/ - SQRT((XPOS-X3D(I))**2+(ZPOS-Z3D(I))**2) 20 CONTINUE *** Direct polynomial summing, obtain reduced coordinates. ELSE * Loop over the terms. DO 30 J=0,NTERMP * Simplify the references to the distances. RR1=SQRT((XPOS-X3D(I))**2+(YPOS-Y3D(I)+J*2*SY)**2+ - (ZPOS-Z3D(I))**2) RR2=SQRT((XPOS-X3D(I))**2+(YPOS-Y3D(I)-J*2*SY)**2+ - (ZPOS-Z3D(I))**2) RM1=SQRT((XPOS-X3D(I))**2+ - (YPOS+Y3D(I)-J*2*SY-2*COPLAY)**2+(ZPOS-Z3D(I))**2) RM2=SQRT((XPOS-X3D(I))**2+ - (YPOS+Y3D(I)+J*2*SY-2*COPLAY)**2+(ZPOS-Z3D(I))**2) * Initialisation of the sum: only a charge and a mirror charge. IF(J.EQ.0)THEN VSUM=1/RR1-1/RM1 EXSUM=(XPOS-X3D(I))*(1/RR1**3-1/RM1**3) EYSUM=(YPOS-Y3D(I))/RR1**3- - (YPOS+Y3D(I)-2*COPLAY)/RM1**3 EZSUM=(ZPOS-Z3D(I))*(1/RR1**3-1/RM1**3) * Further terms in the series: 2 charges and 2 mirror charges. ELSE VSUM=VSUM+1/RR1+1/RR2-1/RM1-1/RM2 EXSUM=EXSUM+(XPOS-X3D(I))* - (1/RR1**3+1/RR2**3-1/RM1**3-1/RM2**3) EYSUM=EYSUM+ - (YPOS-Y3D(I)+J*2*SY)/RR1**3+ - (YPOS-Y3D(I)-J*2*SY)/RR2**3- - (YPOS+Y3D(I)-J*2*SY-2*COPLAY)/RM1**3- - (YPOS+Y3D(I)+J*2*SY-2*COPLAY)/RM2**3 EZSUM=EZSUM+(ZPOS-Z3D(I))* - (1/RR1**3+1/RR2**3-1/RM1**3-1/RM2**3) ENDIF 30 CONTINUE ENDIF *** Take care of a planes at constant x. IF(YNPLAX)THEN *** Bessel function series. IF((XPOS+X3D(I)-2*COPLAX)**2+(ZPOS-Z3D(I))**2.GT. - (RCUT*2*SY)**2)THEN * Loop over the terms in the series. DO 40 J=1,NTERMB * Obtain reduced coordinates. RRM=PI*J*SQRT((XPOS+X3D(I)-2*COPLAX)**2+ - (ZPOS-Z3D(I))**2)/SY ZZP=PI*J*(YPOS-Y3D(I))/SY ZZN=PI*J*(YPOS+Y3D(I)-2*COPLAY)/SY * Evaluate the Bessel functions for this R. IF(RRM.LT.2)THEN K0RM=K0S(RRM) K1RM=K1S(RRM) ELSE K0RM=K0L(RRM) K1RM=K1L(RRM) ENDIF * Get the field components. VSUM=VSUM+(1/SY)*K0RM*(COS(ZZP)-COS(ZZN)) ERR=(2*PI/SY**2)*K1RM*(COS(ZZP)-COS(ZZN)) EZZ=(2*PI/SY**2)*K0RM*(SIN(ZZP)-SIN(ZZN)) EXSUM=EXSUM+ERR*(XPOS+X3D(I)-2*COPLAX)/ - SQRT((XPOS+X3D(I)-2*COPLAX)**2+(ZPOS-Z3D(I))**2) EYSUM=EYSUM+EZZ EZSUM=EZSUM+ERR*(ZPOS-Z3D(I))/ - SQRT((XPOS+X3D(I)-2*COPLAX)**2+(ZPOS-Z3D(I))**2) 40 CONTINUE *** Polynomial sum. ELSE * Loop over the terms. DO 50 J=0,NTERMP * Simplify the references to the distances. RR1=SQRT((YPOS-Y3D(I)+J*2*SY)**2+ - (XPOS+X3D(I)-2*COPLAX)**2+(ZPOS-Z3D(I))**2) RR2=SQRT((YPOS-Y3D(I)-J*2*SY)**2+ - (XPOS+X3D(I)-2*COPLAX)**2+(ZPOS-Z3D(I))**2) RM1=SQRT((YPOS+Y3D(I)-J*2*SY-2*COPLAY)**2+ - (XPOS+X3D(I)-2*COPLAX)**2+(ZPOS-Z3D(I))**2) RM2=SQRT((YPOS+Y3D(I)+J*2*SY-2*COPLAY)**2+ - (XPOS+X3D(I)-2*COPLAX)**2+(ZPOS-Z3D(I))**2) * Initialisation of the sum: only a charge and a mirror charge. IF(J.EQ.0)THEN VSUM=VSUM-1/RR1+1/RM1 EXSUM=EXSUM-(XPOS+X3D(I)-2*COPLAX)* - (1/RR1**3-1/RM1**3) EYSUM=EYSUM-(YPOS-Y3D(I))/RR1**3+ - (YPOS+Y3D(I)-2*COPLAY)/RM1**3 EZSUM=EZSUM-(ZPOS-Z3D(I))*(1/RR1**3-1/RM1**3) * Further terms in the series: 2 charges and 2 mirror charges. ELSE VSUM=VSUM-1/RR1-1/RR2+1/RM1+1/RM2 EXSUM=EXSUM-(XPOS+X3D(I)-2*COPLAX)* - (1/RR1**3+1/RR2**3-1/RM1**3-1/RM2**3) EYSUM=EYSUM- - (YPOS-Y3D(I)+J*2*SY)/RR1**3- - (YPOS-Y3D(I)-J*2*SY)/RR2**3+ - (YPOS+Y3D(I)-J*2*SY-2*COPLAY)/RM1**3+ - (YPOS+Y3D(I)+J*2*SY-2*COPLAY)/RM2**3 EZSUM=EZSUM-(ZPOS-Z3D(I))* - (1/RR1**3+1/RR2**3-1/RM1**3-1/RM2**3) ENDIF 50 CONTINUE ENDIF ENDIF *** Convert the double precision sum to single precision. EX=EX+E3D(I)*REAL(EXSUM) EY=EY+E3D(I)*REAL(EYSUM) EZ=EZ+E3D(I)*REAL(EZSUM) VOLT=VOLT+E3D(I)*REAL(VSUM) *** Finish the loop over the charges. 10 CONTINUE END +DECK,EFCC10. SUBROUTINE EFCC10(XPOS,YPOS,EX,EY,VOLT,IOPT) *----------------------------------------------------------------------- * EFCC10 - Routine returning the potential and electric field. It * calls the routines PH2 and E2SUM written by G.A.Erskine. * VARIABLES : No local variables. *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,CELLDATA. *** Calculate voltage first, if needed. IF(IOPT.NE.0)THEN IF(MODE.EQ.0)VOLT=V0+C1*XPOS IF(MODE.EQ.1)VOLT=V0+C1*YPOS DO 10 I=1,NWIRE VOLT=VOLT+E(I)*PH2(XPOS-X(I),YPOS-Y(I)) 10 CONTINUE ENDIF *** And finally the electric field. CALL E2SUM(XPOS,YPOS,EX,EY) IF(MODE.EQ.0)EX=EX-C1 IF(MODE.EQ.1)EY=EY-C1 END +DECK,EFCC2X. SUBROUTINE EFCC2X(XPOS,YPOS,EX,EY,VOLT,IOPT) *----------------------------------------------------------------------- * EFCC2X - Routine returning the potential and electric field in a * configuration with 2 x planes and y periodicity. * VARIABLES : see the writeup *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,CONSTANTS. COMPLEX WSUM1,WSUM2,ZSIN,ZCOF,ZU,ZUNEW,ZTERM1,ZTERM2,ZETA *** Initial values. WSUM1=0 WSUM2=0 VOLT=0.0 *** Wire loop. DO 10 I=1,NWIRE * Compute the direct contribution. ZETA=ZMULT*CMPLX(XPOS-X(I),YPOS-Y(I)) IF(AIMAG(ZETA).GT.+15.0)THEN WSUM1=WSUM1-E(I)*ICONS IF(IOPT.NE.0)VOLT=VOLT-E(I)*(ABS(AIMAG(ZETA))-CLOG2) ELSEIF(AIMAG(ZETA).LT.-15.0)THEN WSUM1=WSUM1+E(I)*ICONS IF(IOPT.NE.0)VOLT=VOLT-E(I)*(ABS(AIMAG(ZETA))-CLOG2) ELSE ZSIN=SIN(ZETA) ZCOF=4.0*ZSIN**2-2.0 ZU=-P1-ZCOF*P2 ZUNEW=1.0-ZCOF*ZU-P2 ZTERM1=(ZUNEW+ZU)*ZSIN ZU=-3.0*P1-ZCOF*5.0*P2 ZUNEW=1.0-ZCOF*ZU-5.0*P2 ZTERM2=(ZUNEW-ZU)*COS(ZETA) WSUM1=WSUM1+E(I)*(ZTERM2/ZTERM1) IF(IOPT.NE.0)VOLT=VOLT-E(I)*LOG(CABS(ZTERM1)) ENDIF * Find the plane nearest to the wire. CX=COPLAX-SX*ANINT((COPLAX-X(I))/SX) * Mirror contribution. ZETA=ZMULT*CMPLX(2*CX-XPOS-X(I),YPOS-Y(I)) IF(AIMAG(ZETA).GT.+15.0)THEN WSUM2=WSUM2-E(I)*ICONS IF(IOPT.NE.0)VOLT=VOLT+E(I)*(ABS(AIMAG(ZETA))-CLOG2) ELSEIF(AIMAG(ZETA).LT.-15.0)THEN WSUM2=WSUM2+E(I)*ICONS IF(IOPT.NE.0)VOLT=VOLT+E(I)*(ABS(AIMAG(ZETA))-CLOG2) ELSE ZSIN=SIN(ZETA) ZCOF=4.0*ZSIN**2-2.0 ZU=-P1-ZCOF*P2 ZUNEW=1.0-ZCOF*ZU-P2 ZTERM1=(ZUNEW+ZU)*ZSIN ZU=-3.0*P1-ZCOF*5.0*P2 ZUNEW=1.0-ZCOF*ZU-5.0*P2 ZTERM2=(ZUNEW-ZU)*COS(ZETA) WSUM2=WSUM2+E(I)*(ZTERM2/ZTERM1) IF(IOPT.NE.0)VOLT=VOLT+E(I)*LOG(CABS(ZTERM1)) ENDIF * Correct the voltage, if needed (MODE). IF(IOPT.NE.0.AND.MODE.EQ.0)VOLT=VOLT- - 2*E(I)*PI*(XPOS-CX)*(X(I)-CX)/(SX*SY) 10 CONTINUE *** Convert the two contributions to a real field. EX=REAL(ZMULT*(WSUM1+WSUM2)) EY=-AIMAG(ZMULT*(WSUM1-WSUM2)) *** Constant correction terms. IF(MODE.EQ.0)EX=EX-C1 END +DECK,EFCC2Y. SUBROUTINE EFCC2Y(XPOS,YPOS,EX,EY,VOLT,IOPT) *----------------------------------------------------------------------- * EFCC2Y - Routine returning the potential and electric field in a * configuration with 2 y planes and x periodicity. * VARIABLES : see the writeup *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,CONSTANTS. COMPLEX WSUM1,WSUM2,ZSIN,ZCOF,ZU,ZUNEW,ZTERM1,ZTERM2,ZETA *** Initial values. WSUM1=0 WSUM2=0 VOLT=0.0 *** Wire loop. DO 10 I=1,NWIRE * Compute the direct contribution. ZETA=ZMULT*CMPLX(XPOS-X(I),YPOS-Y(I)) IF(AIMAG(ZETA).GT.+15.0)THEN WSUM1=WSUM1-E(I)*ICONS IF(IOPT.NE.0)VOLT=VOLT-E(I)*(ABS(AIMAG(ZETA))-CLOG2) ELSEIF(AIMAG(ZETA).LT.-15.0)THEN WSUM1=WSUM1+E(I)*ICONS IF(IOPT.NE.0)VOLT=VOLT-E(I)*(ABS(AIMAG(ZETA))-CLOG2) ELSE ZSIN=SIN(ZETA) ZCOF=4.0*ZSIN**2-2.0 ZU=-P1-ZCOF*P2 ZUNEW=1.0-ZCOF*ZU-P2 ZTERM1=(ZUNEW+ZU)*ZSIN ZU=-3.0*P1-ZCOF*5.0*P2 ZUNEW=1.0-ZCOF*ZU-5.0*P2 ZTERM2=(ZUNEW-ZU)*COS(ZETA) WSUM1=WSUM1+E(I)*(ZTERM2/ZTERM1) IF(IOPT.NE.0)VOLT=VOLT-E(I)*LOG(CABS(ZTERM1)) ENDIF * Find the plane nearest to the wire. CY=COPLAY-SY*ANINT((COPLAY-Y(I))/SY) * Mirror contribution from the y plane. ZETA=ZMULT*CMPLX(XPOS-X(I),2.0*CY-YPOS-Y(I)) IF(AIMAG(ZETA).GT.+15.0)THEN WSUM2=WSUM2-E(I)*ICONS IF(IOPT.NE.0)VOLT=VOLT+E(I)*(ABS(AIMAG(ZETA))-CLOG2) ELSEIF(AIMAG(ZETA).LT.-15.0)THEN WSUM2=WSUM2+E(I)*ICONS IF(IOPT.NE.0)VOLT=VOLT+E(I)*(ABS(AIMAG(ZETA))-CLOG2) ELSE ZSIN=SIN(ZETA) ZCOF=4.0*ZSIN**2-2.0 ZU=-P1-ZCOF*P2 ZUNEW=1.0-ZCOF*ZU-P2 ZTERM1=(ZUNEW+ZU)*ZSIN ZU=-3.0*P1-ZCOF*5.0*P2 ZUNEW=1.0-ZCOF*ZU-5.0*P2 ZTERM2=(ZUNEW-ZU)*COS(ZETA) WSUM2=WSUM2+E(I)*(ZTERM2/ZTERM1) IF(IOPT.NE.0)VOLT=VOLT+E(I)*LOG(CABS(ZTERM1)) ENDIF * Correct the voltage, if needed (MODE). IF(IOPT.NE.0.AND.MODE.EQ.1)VOLT=VOLT- - 2*E(I)*PI*(YPOS-CY)*(Y(I)-CY)/(SX*SY) 10 CONTINUE *** Convert the two contributions to a real field. EX=REAL(ZMULT*(WSUM1-WSUM2)) EY=-AIMAG(ZMULT*(WSUM1+WSUM2)) *** Constant correction terms. IF(MODE.EQ.1)EY=EY-C1 END +DECK,EFCC30. SUBROUTINE EFCC30(XPOS,YPOS,EX,EY,VOLT,IOPT) *----------------------------------------------------------------------- * EFCC30 - Routine returning the potential and electric field in a * configuration with 2 y and 2 x planes. * VARIABLES : see the writeup *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,CONSTANTS. COMPLEX WSUM1,WSUM2,WSUM3,WSUM4,ZSIN,ZCOF,ZU,ZUNEW, - ZTERM1,ZTERM2,ZETA *** Initial values. WSUM1=0 WSUM2=0 WSUM3=0 WSUM4=0 VOLT=0.0 *** Wire loop. DO 10 I=1,NWIRE * Compute the direct contribution. ZETA=ZMULT*CMPLX(XPOS-X(I),YPOS-Y(I)) IF(AIMAG(ZETA).GT.+15.0)THEN WSUM1=WSUM1-E(I)*ICONS IF(IOPT.NE.0)VOLT=VOLT-E(I)*(ABS(AIMAG(ZETA))-CLOG2) ELSEIF(AIMAG(ZETA).LT.-15.0)THEN WSUM1=WSUM1+E(I)*ICONS IF(IOPT.NE.0)VOLT=VOLT-E(I)*(ABS(AIMAG(ZETA))-CLOG2) ELSE ZSIN=SIN(ZETA) ZCOF=4.0*ZSIN**2-2.0 ZU=-P1-ZCOF*P2 ZUNEW=1.0-ZCOF*ZU-P2 ZTERM1=(ZUNEW+ZU)*ZSIN ZU=-3.0*P1-ZCOF*5.0*P2 ZUNEW=1.0-ZCOF*ZU-5.0*P2 ZTERM2=(ZUNEW-ZU)*COS(ZETA) WSUM1=WSUM1+E(I)*(ZTERM2/ZTERM1) IF(IOPT.NE.0)VOLT=VOLT-E(I)*LOG(CABS(ZTERM1)) ENDIF * Find the plane nearest to the wire. CX=COPLAX-SX*ANINT((COPLAX-X(I))/SX) * Mirror contribution from the x plane. ZETA=ZMULT*CMPLX(2*CX-XPOS-X(I),YPOS-Y(I)) IF(AIMAG(ZETA).GT.+15.0)THEN WSUM2=WSUM2-E(I)*ICONS IF(IOPT.NE.0)VOLT=VOLT+E(I)*(ABS(AIMAG(ZETA))-CLOG2) ELSEIF(AIMAG(ZETA).LT.-15.0)THEN WSUM2=WSUM2+E(I)*ICONS IF(IOPT.NE.0)VOLT=VOLT+E(I)*(ABS(AIMAG(ZETA))-CLOG2) ELSE ZSIN=SIN(ZETA) ZCOF=4.0*ZSIN**2-2.0 ZU=-P1-ZCOF*P2 ZUNEW=1.0-ZCOF*ZU-P2 ZTERM1=(ZUNEW+ZU)*ZSIN ZU=-3.0*P1-ZCOF*5.0*P2 ZUNEW=1.0-ZCOF*ZU-5.0*P2 ZTERM2=(ZUNEW-ZU)*COS(ZETA) WSUM2=WSUM2+E(I)*(ZTERM2/ZTERM1) IF(IOPT.NE.0)VOLT=VOLT+E(I)*LOG(CABS(ZTERM1)) ENDIF * Find the plane nearest to the wire. CY=COPLAY-SY*ANINT((COPLAY-Y(I))/SY) * Mirror contribution from the y plane. ZETA=ZMULT*CMPLX(XPOS-X(I),2.0*CY-YPOS-Y(I)) IF(AIMAG(ZETA).GT.+15.0)THEN WSUM3=WSUM3-E(I)*ICONS IF(IOPT.NE.0)VOLT=VOLT+E(I)*(ABS(AIMAG(ZETA))-CLOG2) ELSEIF(AIMAG(ZETA).LT.-15.0)THEN WSUM3=WSUM3+E(I)*ICONS IF(IOPT.NE.0)VOLT=VOLT+E(I)*(ABS(AIMAG(ZETA))-CLOG2) ELSE ZSIN=SIN(ZETA) ZCOF=4.0*ZSIN**2-2.0 ZU=-P1-ZCOF*P2 ZUNEW=1.0-ZCOF*ZU-P2 ZTERM1=(ZUNEW+ZU)*ZSIN ZU=-3.0*P1-ZCOF*5.0*P2 ZUNEW=1.0-ZCOF*ZU-5.0*P2 ZTERM2=(ZUNEW-ZU)*COS(ZETA) WSUM3=WSUM3+E(I)*(ZTERM2/ZTERM1) IF(IOPT.NE.0)VOLT=VOLT+E(I)*LOG(CABS(ZTERM1)) ENDIF * Mirror contribution from both the x and the y plane. ZETA=ZMULT*CMPLX(2.0*CX-XPOS-X(I),2.0*CY-YPOS-Y(I)) IF(AIMAG(ZETA).GT.+15.0)THEN WSUM4=WSUM4-E(I)*ICONS IF(IOPT.NE.0)VOLT=VOLT-E(I)*(ABS(AIMAG(ZETA))-CLOG2) ELSEIF(AIMAG(ZETA).LT.-15.0)THEN WSUM4=WSUM4+E(I)*ICONS IF(IOPT.NE.0)VOLT=VOLT-E(I)*(ABS(AIMAG(ZETA))-CLOG2) ELSE ZSIN=SIN(ZETA) ZCOF=4.0*ZSIN**2-2.0 ZU=-P1-ZCOF*P2 ZUNEW=1.0-ZCOF*ZU-P2 ZTERM1=(ZUNEW+ZU)*ZSIN ZU=-3.0*P1-ZCOF*5.0*P2 ZUNEW=1.0-ZCOF*ZU-5.0*P2 ZTERM2=(ZUNEW-ZU)*COS(ZETA) WSUM4=WSUM4+E(I)*(ZTERM2/ZTERM1) IF(IOPT.NE.0)VOLT=VOLT-E(I)*LOG(CABS(ZTERM1)) ENDIF 10 CONTINUE *** Convert the two contributions to a real field. EX=+REAL(ZMULT*(WSUM1+WSUM2-WSUM3-WSUM4)) EY=-AIMAG(ZMULT*(WSUM1-WSUM2+WSUM3-WSUM4)) END +DECK,EFCD10,IF=NEVER. SUBROUTINE EFCD10(XPOS,YPOS,EX,EY,VOLT,IOPT) *----------------------------------------------------------------------- * EFCD10 - Subroutine performing the actual field calculations for a * cell which has a one circular plane and some wires. * VARIABLES : EX, EY, VOLT:Electric field and potential. * ETOT, VOLT : Magnitude of electric field, potential. * (XPOS,YPOS): The position where the field is calculated. * ZI, ZPOS : Shorthand complex notations. * (Last changed on 30/ 1/93.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,CELLDATA. COMPLEX ZI,ZPOS *** Initialise the potential and the electric field. EX=0.0 EY=0.0 VOLT=V0 * Set the complex position coordinates. ZPOS=CMPLX(XPOS,YPOS) *** Loop over all wires. DO 10 I=1,NWIRE * Set the complex version of the wire-coordinate for simplicity. ZI=CMPLX(X(I),Y(I)) * Compute the contribution to the potential, if needed. IF(IOPT.NE.0)VOLT=VOLT-E(I)*LOG(ABS((1/COTUBE)*(ZPOS-ZI)/ - (1-ZPOS*CONJG(ZI)/COTUBE**2))) * Compute the contribution to the electric field, always. EX=EX+E(I)*REAL(1/CONJG(ZPOS-ZI)+ZI/(COTUBE**2-CONJG(ZPOS)*ZI)) EY=EY+E(I)*AIMAG(1/CONJG(ZPOS-ZI)+ZI/(COTUBE**2-CONJG(ZPOS)*ZI)) *** Finish the loop over the wires. 10 CONTINUE END +DECK,EFCD10. SUBROUTINE EFCD10(XPOS,YPOS,EX,EY,VOLT,IOPT) *----------------------------------------------------------------------- * EFCD10 - Subroutine performing the actual field calculations for a * cell which has a one circular plane and some wires. * VARIABLES : EX, EY, VOLT:Electric field and potential. * ETOT, VOLT : Magnitude of electric field, potential. * (XPOS,YPOS): The position where the field is calculated. * ZI, ZPOS : Shorthand complex notations. * (Last changed on 4/ 9/95.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,CELLDATA. COMPLEX ZI,ZPOS *** Initialise the potential and the electric field. EX=0.0 EY=0.0 VOLT=V0 * Set the complex position coordinates. ZPOS=CMPLX(XPOS,YPOS) *** Loop over all wires. DO 10 I=1,NWIRE * Set the complex version of the wire-coordinate for simplicity. ZI=CMPLX(X(I),Y(I)) * Compute the contribution to the potential, if needed. IF(IOPT.NE.0)VOLT=VOLT-E(I)*LOG(ABS(COTUBE*(ZPOS-ZI)/ - (COTUBE**2-ZPOS*CONJG(ZI)))) * Compute the contribution to the electric field, always. EX=EX+E(I)*REAL(1/CONJG(ZPOS-ZI)+ZI/(COTUBE**2-CONJG(ZPOS)*ZI)) EY=EY+E(I)*AIMAG(1/CONJG(ZPOS-ZI)+ZI/(COTUBE**2-CONJG(ZPOS)*ZI)) *** Finish the loop over the wires. 10 CONTINUE END +DECK,E3DD10. SUBROUTINE E3DD10(XXPOS,YYPOS,ZZPOS,EEX,EEY,EEZ,VOLT) *----------------------------------------------------------------------- * E3DD10 - Subroutine adding 3-dimensional charges to tubes with one * wire running down the centre. * The series expansions for the modified Bessel functions * have been taken from Abramowitz and Stegun. * VARIABLES : See routine E3DA00 for most of the variables. * (Last changed on 25/11/95.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,CONSTANTS. DOUBLE PRECISION EXSUM,EYSUM,EZSUM,VSUM, - I0S,I1S,K0S,K0L,K1S,K1L,K0R,K1R, - XX,RR,ZZP,ZZN,RR1,RR2,RM1,RM2,ERR,EZZ REAL XPOS,YPOS,ZPOS,EX,EY,EZ,VOLT,RCUT PARAMETER(RCUT=1.0) *** Statement functions for the modified Bessel functions: I0S(XX)=1 - +3.5156229*(XX/3.75)**2 - +3.0899424*(XX/3.75)**4 - +1.2067492*(XX/3.75)**6 - +0.2659732*(XX/3.75)**8 - +0.0360768*(XX/3.75)**10 - +0.0045813*(XX/3.75)**12 I1S(XX)=XX*( - +0.5 - +0.87890594*(XX/3.75)**2 - +0.51498869*(XX/3.75)**4 - +0.15084934*(XX/3.75)**6 - +0.02658733*(XX/3.75)**8 - +0.00301532*(XX/3.75)**10 - +0.00032411*(XX/3.75)**12) K0S(XX)=-LOG(XX/2)*I0S(XX) - -0.57721566 - +0.42278420*(XX/2)**2 - +0.23069756*(XX/2)**4 - +0.03488590*(XX/2)**6 - +0.00262698*(XX/2)**8 - +0.00010750*(XX/2)**10 - +0.00000740*(XX/2)**12 K0L(XX)=(EXP(-XX)/SQRT(XX))*( - +1.25331414 - -0.07832358*(2/XX) - +0.02189568*(2/XX)**2 - -0.01062446*(2/XX)**3 - +0.00587872*(2/XX)**4 - -0.00251540*(2/XX)**5 - +0.00053208*(2/XX)**6) K1S(XX)=LOG(XX/2)*I1S(XX)+(1/XX)*( - +1 - +0.15443144*(XX/2)**2 - -0.67278579*(XX/2)**4 - -0.18156897*(XX/2)**6 - -0.01919402*(XX/2)**8 - -0.00110404*(XX/2)**10 - -0.00004686*(XX/2)**12) K1L(XX)=(EXP(-XX)/SQRT(XX))*( - +1.25331414 - +0.23498619*(2/XX) - -0.03655620*(2/XX)**2 - +0.01504268*(2/XX)**3 - -0.00780353*(2/XX)**4 - +0.00325614*(2/XX)**5 - -0.00068245*(2/XX)**6) *** Initialise the sums for the field components. EX=0.0 EEX=0.0 EY=0.0 EEY=0.0 EZ=0.0 EEZ=0.0 VOLT=0.0 *** Ensure that the routine can actually work. IF(NWIRE.LT.1)THEN PRINT *,' Inappropriate potential function.' RETURN ENDIF *** Define a periodicity and one plane in the mapped frame. SSX=LOG(2*COTUBE/D(1)) CPL=LOG(D(1)/2) *** Transform the coordinates to the mapped frame. XPOS=0.5*LOG(XXPOS**2+YYPOS**2) YPOS=ATAN2(YYPOS,XXPOS) ZPOS=ZZPOS *** Loop over all point charges. DO 10 I=1,N3D DO 40 II=-1,1 XX3D=0.5*LOG(X3D(I)**2+Y3D(I)**2) YY3D=ATAN2(Y3D(I),X3D(I))+II*2*PI ZZ3D=Z3D(I) * Skip wires that are on the charge. IF(XPOS.EQ.XX3D.AND.YPOS.EQ.YY3D.AND.ZPOS.EQ.ZZ3D)GOTO 40 *** In the far away zone, sum the modified Bessel function series. IF((YPOS-YY3D)**2+(ZPOS-ZZ3D)**2.GT.(RCUT*2*SSX)**2)THEN * Initialise the per-wire sum. EXSUM=0.0 EYSUM=0.0 EZSUM=0.0 VSUM=0.0 * Loop over the terms in the series. DO 20 J=1,NTERMB * Obtain reduced coordinates. RR=PI*J*SQRT((YPOS-YY3D)**2+(ZPOS-ZZ3D)**2)/SSX ZZP=PI*J*(XPOS-XX3D)/SSX ZZN=PI*J*(XPOS+XX3D-2*CPL)/SSX * Evaluate the Bessel functions for this R. IF(RR.LT.2)THEN K0R=K0S(RR) K1R=K1S(RR) ELSE K0R=K0L(RR) K1R=K1L(RR) ENDIF * Get the field components. VSUM=VSUM+(1/SSX)*K0R*(COS(ZZP)-COS(ZZN)) ERR=(2*J*PI/SSX**2)*K1R*(COS(ZZP)-COS(ZZN)) EZZ=(2*J*PI/SSX**2)*K0R*(SIN(ZZP)-SIN(ZZN)) EXSUM=EXSUM+EZZ EYSUM=EYSUM+ERR*(YPOS-YY3D)/ - SQRT((YPOS-YY3D)**2+(ZPOS-ZZ3D)**2) EZSUM=EZSUM+ERR*(ZPOS-ZZ3D)/ - SQRT((YPOS-YY3D)**2+(ZPOS-ZZ3D)**2) 20 CONTINUE *** Direct polynomial summing, obtain reduced coordinates. ELSE * Loop over the terms. DO 30 J=0,NTERMP * Simplify the references to the distances. RR1=SQRT((XPOS-XX3D+J*2*SSX)**2+(YPOS-YY3D)**2+ - (ZPOS-ZZ3D)**2) RR2=SQRT((XPOS-XX3D-J*2*SSX)**2+(YPOS-YY3D)**2+ - (ZPOS-ZZ3D)**2) RM1=SQRT((XPOS+XX3D-J*2*SSX-2*CPL)**2+ - (YPOS-YY3D)**2+(ZPOS-ZZ3D)**2) RM2=SQRT((XPOS+XX3D+J*2*SSX-2*CPL)**2+ - (YPOS-YY3D)**2+(ZPOS-ZZ3D)**2) * Initialisation of the sum: only a charge and a mirror charge. IF(J.EQ.0)THEN VSUM=1/RR1-1/RM1 EXSUM=(XPOS-XX3D)/RR1**3- - (XPOS+XX3D-2*CPL)/RM1**3 EYSUM=(YPOS-YY3D)*(1/RR1**3-1/RM1**3) EZSUM=(ZPOS-ZZ3D)*(1/RR1**3-1/RM1**3) * Further terms in the series: 2 charges and 2 mirror charges. ELSE VSUM=VSUM+1/RR1+1/RR2-1/RM1-1/RM2 EXSUM=EXSUM+ - (XPOS-XX3D+J*2*SSX)/RR1**3+ - (XPOS-XX3D-J*2*SSX)/RR2**3- - (XPOS+XX3D-J*2*SSX-2*CPL)/RM1**3- - (XPOS+XX3D+J*2*SSX-2*CPL)/RM2**3 EYSUM=EYSUM+(YPOS-YY3D)* - (1/RR1**3+1/RR2**3-1/RM1**3-1/RM2**3) EZSUM=EZSUM+(ZPOS-ZZ3D)* - (1/RR1**3+1/RR2**3-1/RM1**3-1/RM2**3) ENDIF 30 CONTINUE ENDIF *** Convert the double precision sum to single precision. EX=EX+E3D(I)*REAL(EXSUM) EY=EY+E3D(I)*REAL(EYSUM) EZ=EZ+E3D(I)*REAL(EZSUM) VOLT=VOLT+E3D(I)*REAL(VSUM) *** Finish the loop over the charges. 40 CONTINUE 10 CONTINUE *** Transform the field vectors back to Cartesian coordinates. EEX=EXP(-XPOS)*(+EX*COS(YPOS)-EY*SIN(YPOS)) EEY=EXP(-XPOS)*(+EX*SIN(YPOS)+EY*COS(YPOS)) EEZ=EZ END +DECK,EFCD20. SUBROUTINE EFCD20(XPOS,YPOS,EX,EY,VOLT,IOPT) *----------------------------------------------------------------------- * EFCD20 - Subroutine performing the actual field calculations for a * cell which has a tube and phi periodicity. * VARIABLES : EX, EY, VOLT:Electric field and potential. * ETOT, VOLT : Magnitude of electric field, potential. * (XPOS,YPOS): The position where the field is calculated. * ZI, ZPOS : Shorthand complex notations. * (Last changed on 10/ 2/93.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,CELLDATA. COMPLEX ZI,ZPOS *** Initialise the potential and the electric field. EX=0.0 EY=0.0 VOLT=V0 * Set the complex position coordinates. ZPOS=CMPLX(XPOS,YPOS) *** Loop over all wires. DO 10 I=1,NWIRE * Set the complex version of the wire-coordinate for simplicity. ZI=CMPLX(X(I),Y(I)) * Case of the wire which is not in the centre. IF(ABS(ZI).GT.D(I)/2)THEN * Compute the contribution to the potential, if needed. IF(IOPT.NE.0)VOLT=VOLT-E(I)*LOG(ABS((1/COTUBE**MTUBE)* - (ZPOS**MTUBE-ZI**MTUBE)/ - (1-(ZPOS*CONJG(ZI)/COTUBE**2)**MTUBE))) * Compute the contribution to the electric field, always. EX=EX+E(I)*REAL(MTUBE*CONJG(ZPOS)**(MTUBE-1)* - (1/CONJG(ZPOS**MTUBE-ZI**MTUBE)+ZI**MTUBE/ - (COTUBE**(2*MTUBE)-(CONJG(ZPOS)*ZI)**MTUBE))) EY=EY+E(I)*AIMAG(MTUBE*CONJG(ZPOS)**(MTUBE-1)* - (1/CONJG(ZPOS**MTUBE-ZI**MTUBE)+ZI**MTUBE/ - (COTUBE**(2*MTUBE)-(CONJG(ZPOS)*ZI)**MTUBE))) ELSE * Case of the central wire. IF(IOPT.NE.0)VOLT=VOLT-E(I)*LOG(ABS((1/COTUBE)*(ZPOS-ZI)/ - (1-ZPOS*CONJG(ZI)/COTUBE**2))) * Compute the contribution to the electric field, always. EX=EX+E(I)*REAL(1/CONJG(ZPOS-ZI)+ZI/ - (COTUBE**2-CONJG(ZPOS)*ZI)) EY=EY+E(I)*AIMAG(1/CONJG(ZPOS-ZI)+ZI/ - (COTUBE**2-CONJG(ZPOS)*ZI)) ENDIF *** Finish the loop over the wires. 10 CONTINUE END +DECK,EFCD30. SUBROUTINE EFCD30(XPOS,YPOS,EX,EY,VOLT,IOPT) *----------------------------------------------------------------------- * EFCD30 - Subroutine performing the actual field calculations for a * cell which has a polygon as tube and some wires. * VARIABLES : EX, EY, VOLT:Electric field and potential. * ETOT, VOLT : Magnitude of electric field, potential. * (XPOS,YPOS): The position where the field is calculated. * ZI, ZPOS : Shorthand complex notations. * (Last changed on 19/ 2/94.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,CELLDATA. COMPLEX WPOS,WDPOS *** Initialise the potential and the electric field. EX=0.0 EY=0.0 VOLT=V0 * Get the mapping of the position. CALL EFCMAP(CMPLX(XPOS,YPOS)/COTUBE,WPOS,WDPOS) *** Loop over all wires. DO 10 I=1,NWIRE * Compute the contribution to the potential, if needed. IF(IOPT.NE.0)VOLT=VOLT-E(I)*LOG(ABS((WPOS-WMAP(I))/ - (1-WPOS*CONJG(WMAP(I))))) * Compute the contribution to the electric field, always. EX=EX+(E(I)/COTUBE)*REAL(WDPOS*(1-ABS(WMAP(I))**2)/ - ((WPOS-WMAP(I))*(1-CONJG(WMAP(I))*WPOS))) EY=EY-(E(I)/COTUBE)*AIMAG(WDPOS*(1-ABS(WMAP(I))**2)/ - ((WPOS-WMAP(I))*(1-CONJG(WMAP(I))*WPOS))) *** Finish the loop over the wires. 10 CONTINUE END +DECK,EFCMAP. SUBROUTINE EFCMAP(Z,WW,WD) *----------------------------------------------------------------------- * EFCMAP - Maps a the interior part of a regular in the unit circle. * Variables: Z - point to be mapped * W - the image of Z * WD - derivative of the mapping at Z * CC1 - coefficients for expansion around centre * CC2 - coefficients for expansion around cornre * (Last changed on 19/ 2/94.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,CONSTANTS. COMPLEX Z,ZZ,WW,WSUM,WD,WDSUM,ZTERM REAL CC1(0:15,3:8),CC2(0:15,3:8) INTEGER NTERM1(3:8),NTERM2(3:8) *** Triangle: coefficients for centre and corner expansion. DATA (CC1(I,3),I=0,15) / - 0.1000000000E+01, -.1666666865E+00, 0.3174602985E-01, - -.5731921643E-02, 0.1040112227E-02, -.1886279933E-03, - 0.3421107249E-04, -.6204730198E-05, 0.1125329618E-05, - -.2040969207E-06, 0.3701631357E-07, -.6713513301E-08, - 0.1217605794E-08, -.2208327132E-09, 0.4005162868E-10, - -.7264017512E-11/ DATA (CC2(I,3),I=0,15) / - 0.3333333135E+00, -.5555555597E-01, 0.1014109328E-01, - -.1837154618E-02, 0.3332451452E-03, -.6043842586E-04, - 0.1096152027E-04, -.1988050826E-05, 0.3605655365E-06, - -.6539443120E-07, 0.1186035448E-07, -.2151069323E-08, - 0.3901317047E-09, -.7075676156E-10, 0.1283289534E-10, - -.2327455936E-11/ *** Square: coefficients for centre and corner expansion. DATA (CC1(I,4),I=0,15) / - 0.1000000000E+01, -.1000000238E+00, 0.8333332837E-02, - -.7051283028E-03, 0.5967194738E-04, -.5049648280E-05, - 0.4273189802E-06, -.3616123934E-07, 0.3060091514E-08, - -.2589557457E-09, 0.2191374859E-10, -.1854418528E-11, - 0.1569274224E-12, -.1327975205E-13, 0.1123779363E-14, - -.9509817570E-16/ DATA (CC2(I,4),I=0,15) / - 0.1000000000E+01, -.5000000000E+00, 0.3000000119E+00, - -.1750000119E+00, 0.1016666889E+00, -.5916666612E-01, - 0.3442307562E-01, -.2002724260E-01, 0.1165192947E-01, - -.6779119372E-02, 0.3944106400E-02, -.2294691978E-02, - 0.1335057430E-02, -.7767395582E-03, 0.4519091453E-03, - -.2629216760E-03/ *** Pentagon: coefficients for centre and corner expansion. DATA (CC1(I,5),I=0,15) / - 0.1000000000E+01, -.6666666269E-01, 0.1212121220E-02, - -.2626262140E-03, -.3322110570E-04, -.9413293810E-05, - -.2570029210E-05, -.7695705904E-06, -.2422486887E-06, - -.7945993730E-07, -.2691839640E-07, -.9361642128E-08, - -.3327319087E-08, -.1204430555E-08, -.4428404310E-09, - -.1650302672E-09/ DATA (CC2(I,5),I=0,15) / - 0.1248050690E+01, -.7788147926E+00, 0.6355384588E+00, - -.4899077415E+00, 0.3713272810E+00, -.2838423252E+00, - 0.2174729109E+00, -.1663445234E+00, 0.1271933913E+00, - -.9728997946E-01, 0.7442557812E-01, -.5692918226E-01, - 0.4354400188E-01, -.3330700099E-01, 0.2547712997E-01, - -.1948769018E-01/ *** Hexagon: coefficients for centre and corner expansion. DATA (CC1(I,6),I=0,15) / - 0.1000000000E+01, -.4761904851E-01, -.1221001148E-02, - -.3753788769E-03, -.9415557724E-04, -.2862767724E-04, - -.9587882232E-05, -.3441659828E-05, -.1299798896E-05, - -.5103651119E-06, -.2066504408E-06, -.8578405186E-07, - -.3635090096E-07, -.1567239494E-07, -.6857355572E-08, - -.3038770346E-08/ DATA (CC2(I,6),I=0,15) / - 0.1333333015E+01, -.8888888955E+00, 0.8395061493E+00, - -.7242798209E+00, 0.6016069055E+00, -.5107235312E+00, - 0.4393203855E+00, -.3745460510E+00, 0.3175755739E+00, - -.2703750730E+00, 0.2308617830E+00, -.1966916919E+00, - 0.1672732830E+00, -.1424439549E+00, 0.1214511395E+00, - -.1034612656E+00/ *** Heptagon: coefficients for centre and corner expansion. DATA (CC1(I,7),I=0,15) / - 0.1000000000E+01, -.3571428731E-01, -.2040816238E-02, - -.4936389159E-03, -.1446709794E-03, -.4963850370E-04, - -.1877940667E-04, -.7600909157E-05, -.3232265954E-05, - -.1427365532E-05, -.6493634714E-06, -.3026190711E-06, - -.1438593245E-06, -.6953911225E-07, -.3409525462E-07, - -.1692310647E-07/ DATA (CC2(I,7),I=0,15) / - 0.1359752655E+01, -.9244638681E+00, 0.9593217969E+00, - -.8771237731E+00, 0.7490229011E+00, -.6677658558E+00, - 0.6196745634E+00, -.5591596961E+00, 0.4905325770E+00, - -.4393517375E+00, 0.4029803872E+00, -.3631100059E+00, - 0.3199430704E+00, -.2866140604E+00, 0.2627358437E+00, - -.2368256450E+00/ *** Octagon: coefficients for centre and corner expansion. DATA (CC1(I,8),I=0,15) / - 0.1000000000E+01, -.2777777612E-01, -.2246732125E-02, - -.5571441725E-03, -.1790652314E-03, -.6708275760E-04, - -.2766949183E-04, -.1219387286E-04, -.5640039490E-05, - -.2706697160E-05, -.1337270078E-05, -.6763995657E-06, - -.3488264610E-06, -.1828456675E-06, -.9718036154E-07, - -.5227070332E-07/ DATA (CC2(I,8),I=0,15) / - 0.1362840652E+01, -.9286670089E+00, 0.1035511017E+01, - -.9800255299E+00, 0.8315343261E+00, -.7592730522E+00, - 0.7612683773E+00, -.7132136226E+00, 0.6074471474E+00, - -.5554352999E+00, 0.5699443221E+00, -.5357525349E+00, - 0.4329345822E+00, -.3916820884E+00, 0.4401986003E+00, - -.4197303057E+00/ *** Number of terms in each expansion. DATA (NTERM1(I),I=3,8) /6*15/ DATA (NTERM2(I),I=3,8) /6*15/ *** Z coincides with the centre. IF(Z.EQ.0)THEN * Results are trivial. WW=0 WD=KAPPA *** Z is close to the centre. ELSEIF(ABS(Z).LT.0.75)THEN * Series expansion. ZTERM=(KAPPA*Z)**NTUBE WDSUM=0.0 WSUM=CC1(NTERM1(NTUBE),NTUBE) DO 10 I=NTERM1(NTUBE)-1,0,-1 WDSUM=WSUM+ZTERM*WDSUM WSUM=CC1(I,NTUBE)+ZTERM*WSUM 10 CONTINUE * Return the results. WW=KAPPA*Z*WSUM WD=KAPPA*(WSUM+NTUBE*ZTERM*WDSUM) *** Z is close to the edge. ELSE * First rotate Z nearest to 1. AROT=-2*PI*NINT(0.5*ATAN2(AIMAG(Z),REAL(Z))*NTUBE/PI)/ - REAL(NTUBE) ZZ=Z*CMPLX(COS(AROT),SIN(AROT)) * Expand in a series. ZTERM=(KAPPA*(1-ZZ))**(REAL(NTUBE)/REAL(NTUBE-2)) WDSUM=0 WSUM=CC2(NTERM2(NTUBE),NTUBE) DO 20 I=NTERM2(NTUBE)-1,0,-1 WDSUM=WSUM+ZTERM*WDSUM WSUM=CC2(I,NTUBE)+ZTERM*WSUM 20 CONTINUE * And return the results. WW=CMPLX(COS(AROT),-SIN(AROT))*(1-ZTERM*WSUM) WD=REAL(NTUBE)*KAPPA*(KAPPA*(1-ZZ))**(2.0/REAL(NTUBE-2))* - (WSUM+ZTERM*WDSUM)/REAL(NTUBE-2) ENDIF END +DECK,PH2. REAL FUNCTION PH2(XPOS,YPOS) *----------------------------------------------------------------------- * PH2 - Logarithmic contribution to real single-wire potential, * for a doubly priodic wire array. * PH2LIM - Entry, PH2LIM(r) corresponds to z on the surface of a wire * of (small) radius r. * * Clenshaw's algorithm is used for the evaluation of the sum * ZTERM = SIN(ZETA) - P1*SIN(3*ZETA) + P2*SIN(5*ZETA). * * (G.A.Erskine/DD, 14.8.1984; some minor modifications (i) common block * /EV2COM/ incorporated in /CELDAT/ (ii) large AIMAG(ZETA) corrected) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,CONSTANTS. COMPLEX ZETA,ZSIN,ZCOF,ZU,ZUNEW,ZTERM REAL PH2LIM,RADIUS *** Start of the main subroutine, off diagonal elements. ZETA=ZMULT*CMPLX(XPOS,YPOS) IF(ABS(AIMAG(ZETA)).LT.10.0)THEN ZSIN=SIN(ZETA) ZCOF=4.0*ZSIN**2-2.0 ZU=-P1-ZCOF*P2 ZUNEW=1.0-ZCOF*ZU-P2 ZTERM=(ZUNEW+ZU)*ZSIN PH2=-LOG(CABS(ZTERM)) ELSE PH2=-ABS(AIMAG(ZETA))+CLOG2 ENDIF RETURN *** Start of the entry PH2LIM, used to calculate diagonal terms. ENTRY PH2LIM(RADIUS) PH2LIM=-LOG(ABS(ZMULT)*RADIUS*(1.0-3.0*P1+5.0*P2)) END +DECK,E2SUM. SUBROUTINE E2SUM(XPOS,YPOS,EX,EY) *----------------------------------------------------------------------- * E2SUM - Components of the elecrostatic field intensity in a doubly * periodic wire array. * Clenshaw's algorithm is used for the evaluation of the sums * ZTERM1 = SIN(ZETA) - P1*SIN(3*ZETA) + P2*SIN(5*ZETA), * ZTERM2 = COS(ZETA)- 3 P1*COS(3*ZETA)+ 5P2*COS(5*ZETA) * VARIABLES : (XPOS,YPOS): Position in the basic cell at which the * field is to be computed. * (Essentially by G.A.Erskine/DD, 14.8.1984) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,CONSTANTS. COMPLEX WSUM,ZSIN,ZCOF,ZU,ZUNEW,ZTERM1,ZTERM2,ZETA WSUM=0 DO 10 J=1,NWIRE ZETA=ZMULT*CMPLX(XPOS-X(J),YPOS-Y(J)) IF(AIMAG(ZETA).GT.+15.0)THEN WSUM=WSUM-E(J)*ICONS ELSEIF(AIMAG(ZETA).LT.-15.0)THEN WSUM=WSUM+E(J)*ICONS ELSE ZSIN=SIN(ZETA) ZCOF=4.0*ZSIN**2-2.0 ZU=-P1-ZCOF*P2 ZUNEW=1.0-ZCOF*ZU-P2 ZTERM1=(ZUNEW+ZU)*ZSIN ZU=-3.0*P1-ZCOF*5.0*P2 ZUNEW=1.0-ZCOF*ZU-5.0*P2 ZTERM2=(ZUNEW-ZU)*COS(ZETA) WSUM=WSUM+E(J)*(ZTERM2/ZTERM1) ENDIF 10 CONTINUE EX=-REAL(-ZMULT*WSUM) EY=AIMAG(-ZMULT*WSUM) END +DECK,EFCMAT. SUBROUTINE EFCMAT(X0,Y0,X1,Y1,DX,DY) *----------------------------------------------------------------------- * EFCMAT - Computes the effective distance between points taking the * effects of dielectrica into account. *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,CELLDATA. *** Compute the dielectricum-weighed x-distance. DX=ABS(X1-X0) DO 10 I=1,NXMATT XM0=MAX(MIN(X0,X1),MIN(XMATT(I,1),XMATT(I,2))) XM1=MIN(MAX(X0,X1),MAX(XMATT(I,1),XMATT(I,2))) IF(XM1.GE.XM0)DX=DX+(XMATT(I,3)-1.0)*ABS(XM1-XM0) 10 CONTINUE DX=SIGN(DX,X1-X0) *** Compute the dielectricum-weighed x-distance. DY=ABS(Y1-Y0) DO 20 I=1,NYMATT YM0=MAX(MIN(Y0,Y1),MIN(YMATT(I,1),YMATT(I,2))) YM1=MIN(MAX(Y0,Y1),MAX(YMATT(I,1),YMATT(I,2))) IF(YM1.GE.YM0)DY=DY+(YMATT(I,3)-1.0)*ABS(YM1-YM0) 20 CONTINUE DY=SIGN(DY,Y1-Y0) END +DECK,EFCFMP. SUBROUTINE EFCFMP(XIN,YIN,ZIN,EX,EY,EZ,VOLT,IOPT,ILOC) *----------------------------------------------------------------------- * EFCFMP - Interpolates the field map at (XPOS,YPOS,ZPOS). * (Last changed on 10/ 7/99.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,FIELDMAP. +SEQ,CELLDATA. +SEQ,CONSTANTS. REAL XIN,YIN,ZIN,XPOS,YPOS,ZPOS,EX,EY,EZ,VOLT,XNEW,YNEW,ZNEW, - T1,T2,T3,T4,AUXPHI,AUXR,AROT,XAUX,YAUX,ER,EAXIS,RCOOR,ZCOOR INTEGER IOPT,ILOC,IMAP,NX,NY,NZ LOGICAL MIRRX,MIRRY,MIRRZ *** Initial values. EX=0 EY=0 EZ=0 VOLT=0 ILOC=0 XPOS=XIN YPOS=YIN ZPOS=ZIN *** First see whether we at all have a grid. IF(.NOT.MAPFLG(1))RETURN *** If chamber is periodic, reduce to the cell volume. MIRRX=.FALSE. IF(PERX)THEN XPOS=XMMIN+MOD(XPOS-XMMIN,XMMAX-XMMIN) IF(XPOS.LT.XMMIN)XPOS=XPOS+(XMMAX-XMMIN) ELSEIF(PERMX)THEN XNEW=XMMIN+MOD(XPOS-XMMIN,XMMAX-XMMIN) IF(XNEW.LT.XMMIN)XNEW=XNEW+(XMMAX-XMMIN) NX=NINT((XNEW-XPOS)/(XMMAX-XMMIN)) IF(NX.NE.2*(NX/2))THEN XNEW=XMMIN+XMMAX-XNEW MIRRX=.TRUE. ENDIF XPOS=XNEW ENDIF IF(PERAX.AND.(ZPOS.NE.0.OR.YPOS.NE.0))THEN AUXR=SQRT(ZPOS**2+YPOS**2) AUXPHI=ATAN2(ZPOS,YPOS) AROT=(XAMAX-XAMIN)*ANINT((AUXPHI-0.5*(XAMIN+XAMAX))/ - (XAMAX-XAMIN)) IF(AUXPHI-AROT.LT.XAMIN)AROT=AROT-(XAMAX-XAMIN) IF(AUXPHI-AROT.GT.XAMAX)AROT=AROT+(XAMAX-XAMIN) AUXPHI=AUXPHI-AROT YPOS=AUXR*COS(AUXPHI) ZPOS=AUXR*SIN(AUXPHI) ENDIF MIRRY=.FALSE. IF(PERY)THEN YPOS=YMMIN+MOD(YPOS-YMMIN,YMMAX-YMMIN) IF(YPOS.LT.YMMIN)YPOS=YPOS+(YMMAX-YMMIN) ELSEIF(PERMY)THEN YNEW=YMMIN+MOD(YPOS-YMMIN,YMMAX-YMMIN) IF(YNEW.LT.YMMIN)YNEW=YNEW+(YMMAX-YMMIN) NY=NINT((YNEW-YPOS)/(YMMAX-YMMIN)) IF(NY.NE.2*(NY/2))THEN YNEW=YMMIN+YMMAX-YNEW MIRRY=.TRUE. ENDIF YPOS=YNEW ENDIF IF(PERAY.AND.(XPOS.NE.0.OR.ZPOS.NE.0))THEN AUXR=SQRT(XPOS**2+ZPOS**2) AUXPHI=ATAN2(XPOS,ZPOS) AROT=(YAMAX-YAMIN)*ANINT((AUXPHI-0.5*(YAMIN+YAMAX))/ - (YAMAX-YAMIN)) IF(AUXPHI-AROT.LT.YAMIN)AROT=AROT-(YAMAX-YAMIN) IF(AUXPHI-AROT.GT.YAMAX)AROT=AROT+(YAMAX-YAMIN) AUXPHI=AUXPHI-AROT ZPOS=AUXR*COS(AUXPHI) XPOS=AUXR*SIN(AUXPHI) ENDIF MIRRZ=.FALSE. IF(PERZ)THEN ZPOS=ZMMIN+MOD(ZPOS-ZMMIN,ZMMAX-ZMMIN) IF(ZPOS.LT.ZMMIN)ZPOS=ZPOS+(ZMMAX-ZMMIN) ELSEIF(PERMZ)THEN ZNEW=ZMMIN+MOD(ZPOS-ZMMIN,ZMMAX-ZMMIN) IF(ZNEW.LT.ZMMIN)ZNEW=ZNEW+(ZMMAX-ZMMIN) NZ=NINT((ZNEW-ZPOS)/(ZMMAX-ZMMIN)) IF(NZ.NE.2*(NZ/2))THEN ZNEW=ZMMIN+ZMMAX-ZNEW MIRRZ=.TRUE. ENDIF ZPOS=ZNEW ENDIF IF(PERAZ.AND.(YPOS.NE.0.OR.XPOS.NE.0))THEN AUXR=SQRT(YPOS**2+XPOS**2) AUXPHI=ATAN2(YPOS,XPOS) AROT=(ZAMAX-ZAMIN)*ANINT((AUXPHI-0.5*(ZAMIN+ZAMAX))/ - (ZAMAX-ZAMIN)) IF(AUXPHI-AROT.LT.ZAMIN)AROT=AROT-(ZAMAX-ZAMIN) IF(AUXPHI-AROT.GT.ZAMAX)AROT=AROT+(ZAMAX-ZAMIN) AUXPHI=AUXPHI-AROT XPOS=AUXR*COS(AUXPHI) YPOS=AUXR*SIN(AUXPHI) ENDIF *** If we have a rotationally symmetric field map, store coordinates. IF(PERRX)THEN RCOOR=SQRT(YPOS**2+ZPOS**2) ZCOOR=XPOS ELSEIF(PERRY)THEN RCOOR=SQRT(XPOS**2+ZPOS**2) ZCOOR=YPOS ELSEIF(PERRZ)THEN RCOOR=SQRT(XPOS**2+YPOS**2) ZCOOR=ZPOS ENDIF IF(PERRX.OR.PERRY.OR.PERRZ)THEN XPOS=RCOOR YPOS=ZCOOR ZPOS=0 ENDIF *** Locate the point. CALL MAPIND(XPOS,YPOS,ZPOS,T1,T2,T3,T4,IMAP) IF(IMAP.LE.0.OR.IMAP.GT.NMAP)THEN ILOC=-6 RETURN ENDIF *** Next perform a 3-dimensional interpolation, linear ... IF((MAPTYP.EQ.11.OR.MAPTYP.EQ.12.OR.MAPTYP.EQ.13).AND. - MAPORD.EQ.1)THEN IF(MAPFLG(5).AND.IOPT.EQ.1)VOLT=VMAP(IMAP,1)*T1+ - VMAP(IMAP,2)*T2+VMAP(IMAP,3)*T3+VMAP(IMAP,4)*T4 IF(MAPFLG(2))EX=EXMAP(IMAP,1)*T1+EXMAP(IMAP,2)*T2+ - EXMAP(IMAP,3)*T3+EXMAP(IMAP,4)*T4 IF(MAPFLG(3))EY=EYMAP(IMAP,1)*T1+EYMAP(IMAP,2)*T2+ - EYMAP(IMAP,3)*T3+EYMAP(IMAP,4)*T4 IF(MAPFLG(4))EZ=EZMAP(IMAP,1)*T1+EZMAP(IMAP,2)*T2+ - EZMAP(IMAP,3)*T3+EZMAP(IMAP,4)*T4 * or quadratic. ELSEIF(MAPTYP.EQ.12.AND.MAPORD.EQ.2)THEN IF(MAPFLG(5).AND.IOPT.EQ.1)VOLT= - VMAP(IMAP,1)*T1*(2*T1-1)+VMAP(IMAP,2)*T2*(2*T2-1)+ - VMAP(IMAP,3)*T3*(2*T3-1)+VMAP(IMAP,4)*T4*(2*T4-1)+ - 4*VMAP(IMAP,5)*T1*T2+4*VMAP(IMAP,6)*T1*T3+ - 4*VMAP(IMAP,7)*T1*T4+4*VMAP(IMAP,8)*T2*T3+ - 4*VMAP(IMAP,9)*T2*T4+4*VMAP(IMAP,10)*T3*T4 IF(MAPFLG(2))EX= - EXMAP(IMAP,1)*T1*(2*T1-1)+EXMAP(IMAP,2)*T2*(2*T2-1)+ - EXMAP(IMAP,3)*T3*(2*T3-1)+EXMAP(IMAP,4)*T4*(2*T4-1)+ - 4*EXMAP(IMAP,5)*T1*T2+4*EXMAP(IMAP,6)*T1*T3+ - 4*EXMAP(IMAP,7)*T1*T4+4*EXMAP(IMAP,8)*T2*T3+ - 4*EXMAP(IMAP,9)*T2*T4+4*EXMAP(IMAP,10)*T3*T4 IF(MAPFLG(3))EY= - EYMAP(IMAP,1)*T1*(2*T1-1)+EYMAP(IMAP,2)*T2*(2*T2-1)+ - EYMAP(IMAP,3)*T3*(2*T3-1)+EYMAP(IMAP,4)*T4*(2*T4-1)+ - 4*EYMAP(IMAP,5)*T1*T2+4*EYMAP(IMAP,6)*T1*T3+ - 4*EYMAP(IMAP,7)*T1*T4+4*EYMAP(IMAP,8)*T2*T3+ - 4*EYMAP(IMAP,9)*T2*T4+4*EYMAP(IMAP,10)*T3*T4 IF(MAPFLG(4))EZ= - EZMAP(IMAP,1)*T1*(2*T1-1)+EZMAP(IMAP,2)*T2*(2*T2-1)+ - EZMAP(IMAP,3)*T3*(2*T3-1)+EZMAP(IMAP,4)*T4*(2*T4-1)+ - 4*EZMAP(IMAP,5)*T1*T2+4*EZMAP(IMAP,6)*T1*T3+ - 4*EZMAP(IMAP,7)*T1*T4+4*EZMAP(IMAP,8)*T2*T3+ - 4*EZMAP(IMAP,9)*T2*T4+4*EZMAP(IMAP,10)*T3*T4 *** Or perform a 2-dimensional interpolation, linear ... ELSEIF((MAPTYP.EQ.1.OR.MAPTYP.EQ.2.OR.MAPTYP.EQ.3).AND. - MAPORD.EQ.1)THEN IF(MAPFLG(5).AND.IOPT.EQ.1)VOLT= - VMAP(IMAP,1)*T1+VMAP(IMAP,2)*T2+VMAP(IMAP,3)*T3 IF(MAPFLG(2))EX= - EXMAP(IMAP,1)*T1+EXMAP(IMAP,2)*T2+EXMAP(IMAP,3)*T3 IF(MAPFLG(3))EY= - EYMAP(IMAP,1)*T1+EYMAP(IMAP,2)*T2+EYMAP(IMAP,3)*T3 IF(MAPFLG(4))EZ= - EZMAP(IMAP,1)*T1+EZMAP(IMAP,2)*T2+EZMAP(IMAP,3)*T3 * or quadratic. ELSEIF(MAPTYP.EQ.2.AND.MAPORD.EQ.2)THEN IF(MAPFLG(5).AND.IOPT.EQ.1)VOLT= - VMAP(IMAP,1)*T1*(2*T1-1)+VMAP(IMAP,2)*T2*(2*T2-1)+ - VMAP(IMAP,3)*T3*(2*T3-1)+4*VMAP(IMAP,4)*T1*T2+ - 4*VMAP(IMAP,5)*T1*T3+4*VMAP(IMAP,6)*T2*T3 IF(MAPFLG(2))EX= - EXMAP(IMAP,1)*T1*(2*T1-1)+EXMAP(IMAP,2)*T2*(2*T2-1)+ - EXMAP(IMAP,3)*T3*(2*T3-1)+4*EXMAP(IMAP,4)*T1*T2+ - 4*EXMAP(IMAP,5)*T1*T3+4*EXMAP(IMAP,6)*T2*T3 IF(MAPFLG(3))EY= - EYMAP(IMAP,1)*T1*(2*T1-1)+EYMAP(IMAP,2)*T2*(2*T2-1)+ - EYMAP(IMAP,3)*T3*(2*T3-1)+4*EYMAP(IMAP,4)*T1*T2+ - 4*EYMAP(IMAP,5)*T1*T3+4*EYMAP(IMAP,6)*T2*T3 IF(MAPFLG(4))EZ= - EZMAP(IMAP,1)*T1*(2*T1-1)+EZMAP(IMAP,2)*T2*(2*T2-1)+ - EZMAP(IMAP,3)*T3*(2*T3-1)+4*EZMAP(IMAP,4)*T1*T2+ - 4*EZMAP(IMAP,5)*T1*T3+4*EZMAP(IMAP,6)*T2*T3 *** Or an interpolation on a regular hexahedron, linear. ELSEIF(MAPTYP.EQ.14)THEN IF(MAPFLG(5).AND.IOPT.EQ.1)VOLT= - VMAP(IMAP,1)*(1-T1)*(1-T2)*(1-T3)+ - VMAP(IMAP,2)* T1 *(1-T2)*(1-T3)+ - VMAP(IMAP,3)* T1 * T2 *(1-T3)+ - VMAP(IMAP,4)*(1-T1)* T2 *(1-T3)+ - VMAP(IMAP,5)*(1-T1)*(1-T2)* T3 + - VMAP(IMAP,6)* T1 *(1-T2)* T3 + - VMAP(IMAP,7)* T1 * T2 * T3 + - VMAP(IMAP,8)*(1-T1)* T2 * T3 IF(MAPFLG(2))EX= - EXMAP(IMAP,1)*(1-T1)*(1-T2)*(1-T3)+ - EXMAP(IMAP,2)* T1 *(1-T2)*(1-T3)+ - EXMAP(IMAP,3)* T1 * T2 *(1-T3)+ - EXMAP(IMAP,4)*(1-T1)* T2 *(1-T3)+ - EXMAP(IMAP,5)*(1-T1)*(1-T2)* T3 + - EXMAP(IMAP,6)* T1 *(1-T2)* T3 + - EXMAP(IMAP,7)* T1 * T2 * T3 + - EXMAP(IMAP,8)*(1-T1)* T2 * T3 IF(MAPFLG(3))EY= - EYMAP(IMAP,1)*(1-T1)*(1-T2)*(1-T3)+ - EYMAP(IMAP,2)* T1 *(1-T2)*(1-T3)+ - EYMAP(IMAP,3)* T1 * T2 *(1-T3)+ - EYMAP(IMAP,4)*(1-T1)* T2 *(1-T3)+ - EYMAP(IMAP,5)*(1-T1)*(1-T2)* T3 + - EYMAP(IMAP,6)* T1 *(1-T2)* T3 + - EYMAP(IMAP,7)* T1 * T2 * T3 + - EYMAP(IMAP,8)*(1-T1)* T2 * T3 IF(MAPFLG(4))EZ= - EZMAP(IMAP,1)*(1-T1)*(1-T2)*(1-T3)+ - EZMAP(IMAP,2)* T1 *(1-T2)*(1-T3)+ - EZMAP(IMAP,3)* T1 * T2 *(1-T3)+ - EZMAP(IMAP,4)*(1-T1)* T2 *(1-T3)+ - EZMAP(IMAP,5)*(1-T1)*(1-T2)* T3 + - EZMAP(IMAP,6)* T1 *(1-T2)* T3 + - EZMAP(IMAP,7)* T1 * T2 * T3 + - EZMAP(IMAP,8)*(1-T1)* T2 * T3 *** Or an unknown case. ELSE ILOC=-10 RETURN ENDIF *** Apply mirror imaging. IF(MIRRX)EX=-EX IF(MIRRY)EY=-EY IF(MIRRZ)EZ=-EZ *** Rotate the field. IF(PERAX)THEN CALL CFMCTP(EY,EZ,XAUX,YAUX,1) YAUX=YAUX+AROT*180/PI CALL CFMPTC(XAUX,YAUX,EY,EZ,1) ENDIF IF(PERAY)THEN CALL CFMCTP(EZ,EX,XAUX,YAUX,1) YAUX=YAUX+AROT*180/PI CALL CFMPTC(XAUX,YAUX,EZ,EX,1) ENDIF IF(PERAZ)THEN CALL CFMCTP(EX,EY,XAUX,YAUX,1) YAUX=YAUX+AROT*180/PI CALL CFMPTC(XAUX,YAUX,EX,EY,1) ENDIF *** And take care of symmetry. ER=EX EAXIS=EZ IF(PERRX)THEN IF(RCOOR.LE.0)THEN EX=EAXIS EY=0 EZ=0 ELSE EX=EAXIS EY=ER*YIN/RCOOR EZ=ER*ZIN/RCOOR ENDIF ENDIF IF(PERRY)THEN IF(RCOOR.LE.0)THEN EX=0 EY=EAXIS EZ=0 ELSE EX=ER*XIN/RCOOR EY=EAXIS EZ=ER*ZIN/RCOOR ENDIF ENDIF IF(PERRZ)THEN IF(RCOOR.LE.0)THEN EX=0 EY=0 EZ=EAXIS ELSE EX=ER*XIN/RCOOR EY=ER*YIN/RCOOR EZ=EAXIS ENDIF ENDIF *** And store material index. IF(MATMAP(IMAP).EQ.IDRMAT.OR..NOT.MAPFLG(9))THEN ILOC=0 ELSE ILOC=-5 ENDIF END +DECK,EFCBGF. SUBROUTINE EFCBGF(XIN,YIN,ZIN,EXBGF,EYBGF,EZBGF,VBGF) *----------------------------------------------------------------------- * EFCBGF - Computes the background field. * (Last changed on 6/ 4/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,PRINTPLOT. REAL VAR(MXVAR),RES(4),XIN,YIN,ZIN,EXBGF,EYBGF,EZBGF,VBGF, - EXFMP,EYFMP,EZFMP,VFMP INTEGER MODVAR(MXVAR),MODRES(4),IFAIL,I,NREXP,NVAR,ILOC *** Check that there is an entry. IF(IENBGF.LE.0)RETURN *** Store the location in the variables. IF(POLAR)THEN CALL CFMRTP(XIN,YIN,VAR(1),VAR(2),1) VAR(3)=ZIN ELSE VAR(1)=XIN VAR(2)=YIN VAR(3)=ZIN ENDIF MODVAR(1)=2 MODVAR(2)=2 MODVAR(3)=2 * Interpolate field map. IF(LBGFMP)THEN CALL EFCFMP(XIN,YIN,ZIN,EXFMP,EYFMP,EZFMP,VFMP,1,ILOC) IF(ILOC.NE.0.AND.ILOC.NE.-5)THEN VAR(4)=0 VAR(5)=0 VAR(6)=0 VAR(7)=0 ELSE VAR(4)=EXFMP VAR(5)=EYFMP VAR(6)=EZFMP VAR(7)=VFMP ENDIF MODVAR(4)=2 MODVAR(5)=2 MODVAR(6)=2 MODVAR(7)=2 ELSE VAR(4)=0 VAR(5)=0 VAR(6)=0 VAR(7)=0 MODVAR(4)=0 MODVAR(5)=0 MODVAR(6)=0 MODVAR(7)=0 ENDIF * Set number of variables. NVAR=7 *** Compute the field. NREXP=4 CALL AL2EXE(IENBGF,VAR,MODVAR,NVAR,RES,MODRES,NREXP,IFAIL) * Check the error flag and variable types. IF(IFAIL.NE.0.OR.MODRES(1).NE.2.OR.MODRES(2).NE.2.OR. - MODRES(3).NE.2.OR.MODRES(4).NE.2)THEN EXBGF=0 EYBGF=0 EZBGF=0 VBGF=0 IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ EFCBGF DEBUG :'', - '' Invalid background field result:''/ - 26X,''IFAIL='',I2,'', modes: '',4I2)') - IFAIL,(MODRES(I),I=1,4) * Convert to polar internal field vectors if required. ELSEIF(POLAR)THEN VBGF=RES(1) EXBGF=RES(2)*EXP(XIN) EYBGF=RES(3)*EXP(XIN) EZBGF=RES(4) * Or simply store the results. ELSE VBGF=RES(1) EXBGF=RES(2) EYBGF=RES(3) EZBGF=RES(4) ENDIF END +DECK,FFDBG. SUBROUTINE FFDBG(XPOS,YPOS,EX,EY) *----------------------------------------------------------------------- * FFDBG - Subroutine used for debugging force calculations. * VARIABLES : XPOS, YPOS : position * EX, EY : x- and y-component of the electric field. * (Last changed on 20/ 1/97.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,PARAMETERS. +SEQ,CELLDATA. +SEQ,PRINTPLOT. +SEQ,CONSTANTS. REAL EX,EY *** Initial values. EX=0 EY=0 *** Set the CNALSO flags appropriately. DO 10 I=1,NWIRE CNALSO(I)=.TRUE. 10 CONTINUE *** Call the appropriate potential calculation function. IF(ICTYPE.EQ.1) CALL FFCA00(XPOS,YPOS,EX,EY) IF(ICTYPE.EQ.2) CALL FFCB1X(XPOS,YPOS,EX,EY) IF(ICTYPE.EQ.3) CALL FFCB1Y(XPOS,YPOS,EX,EY) IF(ICTYPE.EQ.4) CALL FFCB2X(XPOS,YPOS,EX,EY) IF(ICTYPE.EQ.5) CALL FFCB2Y(XPOS,YPOS,EX,EY) IF(ICTYPE.EQ.6) CALL FFCC10(XPOS,YPOS,EX,EY) IF(ICTYPE.EQ.7) CALL FFCC2X(XPOS,YPOS,EX,EY) IF(ICTYPE.EQ.8) CALL FFCC2Y(XPOS,YPOS,EX,EY) IF(ICTYPE.EQ.9) CALL FFCC30(XPOS,YPOS,EX,EY) IF(ICTYPE.EQ.10)CALL FFCD10(XPOS,YPOS,EX,EY) IF(ICTYPE.EQ.11)CALL FFCD20(XPOS,YPOS,EX,EY) IF(ICTYPE.EQ.12)CALL FFCD30(XPOS,YPOS,EX,EY) C IF(ICTYPE.EQ.13)CALL FFCD40(XPOS,YPOS,EX,EY) *** Correct for the equipotential planes. EX=EX-CORVTA EY=EY-CORVTB END +DECK,FFIELD. SUBROUTINE FFIELD(IW,EX,EY) *----------------------------------------------------------------------- * FFIELD - Subroutine calculating the electric field at a given wire * position, as if the wire itself were not there but with * the presence of its mirror images. * VARIABLES : IW : wire number * EX, EY : x- and y-component of the electric field. * (Last changed on 27/ 1/96.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,PARAMETERS. +SEQ,CELLDATA. +SEQ,PRINTPLOT. +SEQ,CONSTANTS. REAL EX,EY INTEGER IW *** Initial values. EX=0 EY=0 *** Check the wire number. IF(IW.LT.1.OR.IW.GT.NWIRE)THEN PRINT *,' !!!!!! FFIELD WARNING : Received an invalid'// - ' wire number; field set to zero.' RETURN ENDIF *** Set the CNALSO flags appropriately. DO 10 I=1,NWIRE CNALSO(I)=.TRUE. 10 CONTINUE CNALSO(IW)=.FALSE. *** Call the appropriate potential calculation function. IF(ICTYPE.EQ.1) CALL FFCA00(X(IW),Y(IW),EX,EY) IF(ICTYPE.EQ.2) CALL FFCB1X(X(IW),Y(IW),EX,EY) IF(ICTYPE.EQ.3) CALL FFCB1Y(X(IW),Y(IW),EX,EY) IF(ICTYPE.EQ.4) CALL FFCB2X(X(IW),Y(IW),EX,EY) IF(ICTYPE.EQ.5) CALL FFCB2Y(X(IW),Y(IW),EX,EY) IF(ICTYPE.EQ.6) CALL FFCC10(X(IW),Y(IW),EX,EY) IF(ICTYPE.EQ.7) CALL FFCC2X(X(IW),Y(IW),EX,EY) IF(ICTYPE.EQ.8) CALL FFCC2Y(X(IW),Y(IW),EX,EY) IF(ICTYPE.EQ.9) CALL FFCC30(X(IW),Y(IW),EX,EY) IF(ICTYPE.EQ.10)CALL FFCD10(X(IW),Y(IW),EX,EY) IF(ICTYPE.EQ.11)CALL FFCD20(X(IW),Y(IW),EX,EY) IF(ICTYPE.EQ.12)CALL FFCD30(X(IW),Y(IW),EX,EY) C IF(ICTYPE.EQ.13)CALL FFCD40(X(IW),Y(IW),EX,EY) *** Correct for the equipotential planes. EX=EX-CORVTA EY=EY-CORVTB C print *,' FFIELD - wire ',IW,' E=',EX,EY,' q=',E(IW) END +DECK,FFCA00. SUBROUTINE FFCA00(XPOS,YPOS,EX,EY) *----------------------------------------------------------------------- * FFCA00 - Subroutine performing the actual field calculations in case * only one charge and not more than 1 mirror-charge in either * x or y is present. * The potential used is 1/2*pi*eps0 log(r). * VARIABLES : R2 : Potential before taking -log(sqrt(...)) * EX, EY : x,y-component of the electric field. * ETOT : Magnitude of electric field. * EXHELP etc : One term in the series to be summed. * (XPOS,YPOS): The position where the field is calculated. * (Last changed on 27/ 1/96.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,CELLDATA. *** Initialise the potential and the electric field. EX=0 EY=0 *** Loop over all wires. DO 10 I=1,NWIRE *** Calculate the field in case there are no planes. IF(CNALSO(I))THEN R2=(XPOS-X(I))**2+(YPOS-Y(I))**2 EXHELP=(XPOS-X(I))/R2 EYHELP=(YPOS-Y(I))/R2 ELSE EXHELP=0 EYHELP=0 ENDIF *** Take care of a plane at constant x. IF(YNPLAX)THEN XXMIRR=X(I)+XPOS-2*COPLAX R2PLAN=XXMIRR**2+(YPOS-Y(I))**2 EXHELP=EXHELP-XXMIRR/R2PLAN EYHELP=EYHELP-(YPOS-Y(I))/R2PLAN ENDIF *** Take care of a plane at constant y. IF(YNPLAY)THEN YYMIRR=Y(I)+YPOS-2*COPLAY R2PLAN=(XPOS-X(I))**2+YYMIRR**2 EXHELP=EXHELP-(XPOS-X(I))/R2PLAN EYHELP=EYHELP-YYMIRR/R2PLAN ENDIF *** Take care of pairs of planes. IF(YNPLAX.AND.YNPLAY)THEN R2PLAN=XXMIRR**2+YYMIRR**2 EXHELP=EXHELP+XXMIRR/R2PLAN EYHELP=EYHELP+YYMIRR/R2PLAN ENDIF *** Calculate the electric field and the potential. EX=EX+E(I)*EXHELP EY=EY+E(I)*EYHELP *** Finish the loop over the wires. 10 CONTINUE END +DECK,FFCB1X. SUBROUTINE FFCB1X(XPOS,YPOS,EX,EY) *----------------------------------------------------------------------- * FFCB1X - Routine calculating the potential for a row of positive * charges. The potential used is Re(Log(sin pi/s (z-z0))). * VARIABLES : See routine FFCA00 for most of the variables. * Z,ZZMIRR : X + I*Y , XXMIRR + I*YYMIRR ; I**2=-1 * ECOMPL : EX + I*EY ; I**2=-1 * (Last changed on 27/ 1/96.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,CONSTANTS. COMPLEX ZZ,ECOMPL,ZZMIRR *** Initialise EX, EY. EX=0 EY=0 *** With a y plane. IF(YNPLAY)THEN DO 10 I=1,NWIRE XX=(PI/SX)*(XPOS-X(I)) YY=(PI/SX)*(YPOS-Y(I)) ZZ=CMPLX(XX,YY) IF(.NOT.CNALSO(I))THEN ECOMPL=0 ELSEIF(YY.GT.+20)THEN ECOMPL=-ICONS ELSEIF(YY.LT.-20)THEN ECOMPL=+ICONS ELSE ECOMPL=ICONS*(EXP(2*ICONS*ZZ)+1)/(EXP(2*ICONS*ZZ)-1) ENDIF YYMIRR=(PI/SX)*(YPOS+Y(I)-2*COPLAY) ZZMIRR=CMPLX(XX,YYMIRR) IF(YYMIRR.GT.+20)THEN ECOMPL=ECOMPL+ICONS ELSEIF(YYMIRR.LT.-20)THEN ECOMPL=ECOMPL-ICONS ELSE ECOMPL=ECOMPL-ICONS*(EXP(2*ICONS*ZZMIRR)+1)/ - (EXP(2*ICONS*ZZMIRR)-1) ENDIF * Update the field. EX=EX+E(I)*(PI/SX)*REAL(ECOMPL) EY=EY-E(I)*(PI/SX)*AIMAG(ECOMPL) 10 CONTINUE *** Without y plane. ELSE DO 20 I=1,NWIRE IF(.NOT.CNALSO(I))GOTO 20 XX=(PI/SX)*(XPOS-X(I)) YY=(PI/SX)*(YPOS-Y(I)) ZZ=CMPLX(XX,YY) IF(YY.GT.+20)THEN ECOMPL=-ICONS ELSEIF(YY.LT.-20)THEN ECOMPL=+ICONS ELSE ECOMPL=ICONS*(EXP(2*ICONS*ZZ)+1)/ - (EXP(2*ICONS*ZZ)-1) ENDIF EX=EX+E(I)*(PI/SX)*REAL(ECOMPL) EY=EY-E(I)*(PI/SX)*AIMAG(ECOMPL) 20 CONTINUE ENDIF END +DECK,FFCB1Y. SUBROUTINE FFCB1Y(XPOS,YPOS,EX,EY) *----------------------------------------------------------------------- * FFCB1Y - Routine calculating the potential for a row of positive * charges. The potential used is Re(Log(sinh pi/sy(z-z0)). * VARIABLES : See routine FFCA00 for most of the variables. * Z,ZZMIRR : X + I*Y , XXMIRR + I*YYMIRR ; I**2=-1 * ECOMPL : EX + I*EY ; I**2=-1 * (IBM and Cray vectorisable version.) * (Last changed on 27/ 1/96.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,CONSTANTS. COMPLEX ZZ,ECOMPL,ZZMIRR *** Initialise EX, EY. EX=0 EY=0 *** First the situation there is an x-plane. IF(YNPLAX)THEN DO 10 I=1,NWIRE XX=(PI/SY)*(XPOS-X(I)) YY=(PI/SY)*(YPOS-Y(I)) ZZ=CMPLX(XX,YY) IF(.NOT.CNALSO(I))THEN ECOMPL=0 ELSEIF(XX.GT.+20)THEN ECOMPL=+1 ELSEIF(XX.LT.-20)THEN ECOMPL=-1 ELSE ECOMPL=(EXP(2*ZZ)+1)/(EXP(2*ZZ)-1) ENDIF XXMIRR=(PI/SY)*(XPOS+X(I)-2*COPLAX) ZZMIRR=CMPLX(XXMIRR,YY) IF(XXMIRR.GT.+20)THEN ECOMPL=ECOMPL-1 ELSEIF(XXMIRR.LT.-20)THEN ECOMPL=ECOMPL+1 ELSE ECOMPL=ECOMPL-(EXP(2*ZZMIRR)+1)/(EXP(2*ZZMIRR)-1) ENDIF EX=EX+E(I)*(PI/SY)*REAL(ECOMPL) EY=EY-E(I)*(PI/SY)*AIMAG(ECOMPL) 10 CONTINUE *** Case the is no plane. ELSE DO 20 I=1,NWIRE IF(.NOT.CNALSO(I))GOTO 20 XX=(PI/SY)*(XPOS-X(I)) YY=(PI/SY)*(YPOS-Y(I)) ZZ=CMPLX(XX,YY) IF(XX.GT.+20)THEN ECOMPL=+1 ELSEIF(XX.LT.-20)THEN ECOMPL=-1 ELSE ECOMPL=(EXP(2*ZZ)+1)/(EXP(2*ZZ)-1) ENDIF EX=EX+E(I)*(PI/SY)*REAL(ECOMPL) EY=EY-E(I)*(PI/SY)*AIMAG(ECOMPL) 20 CONTINUE ENDIF END +DECK,FFCB2X. SUBROUTINE FFCB2X(XPOS,YPOS,EX,EY) *----------------------------------------------------------------------- * FFCB2X - Routine calculating the potential for a row of alternating * + - charges. The potential used is re log(sin pi/sx (z-z0)) * VARIABLES : See routine FFCA00 for most of the variables. * Z, ZZMRR : X + i*Y , XXMIRR + i*YYMIRR ; i**2=-1 * ECOMPL : EX + i*EY ; i**2=-1 * (Cray vectorisable) * (Last changed on 21/ 1/97.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,CONSTANTS. COMPLEX ZZ,ECOMPL,ZZMIRR,ZZNEG,ZZNMIR *** Initialise EX, EY. EX=0 EY=0 *** Loop over all wires. DO 10 I=1,NWIRE XX=(0.5*PI/SX)*(XPOS-X(I)) YY=(0.5*PI/SX)*(YPOS-Y(I)) XXNEG=(0.5*PI/SX)*(XPOS+X(I)-2*COPLAX) ZZ=CMPLX(XX,YY) ZZNEG=CMPLX(XXNEG,YY) *** Calculate the field in case there are no equipotential planes. IF(CNALSO(I).AND.ABS(YY).LE.20)THEN ECOMPL=-B2SIN(I)/(SIN(ZZ)*SIN(ZZNEG)) ELSEIF(ABS(YY).LE.20)THEN ECOMPL=-ICONS*(EXP(2*ICONS*ZZNEG)+1)/(EXP(2*ICONS*ZZNEG)-1) ELSE ECOMPL=0 ENDIF *** Take care of a planes at constant y. IF(YNPLAY)THEN YYMIRR=(0.5*PI/SX)*(YPOS+Y(I)-2*COPLAY) ZZMIRR=CMPLX(XX,YYMIRR) ZZNMIR=CMPLX(XXNEG,YYMIRR) IF(ABS(YYMIRR).LE.20) - ECOMPL=ECOMPL+B2SIN(I)/(SIN(ZZMIRR)*SIN(ZZNMIR)) ENDIF *** Calculate the electric field and the potential. EX=EX+E(I)*(0.5*PI/SX)*REAL(ECOMPL) EY=EY-E(I)*(0.5*PI/SX)*AIMAG(ECOMPL) *** Finish the wire loop. 10 CONTINUE END +DECK,FFCB2Y. SUBROUTINE FFCB2Y(XPOS,YPOS,EX,EY) *----------------------------------------------------------------------- * FFCB2Y - Routine calculating the potential for a row of alternating * + - charges. The potential used is re log(sin pi/sx (z-z0)) * VARIABLES : See routine FFCA00 for most of the variables. * Z, ZMIRR : X + i*Y , XXMIRR + i*YYMIRR ; i**2=-1 * ECOMPL : EX + i*EY ; i**2=-1 * (Cray vectorisable) * (Last changed on 21/ 1/97.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,CONSTANTS. COMPLEX ZZ,ECOMPL,ZZMIRR,ZZNEG,ZZNMIR *** Initialise EX, EY. EX=0 EY=0 *** Loop over all wires. DO 10 I=1,NWIRE XX=(0.5*PI/SY)*(XPOS-X(I)) YY=(0.5*PI/SY)*(YPOS-Y(I)) YYNEG=(0.5*PI/SY)*(YPOS+Y(I)-2*COPLAY) ZZ=CMPLX(XX,YY) ZZNEG=CMPLX(XX,YYNEG) *** Calculate the field in case there are no equipotential planes. IF(CNALSO(I).AND.ABS(XX).LE.20)THEN ECOMPL=ICONS*B2SIN(I)/(SIN(ICONS*ZZ)*SIN(ICONS*ZZNEG)) ELSEIF(ABS(XX).LE.20)THEN ECOMPL=-(EXP(2*ZZNEG)+1)/(EXP(2*ZZNEG)-1) ELSE ECOMPL=0 ENDIF *** Take care of a plane at constant x. IF(YNPLAX)THEN XXMIRR=(0.5*PI/SY)*(XPOS+X(I)-2*COPLAX) ZZMIRR=CMPLX(XXMIRR,YY) ZZNMIR=CMPLX(XXMIRR,YYNEG) IF(ABS(XXMIRR).LE.20)ECOMPL=ECOMPL- - ICONS*B2SIN(I)/(SIN(ICONS*ZZMIRR)*SIN(ICONS*ZZNMIR)) ENDIF *** Calculate the electric field and the potential. EX=EX+E(I)*(0.5*PI/SY)*REAL(ECOMPL) EY=EY-E(I)*(0.5*PI/SY)*AIMAG(ECOMPL) *** Finish the wire loop. 10 CONTINUE END +DECK,FFCC10. SUBROUTINE FFCC10(XPOS,YPOS,EX,EY) *----------------------------------------------------------------------- * FFCC10 - Routine returning the potential and electric field. It * calls the routines PH2 and E2SUM written by G.A.Erskine. * VARIABLES : No local variables. * (Last changed on 27/ 1/96.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,CONSTANTS. COMPLEX WSUM,ZSIN,ZCOF,ZU,ZUNEW,ZTERM1,ZTERM2,ZETA *** Initial value. WSUM=0 *** Loop over the wires. DO 10 J=1,NWIRE IF(.NOT.CNALSO(J))GOTO 10 ZETA=ZMULT*CMPLX(XPOS-X(J),YPOS-Y(J)) IF(AIMAG(ZETA).GT.+15)THEN WSUM=WSUM-E(J)*ICONS ELSEIF(AIMAG(ZETA).LT.-15)THEN WSUM=WSUM+E(J)*ICONS ELSE ZSIN=SIN(ZETA) ZCOF=4*ZSIN**2-2 ZU=-P1-ZCOF*P2 ZUNEW=1-ZCOF*ZU-P2 ZTERM1=(ZUNEW+ZU)*ZSIN ZU=-3*P1-ZCOF*5*P2 ZUNEW=1-ZCOF*ZU-5*P2 ZTERM2=(ZUNEW-ZU)*COS(ZETA) WSUM=WSUM+E(J)*(ZTERM2/ZTERM1) ENDIF 10 CONTINUE EX=-REAL(-ZMULT*WSUM) EY=AIMAG(-ZMULT*WSUM) *** Correction terms. IF(MODE.EQ.0)EX=EX-C1 IF(MODE.EQ.1)EY=EY-C1 END +DECK,FFCC2X. SUBROUTINE FFCC2X(XPOS,YPOS,EX,EY) *----------------------------------------------------------------------- * FFCC2X - Routine returning the potential and electric field in a * configuration with 2 x planes and y periodicity. * VARIABLES : see the writeup * (Last changed on 27/ 1/96.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,CONSTANTS. COMPLEX WSUM1,WSUM2,ZSIN,ZCOF,ZU,ZUNEW,ZTERM1,ZTERM2,ZETA *** Initial values. WSUM1=0 WSUM2=0 *** Wire loop. DO 10 I=1,NWIRE * Compute the direct contribution. IF(CNALSO(I))THEN ZETA=ZMULT*CMPLX(XPOS-X(I),YPOS-Y(I)) IF(AIMAG(ZETA).GT.+15)THEN WSUM1=WSUM1-E(I)*ICONS ELSEIF(AIMAG(ZETA).LT.-15)THEN WSUM1=WSUM1+E(I)*ICONS ELSE ZSIN=SIN(ZETA) ZCOF=4*ZSIN**2-2 ZU=-P1-ZCOF*P2 ZUNEW=1-ZCOF*ZU-P2 ZTERM1=(ZUNEW+ZU)*ZSIN ZU=-3*P1-ZCOF*5*P2 ZUNEW=1-ZCOF*ZU-5*P2 ZTERM2=(ZUNEW-ZU)*COS(ZETA) WSUM1=WSUM1+E(I)*(ZTERM2/ZTERM1) ENDIF ENDIF * Find the plane nearest to the wire. CX=COPLAX-SX*ANINT((COPLAX-X(I))/SX) * Mirror contribution. ZETA=ZMULT*CMPLX(2*CX-XPOS-X(I),YPOS-Y(I)) IF(AIMAG(ZETA).GT.+15)THEN WSUM2=WSUM2-E(I)*ICONS ELSEIF(AIMAG(ZETA).LT.-15)THEN WSUM2=WSUM2+E(I)*ICONS ELSE ZSIN=SIN(ZETA) ZCOF=4*ZSIN**2-2 ZU=-P1-ZCOF*P2 ZUNEW=1-ZCOF*ZU-P2 ZTERM1=(ZUNEW+ZU)*ZSIN ZU=-3*P1-ZCOF*5*P2 ZUNEW=1-ZCOF*ZU-5*P2 ZTERM2=(ZUNEW-ZU)*COS(ZETA) WSUM2=WSUM2+E(I)*(ZTERM2/ZTERM1) ENDIF 10 CONTINUE *** Convert the two contributions to a real field. EX=REAL(ZMULT*(WSUM1+WSUM2)) EY=-AIMAG(ZMULT*(WSUM1-WSUM2)) *** Constant correction terms. IF(MODE.EQ.0)EX=EX-C1 END +DECK,FFCC2Y. SUBROUTINE FFCC2Y(XPOS,YPOS,EX,EY) *----------------------------------------------------------------------- * FFCC2Y - Routine returning the potential and electric field in a * configuration with 2 y planes and x periodicity. * VARIABLES : see the writeup * (Last changed on 27/ 1/96.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,CONSTANTS. COMPLEX WSUM1,WSUM2,ZSIN,ZCOF,ZU,ZUNEW,ZTERM1,ZTERM2,ZETA *** Initial values. WSUM1=0 WSUM2=0 *** Wire loop. DO 10 I=1,NWIRE * Compute the direct contribution. IF(CNALSO(I))THEN ZETA=ZMULT*CMPLX(XPOS-X(I),YPOS-Y(I)) IF(AIMAG(ZETA).GT.+15)THEN WSUM1=WSUM1-E(I)*ICONS ELSEIF(AIMAG(ZETA).LT.-15)THEN WSUM1=WSUM1+E(I)*ICONS ELSE ZSIN=SIN(ZETA) ZCOF=4*ZSIN**2-2 ZU=-P1-ZCOF*P2 ZUNEW=1-ZCOF*ZU-P2 ZTERM1=(ZUNEW+ZU)*ZSIN ZU=-3*P1-ZCOF*5*P2 ZUNEW=1-ZCOF*ZU-5*P2 ZTERM2=(ZUNEW-ZU)*COS(ZETA) WSUM1=WSUM1+E(I)*(ZTERM2/ZTERM1) ENDIF ENDIF * Find the plane nearest to the wire. CY=COPLAY-SY*ANINT((COPLAY-Y(I))/SY) * Mirror contribution from the y plane. ZETA=ZMULT*CMPLX(XPOS-X(I),2*CY-YPOS-Y(I)) IF(AIMAG(ZETA).GT.+15)THEN WSUM2=WSUM2-E(I)*ICONS ELSEIF(AIMAG(ZETA).LT.-15)THEN WSUM2=WSUM2+E(I)*ICONS ELSE ZSIN=SIN(ZETA) ZCOF=4*ZSIN**2-2 ZU=-P1-ZCOF*P2 ZUNEW=1-ZCOF*ZU-P2 ZTERM1=(ZUNEW+ZU)*ZSIN ZU=-3*P1-ZCOF*5*P2 ZUNEW=1-ZCOF*ZU-5*P2 ZTERM2=(ZUNEW-ZU)*COS(ZETA) WSUM2=WSUM2+E(I)*(ZTERM2/ZTERM1) ENDIF 10 CONTINUE *** Convert the two contributions to a real field. EX=REAL(ZMULT*(WSUM1-WSUM2)) EY=-AIMAG(ZMULT*(WSUM1+WSUM2)) *** Constant correction terms. IF(MODE.EQ.1)EY=EY-C1 END +DECK,FFCC30. SUBROUTINE FFCC30(XPOS,YPOS,EX,EY) *----------------------------------------------------------------------- * FFCC30 - Routine returning the potential and electric field in a * configuration with 2 y and 2 x planes. * VARIABLES : see the writeup * (Last changed on 27/ 1/96.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,CONSTANTS. COMPLEX WSUM1,WSUM2,WSUM3,WSUM4,ZSIN,ZCOF,ZU,ZUNEW, - ZTERM1,ZTERM2,ZETA *** Initial values. WSUM1=0 WSUM2=0 WSUM3=0 WSUM4=0 *** Wire loop. DO 10 I=1,NWIRE * Compute the direct contribution. IF(CNALSO(I))THEN ZETA=ZMULT*CMPLX(XPOS-X(I),YPOS-Y(I)) IF(AIMAG(ZETA).GT.+15)THEN WSUM1=WSUM1-E(I)*ICONS ELSEIF(AIMAG(ZETA).LT.-15)THEN WSUM1=WSUM1+E(I)*ICONS ELSE ZSIN=SIN(ZETA) ZCOF=4*ZSIN**2-2 ZU=-P1-ZCOF*P2 ZUNEW=1-ZCOF*ZU-P2 ZTERM1=(ZUNEW+ZU)*ZSIN ZU=-3*P1-ZCOF*5*P2 ZUNEW=1-ZCOF*ZU-5*P2 ZTERM2=(ZUNEW-ZU)*COS(ZETA) WSUM1=WSUM1+E(I)*(ZTERM2/ZTERM1) ENDIF ENDIF * Find the plane nearest to the wire. CX=COPLAX-SX*ANINT((COPLAX-X(I))/SX) * Mirror contribution from the x plane. ZETA=ZMULT*CMPLX(2*CX-XPOS-X(I),YPOS-Y(I)) IF(AIMAG(ZETA).GT.+15)THEN WSUM2=WSUM2-E(I)*ICONS ELSEIF(AIMAG(ZETA).LT.-15)THEN WSUM2=WSUM2+E(I)*ICONS ELSE ZSIN=SIN(ZETA) ZCOF=4*ZSIN**2-2 ZU=-P1-ZCOF*P2 ZUNEW=1-ZCOF*ZU-P2 ZTERM1=(ZUNEW+ZU)*ZSIN ZU=-3*P1-ZCOF*5*P2 ZUNEW=1-ZCOF*ZU-5*P2 ZTERM2=(ZUNEW-ZU)*COS(ZETA) WSUM2=WSUM2+E(I)*(ZTERM2/ZTERM1) ENDIF * Find the plane nearest to the wire. CY=COPLAY-SY*ANINT((COPLAY-Y(I))/SY) * Mirror contribution from the y plane. ZETA=ZMULT*CMPLX(XPOS-X(I),2*CY-YPOS-Y(I)) IF(AIMAG(ZETA).GT.+15)THEN WSUM3=WSUM3-E(I)*ICONS ELSEIF(AIMAG(ZETA).LT.-15)THEN WSUM3=WSUM3+E(I)*ICONS ELSE ZSIN=SIN(ZETA) ZCOF=4*ZSIN**2-2 ZU=-P1-ZCOF*P2 ZUNEW=1-ZCOF*ZU-P2 ZTERM1=(ZUNEW+ZU)*ZSIN ZU=-3*P1-ZCOF*5*P2 ZUNEW=1-ZCOF*ZU-5*P2 ZTERM2=(ZUNEW-ZU)*COS(ZETA) WSUM3=WSUM3+E(I)*(ZTERM2/ZTERM1) ENDIF * Mirror contribution from both the x and the y plane. ZETA=ZMULT*CMPLX(2*CX-XPOS-X(I),2*CY-YPOS-Y(I)) IF(AIMAG(ZETA).GT.+15)THEN WSUM4=WSUM4-E(I)*ICONS ELSEIF(AIMAG(ZETA).LT.-15)THEN WSUM4=WSUM4+E(I)*ICONS ELSE ZSIN=SIN(ZETA) ZCOF=4*ZSIN**2-2 ZU=-P1-ZCOF*P2 ZUNEW=1-ZCOF*ZU-P2 ZTERM1=(ZUNEW+ZU)*ZSIN ZU=-3*P1-ZCOF*5*P2 ZUNEW=1-ZCOF*ZU-5*P2 ZTERM2=(ZUNEW-ZU)*COS(ZETA) WSUM4=WSUM4+E(I)*(ZTERM2/ZTERM1) ENDIF 10 CONTINUE *** Convert the two contributions to a real field. EX=+REAL(ZMULT*(WSUM1+WSUM2-WSUM3-WSUM4)) EY=-AIMAG(ZMULT*(WSUM1-WSUM2+WSUM3-WSUM4)) END +DECK,FFCD10. SUBROUTINE FFCD10(XPOS,YPOS,EX,EY) *----------------------------------------------------------------------- * FFCD10 - Subroutine performing the actual field calculations for a * cell which has a one circular plane and some wires. * VARIABLES : EX, EY : Electric field. * ETOT : Magnitude of electric field. * (XPOS,YPOS): The position where the field is calculated. * ZI, ZPOS : Shorthand complex notations. * (Last changed on 2/ 3/97.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. INTEGER I REAL XPOS,YPOS,EX,EY COMPLEX ZI,ZPOS *** Initialise the potential and the electric field. EX=0 EY=0 * Set the complex position coordinates. ZPOS=CMPLX(XPOS,YPOS) *** Loop over all wires. DO 10 I=1,NWIRE * Set the complex version of the wire-coordinate for simplicity. ZI=CMPLX(X(I),Y(I)) * First the case that the wire has to be taken fully. IF(CNALSO(I))THEN EX=EX+E(I)*REAL(1/CONJG(ZPOS-ZI)+ - ZI/(COTUBE**2-CONJG(ZPOS)*ZI)) EY=EY+E(I)*AIMAG(1/CONJG(ZPOS-ZI)+ - ZI/(COTUBE**2-CONJG(ZPOS)*ZI)) * Otherwise only take the mirror charge. ELSE EX=EX+E(I)*REAL(ZI/(COTUBE**2-CONJG(ZPOS)*ZI)) EY=EY+E(I)*AIMAG(ZI/(COTUBE**2-CONJG(ZPOS)*ZI)) ENDIF *** Finish the loop over the wires. 10 CONTINUE END +DECK,FFCD20. SUBROUTINE FFCD20(XPOS,YPOS,EX,EY) *----------------------------------------------------------------------- * FFCD20 - Subroutine performing the actual field calculations for a * cell which has a tube and phi periodicity. * VARIABLES : EX, EY : Electric field. * ETOT : Magnitude of electric field. * (XPOS,YPOS): The position where the field is calculated. * ZI, ZPOS : Shorthand complex notations. * (Last changed on 2/ 3/97.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. REAL XPOS,YPOS,EX,EY INTEGER I COMPLEX ZI,ZPOS *** Initialise the potential and the electric field. EX=0 EY=0 * Set the complex position coordinates. ZPOS=CMPLX(XPOS,YPOS) *** Loop over all wires. DO 10 I=1,NWIRE * Set the complex version of the wire-coordinate for simplicity. ZI=CMPLX(X(I),Y(I)) IF(CNALSO(I))THEN * Case of the wire which is not in the centre. IF(ABS(ZI).GT.D(I)/2)THEN EX=EX+E(I)*REAL(MTUBE*CONJG(ZPOS)**(MTUBE-1)* - (1/CONJG(ZPOS**MTUBE-ZI**MTUBE)+ZI**MTUBE/ - (COTUBE**(2*MTUBE)-(CONJG(ZPOS)*ZI)**MTUBE))) EY=EY+E(I)*AIMAG(MTUBE*CONJG(ZPOS)**(MTUBE-1)* - (1/CONJG(ZPOS**MTUBE-ZI**MTUBE)+ZI**MTUBE/ - (COTUBE**(2*MTUBE)-(CONJG(ZPOS)*ZI)**MTUBE))) * Regular case of the off-centre wire. ELSE EX=EX+E(I)*REAL(1/CONJG(ZPOS-ZI)+ZI/ - (COTUBE**2-CONJG(ZPOS)*ZI)) EY=EY+E(I)*AIMAG(1/CONJG(ZPOS-ZI)+ZI/ - (COTUBE**2-CONJG(ZPOS)*ZI)) ENDIF ELSE * Case of the wire which is not in the centre. IF(ABS(ZI).GT.D(I)/2)THEN EX=EX+E(I)*REAL(MTUBE*CONJG(ZPOS)**(MTUBE-1)* - (ZI**MTUBE/(COTUBE**(2*MTUBE)- - (CONJG(ZPOS)*ZI)**MTUBE))) EY=EY+E(I)*AIMAG(MTUBE*CONJG(ZPOS)**(MTUBE-1)* - (ZI**MTUBE/(COTUBE**(2*MTUBE)- - (CONJG(ZPOS)*ZI)**MTUBE))) * Regular case of the off-centre wire. ELSE EX=EX+E(I)*REAL(ZI/(COTUBE**2-CONJG(ZPOS)*ZI)) EY=EY+E(I)*AIMAG(ZI/(COTUBE**2-CONJG(ZPOS)*ZI)) ENDIF ENDIF *** Finish the loop over the wires. 10 CONTINUE END +DECK,FFCD30. SUBROUTINE FFCD30(XPOS,YPOS,EX,EY) *----------------------------------------------------------------------- * FFCD30 - Subroutine performing the actual field calculations for a * cell which has a polygon as tube and some wires. * VARIABLES : EX, EY : Electric field. * ETOT : Magnitude of electric field. * (XPOS,YPOS): The position where the field is calculated. * ZI, ZPOS : Shorthand complex notations. * (Last changed on 2/ 3/97.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. REAL XPOS,YPOS,EX,EY INTEGER I COMPLEX WPOS,WDPOS *** Initialise the potential and the electric field. EX=0 EY=0 * Get the mapping of the position. CALL EFCMAP(CMPLX(XPOS,YPOS)/COTUBE,WPOS,WDPOS) *** Loop over all wires. DO 10 I=1,NWIRE * Full contribution. IF(CNALSO(I))THEN EX=EX+(E(I)/COTUBE)*REAL(WDPOS*(1-ABS(WMAP(I))**2)/ - ((WPOS-WMAP(I))*(1-CONJG(WMAP(I))*WPOS))) EY=EY-(E(I)/COTUBE)*AIMAG(WDPOS*(1-ABS(WMAP(I))**2)/ - ((WPOS-WMAP(I))*(1-CONJG(WMAP(I))*WPOS))) * Mirror charges only. ELSE EX=EX+(E(I)/COTUBE)*REAL(WDPOS*CONJG(WMAP(I))/ - (1-CONJG(WMAP(I))*WPOS)) EY=EY-(E(I)/COTUBE)*AIMAG(WDPOS*CONJG(WMAP(I))/ - (1-CONJG(WMAP(I))*WPOS)) ENDIF *** Finish the loop over the wires. 10 CONTINUE END +DECK,EFMWIR. SUBROUTINE EFMWIR *----------------------------------------------------------------------- * EFMWIR - Computes the dipole moment of a given wire. * (Last changed on 11/ 6/96.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,CONSTANTS. +SEQ,PRINTPLOT. +SEQ,BFIELD. INTEGER NPOLE,NPOLER,NPOLES,NITMAX,I,IFAIL,INEXT,IW,NCFUN, - IWR COMMON /EFMDAT/ NPOLE PARAMETER(N=MXFPNT) CHARACTER*(MXCHAR) FUN CHARACTER*20 AUX CHARACTER*10 VARLIS(MXVAR) REAL PHI0(MXPOLE),POLE(MXPOLE),XPL(MXLIST),YPL(MXLIST), - VAR(MXVAR),RES(1),DRES,VLTMIN,VLTMAX,VLTAVE,RMULT, - RMULTR,EPSR DOUBLE PRECISION PAR(1+2*MXPOLE),ANGLE(N),VOLT(N),WEIGHT(N), - DIST,CHI2,EPS,DAUX,PARRES(1+2*MXPOLE),EPAR(1+2*MXPOLE) LOGICAL LFITPR,LFITPL,USE(MXVAR) INTEGER MODVAR(MXVAR),MODRES(1) EXTERNAL EFMFUN +SELF,IF=SAVE. SAVE IW,RMULT,NPOLES,NITMAX,EPS,LFITPR,LFITPL,VARLIS +SELF. DATA IW/0/, RMULT/1.0/, NPOLES/4/, NITMAX/20/, EPS/1.0E-4/, - LFITPR/.FALSE./, LFITPL/.FALSE./ DATA (VARLIS(I),I=1,9) / - 'ANGLE ','EX ','EY ','E ', - 'V ','BX ','BY ','BZ ', - 'B '/ *** Assume the routine fails. IFAIL=1 *** Special default handling for NPOLE which is in common. NPOLE=NPOLES *** Default function. FUN='V' NCFUN=1 *** Decode the argument string, get the number of words. CALL INPNUM(NWORD) INEXT=2 * Loop over the string. DO 100 I=2,NWORD IF(I.LT.INEXT)GOTO 100 * Epsilon for fitting purposes. IF(INPCMP(I,'EPS#ILON').NE.0)THEN IF(NWORD.LT.I+1.OR.INPTYP(I+1).LE.0)THEN CALL INPMSG(I,'Should have an argument. ') ELSE CALL INPCHK(I+1,2,IFAIL) CALL INPRDR(I+1,EPSR,0.0) IF(EPSR.LE.0.0.AND.IFAIL.EQ.0)THEN CALL INPMSG(I,'Epsilon must be positive. ') ELSEIF(IFAIL.EQ.0)THEN EPS=EPSR ENDIF INEXT=I+2 ENDIF * Function to be treated. ELSEIF(INPCMP(I,'F#UNCTION').NE.0)THEN IF(NWORD.LT.I+1)THEN CALL INPMSG(I,'Should have an argument. ') ELSE CALL INPSTR(I+1,I+1,FUN,NCFUN) INEXT=I+2 ENDIF * Maximum number of iterations. ELSEIF(INPCMP(I,'I#TERATE-#MAXIMUM').NE.0)THEN IF(NWORD.LT.I+1.OR.INPTYP(I+1).LE.0)THEN CALL INPMSG(I,'Should have an argument. ') ELSE CALL INPCHK(I+1,1,IFAIL) CALL INPRDI(I+1,NITMAR,0) IF(NITMAR.LT.0.AND.IFAIL.EQ.0)THEN CALL INPMSG(I,'Number of iterations < 0. ') ELSEIF(IFAIL.EQ.0)THEN NITMAX=NITMAR ENDIF INEXT=I+2 ENDIF * Highest multipole order. ELSEIF(INPCMP(I,'O#RDER').NE.0)THEN IF(NWORD.LT.I+1.OR.INPTYP(I+1).LE.0)THEN CALL INPMSG(I,'Should have an argument. ') ELSE CALL INPCHK(I+1,1,IFAIL) CALL INPRDI(I+1,NPOLER,0) IF((NPOLER.LE.0.OR.NPOLER.GT.MXPOLE).AND. - IFAIL.EQ.0)THEN CALL INPMSG(I,'Multipole order out of range. ') ELSEIF(IFAIL.EQ.0)THEN NPOLE=NPOLER ENDIF INEXT=I+2 ENDIF * Number of radii. ELSEIF(INPCMP(I,'R#ADIUS').NE.0)THEN IF(NWORD.LT.I+1.OR.INPTYP(I+1).LE.0)THEN CALL INPMSG(I,'Should have an argument. ') ELSE CALL INPCHK(I+1,2,IFAIL) CALL INPRDR(I+1,RMULTR,0.0) IF(RMULTR.LE.0.0.AND.IFAIL.EQ.0)THEN CALL INPMSG(I,'Wire number out of range. ') ELSEIF(IFAIL.EQ.0)THEN RMULT=RMULTR ENDIF INEXT=I+2 ENDIF * Print/Plot options. ELSEIF(INPCMP(I,'PL#OT').NE.0)THEN LFITPL=.TRUE. ELSEIF(INPCMP(I,'NOPL#OT').NE.0)THEN LFITPL=.FALSE. ELSEIF(INPCMP(I,'PR#INT').NE.0)THEN LFITPR=.TRUE. ELSEIF(INPCMP(I,'NOPR#INT').NE.0)THEN LFITPR=.FALSE. * Wire number. ELSEIF(INPCMP(I,'W#IRE').NE.0)THEN IF(NWORD.LT.I+1.OR.INPTYP(I+1).LE.0)THEN CALL INPMSG(I,'Should have an argument. ') ELSE CALL INPCHK(I+1,1,IFAIL) CALL INPRDI(I+1,IWR,0) IF((IWR.LE.0.OR.IWR.GT.NWIRE).AND.IFAIL.EQ.0)THEN CALL INPMSG(I,'Wire number out of range. ') ELSEIF(IFAIL.EQ.0)THEN IW=IWR ENDIF INEXT=I+2 ENDIF * Anything else. ELSE CALL INPMSG(I,'Not a known keyword; ignored. ') ENDIF 100 CONTINUE CALL INPERR *** Keep track of the default value for NPOLE. NPOLES=NPOLE *** Check the wire number again (cell change). IF(IW.LE.0.OR.IW.GT.NWIRE)THEN PRINT *,' !!!!!! EFMWIR WARNING : The wire number is not'// - ' within range (0 -> number of wires).' RETURN ENDIF *** Print the parameter settings. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ EFMWIR DEBUG : Parameter'', - '' settings:'',// - 5X,''Fit will be done for wire: '',I3,/, - 5X,''Function to be fitted: '',A,/, - 5X,''Highest multipole term fitted: '',I3,/, - 5X,''Radius multiplication factor: '',E15.8,/, - 5X,''Maximum number of iterations: '',I3,/, - 5X,''Epsilon for fitting purposes: '',E15.8,/, - 5X,''Plotting: '',L1,'', Printing: '',L1,/)') - IW,FUN(1:NCFUN),NPOLE,RMULT,NITMAX,EPS,LFITPL,LFITPR *** Set the radius of the wire to 0. DRES=D(IW) D(IW)=0.0 *** Translate the function. IF(INDEX(FUN(1:NCFUN),'@').NE.0)THEN NRES=0 CALL ALGEDT(VARLIS,9,IENTRY,USE,NRES) FUN='Edited function' NCFUN=15 IF(NRES.NE.1)THEN PRINT *,' !!!!!! EFMWIR WARNING : The edited'// - ' instruction list does not return 1 result;'// - ' no fit.' CALL ALGCLR(IENTRY) RETURN ENDIF ELSE CALL ALGPRE(FUN,NCFUN,VARLIS,9,NRES,USE,IENTRY,IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! EFMWIR WARNING : The function '// - FUN(1:NCFUN)//' is not fitted because of'// - ' syntax error(s).' CALL ALGCLR(IENTRY) RETURN ELSEIF(NRES.NE.1)THEN PRINT *,' !!!!!! EFMWIR WARNING : The function'// - ' does not return 1 result; no fit performed.' CALL ALGCLR(IENTRY) RETURN ENDIF ENDIF * Check use of variables. IF((.NOT.MAGOK).AND.(USE(6).OR.USE(7).OR.USE(8).OR.USE(9)))THEN PRINT *,' !!!!!! EFMWIR WARNING : The function relies on'// - ' a magnetic field, which is not defined.' CALL ALGCLR(IENTRY) RETURN ENDIF *** Loop around the wire. VLTMIN=0.0 VLTMAX=0.0 VLTAVE=0.0 DO 10 I=1,N * Set angle around wire. ANGLE(I)=2*PI*REAL(I)/REAL(N) * Set up variable list. VAR(1)=ANGLE(I) * Compute E field, make sure the point is in a free region. IF(USE(2).OR.USE(3).OR.USE(4).OR.USE(5))THEN CALL EFIELD(REAL(X(IW)+RMULT*DRES*COS(ANGLE(I))/2), - REAL(Y(IW)+RMULT*DRES*SIN(ANGLE(I))/2),0.0, - VAR(2),VAR(3),EZ,VAR(4),VAR(5),1,ILOC) IF(ILOC.NE.0)THEN PRINT *,' !!!!!! EFMWIR WARNING : Unexpected'// - ' location code received from EFIELD ;'// - ' computation stopped.' GOTO 3000 ENDIF ENDIF * Compute B field. IF(USE(6).OR.USE(7).OR.USE(8).OR.USE(9)) - CALL BFIELD(REAL(X(IW)+RMULT*DRES*COS(ANGLE(I))/2), - REAL(Y(IW)+RMULT*DRES*SIN(ANGLE(I))/2),0.0, - VAR(6),VAR(7),VAR(8),VAR(9)) * Assign the variable modes. DO 120 J=1,9 MODVAR(J)=2 120 CONTINUE * Evaluate the function. CALL ALGEXE(IENTRY,VAR,MODVAR,9,RES,MODRES,1,IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! EFMWIR WARNING : Algebra error'// - ' evaluating the function at the angle',ANGLE(I) GOTO 3000 ELSEIF(MODVAR(1).NE.2)THEN PRINT *,' !!!!!! EFMWIR WARNING : The result of the'// - ' function is not a number at the angle',ANGLE(I) GOTO 3000 ENDIF * Assign the result to the fitting array. VOLT(I)=RES(1) * Set weighting function to 1. WEIGHT(I)=1 * Keep track of the maximum, minimum and average. IF(I.EQ.1)THEN VLTMAX=VOLT(I) VLTMIN=VOLT(I) ELSE IF(VLTMAX.LT.VOLT(I))VLTMAX=VOLT(I) IF(VLTMIN.GT.VOLT(I))VLTMIN=VOLT(I) ENDIF VLTAVE=VLTAVE+VOLT(I) 10 CONTINUE * Subtract the wire potential to put centre the data more or less. VLTAVE=VLTAVE/REAL(N) DO 50 I=1,N VOLT(I)=VOLT(I)-VLTAVE 50 CONTINUE VLTMAX=VLTMAX-VLTAVE VLTMIN=VLTMIN-VLTAVE *** Perform the fit. CHI2=1E-6*N*(ABS(VLTMIN)+ABS(VLTMAX))**2/4 DIST=1E-3*(2.0+ABS(VLTMIN)+ABS(VLTMAX))/2 PAR(1)=(VLTMAX+VLTMIN)/2 DO 30 I=1,NPOLE PAR(2*I)=(VLTMAX-VLTMIN)/2 PAR(2*I+1)=0.0 30 CONTINUE CALL LSQFIT(EFMFUN,PAR,EPAR,2*NPOLE+1,ANGLE,VOLT,WEIGHT,N, - NITMAX,DIST,CHI2,EPS,LFITPR,IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! EFMWIR WARNING : The procedure fitting'// - ' the multipole failed ; computation stopped.' GOTO 3000 ENDIF *** Plot the result of the fit. IF(LFITPL)THEN * Frame with data curve. CALL GRGRP2(ANGLE,VOLT,N, - 'Angle around the wire [rad]', - FUN(1:NCFUN)//' - average', - 'MULTIPOLE FIT FOR A WIRE') IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) CALL OUTFMT(REAL(IW),2,AUX,NC,'LEFT') CALL GRCOMM(3,'Wire '//AUX(1:NC)//', type '// - WIRTYP(IW)) CALL OUTFMT(RMULT,2,AUX,NC,'LEFT') CALL GRCOMM(4,'Distance: '//AUX(1:NC)//' radii') * Sum of contributions. DO 20 I=1,MXLIST XPL(I)=2*PI*REAL(I)/REAL(MXLIST) CALL EFMFUN(DBLE(XPL(I)),PAR,DAUX) YPL(I)=REAL(DAUX) 20 CONTINUE CALL GRATTS('FUNCTION-2','POLYLINE') CALL GRLINE(MXLIST,XPL,YPL) * Individual contributions. CALL GRATTS('FUNCTION-3','POLYLINE') DO 70 I=1,2*NPOLE+1 PARRES(I)=PAR(I) IF(2*(I/2).EQ.I)PARRES(I)=0 70 CONTINUE DO 80 J=1,NPOLE PARRES(2*J)=PAR(2*J) DO 90 I=1,MXLIST CALL EFMFUN(DBLE(XPL(I)),PARRES,DAUX) YPL(I)=REAL(DAUX) 90 CONTINUE PARRES(2*J)=0 CALL GRLINE(MXLIST,XPL,YPL) 80 CONTINUE CALL GRNEXT CALL GRALOG('Multipole fit around a wire: ') ENDIF *** Remove radial terms from the multipole moments. DO 40 I=1,NPOLE POLE(I)=(RMULT*DRES/2)**I*PAR(2*I) PHI0(I)=180*MOD(REAL(PAR(2*I+1)),PI)/PI 40 CONTINUE *** Print the results. WRITE(LUNOUT,'('' Multipole moments for wire '',I3,'':''// - '' Moment Value Angle''/ - '' - - [degree]''/)') IW WRITE(LUNOUT,'(2X,I6,2X,E15.8,8X,''Arbitrary'')') 0,VLTAVE DO 60 I=1,NPOLE WRITE(LUNOUT,'(2X,I6,2X,E15.8,2X,E15.8)') I,POLE(I),PHI0(I) 60 CONTINUE WRITE(LUNOUT,'('' '')') *** Restore the wire diameter. 3000 CONTINUE D(IW)=DRES CALL ALGERR CALL ALGCLR(IENTRY) END +DECK,EFMFUN. SUBROUTINE EFMFUN(ANGLE,PAR,VALUE) *----------------------------------------------------------------------- * EFMFUN - Function used by the dipole moment calculting routine, is * called from the LSQFIT routine. * (Last changed on 3/12/90.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. COMMON /EFMDAT/ NPOLE DOUBLE PRECISION ANGLE,PAR(1+2*MXPOLE),VALUE REAL P(0:MXPOLE) *** Sum the series, initial value is the monopole term. VALUE=PAR(1) DO 10 I=1,NPOLE * Obtain the Legendre polynomial of this order. CALL ASLGF(2,REAL(COS(ANGLE-PAR(2*I+1))),0,I,P) * Add to the series. VALUE=VALUE+PAR(2*I)*P(I) 10 CONTINUE END +DECK,BFIELD. SUBROUTINE BFIELD(XIN,YIN,ZIN,BX,BY,BZ,BTOT) *----------------------------------------------------------------------- * BFIELD - Subroutine returning the magnetic field at (X1,Y1) * it calls -depending on the type of periodicity one of the * routines MAG00, MAGX0, MAG0Y or MAGXY. * VARIABLES : XIN,YIN,ZIN : Point where the B field is requested. * (Last changed on 25/ 2/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,BFIELD. REAL XIN,YIN,ZIN,BX,BY,BZ,BTOT,XPOS,YPOS,VAR(3),RES(1) INTEGER ILOC,MODVAR(3),NVAR,MODRES(1),NREXP,IFAIL, - ISB0X,ISV0X,ISB0Y,ISV0Y,ISB0Z,ISV0Z *** Computed field (0: absent, 1: constant, 2: formula, 3: table) IF(MAGSRC.EQ.1)THEN ** Compute Bx. IF(POLAR)THEN BX=0 ELSEIF(IBXTYP.EQ.0)THEN BX=0 ELSEIF(IBXTYP.EQ.1)THEN BX=B0X ELSEIF(IBXTYP.EQ.2)THEN VAR(1)=XIN VAR(2)=YIN VAR(3)=ZIN MODVAR(1)=2 MODVAR(2)=2 MODVAR(3)=2 NVAR=3 NREXP=1 CALL ALGEXE(IENB0X,VAR,MODVAR,NVAR,RES,MODRES,NREXP, - IFAIL) IF(IFAIL.EQ.0.AND.MODRES(1).EQ.2)THEN BX=RES(1) ELSE BX=0 ENDIF ELSEIF(IBXTYP.EQ.3)THEN IF(IBXDIR.EQ.1)THEN VAR(1)=XIN ELSEIF(IBXDIR.EQ.2)THEN VAR(1)=YIN ELSEIF(IBXDIR.EQ.3)THEN VAR(1)=ZIN ENDIF ISB0X=0 ISV0X=0 CALL MATIN1(IRV0X,IRB0X,1,VAR,RES,ISV0X,ISB0X,2,IFAIL) IF(IFAIL.EQ.0)THEN BX=RES(1) ELSE BX=0 ENDIF ENDIF ** Compute By. IF(POLAR)THEN BY=0 ELSEIF(IBYTYP.EQ.0)THEN BY=0 ELSEIF(IBYTYP.EQ.1)THEN BY=B0Y ELSEIF(IBYTYP.EQ.2)THEN VAR(1)=XIN VAR(2)=YIN VAR(3)=ZIN MODVAR(1)=2 MODVAR(2)=2 MODVAR(3)=2 NVAR=3 NREXP=1 CALL ALGEXE(IENB0Y,VAR,MODVAR,NVAR,RES,MODRES,NREXP, - IFAIL) IF(IFAIL.EQ.0.AND.MODRES(1).EQ.2)THEN BY=RES(1) ELSE BY=0 ENDIF ELSEIF(IBYTYP.EQ.3)THEN IF(IBYDIR.EQ.1)THEN VAR(1)=XIN ELSEIF(IBYDIR.EQ.2)THEN VAR(1)=YIN ELSEIF(IBYDIR.EQ.3)THEN VAR(1)=ZIN ENDIF ISB0Y=0 ISV0Y=0 CALL MATIN1(IRV0Y,IRB0Y,1,VAR,RES,ISV0Y,ISB0Y,2,IFAIL) IF(IFAIL.EQ.0)THEN BY=RES(1) ELSE BY=0 ENDIF ENDIF ** Compute Bz. IF(IBZTYP.EQ.0)THEN BZ=0 ELSEIF(IBZTYP.EQ.1)THEN BZ=B0Z ELSEIF(IBZTYP.EQ.2)THEN VAR(1)=XIN VAR(2)=YIN VAR(3)=ZIN MODVAR(1)=2 MODVAR(2)=2 MODVAR(3)=2 NVAR=3 NREXP=1 CALL ALGEXE(IENB0Z,VAR,MODVAR,NVAR,RES,MODRES,NREXP, - IFAIL) IF(IFAIL.EQ.0.AND.MODRES(1).EQ.2)THEN BZ=RES(1) ELSE BZ=0 ENDIF ELSEIF(IBZTYP.EQ.3)THEN IF(IBZDIR.EQ.1)THEN VAR(1)=XIN ELSEIF(IBZDIR.EQ.2)THEN VAR(1)=YIN ELSEIF(IBZDIR.EQ.3)THEN VAR(1)=ZIN ENDIF ISB0Z=0 ISV0Z=0 CALL MATIN1(IRV0Z,IRB0Z,1,VAR,RES,ISV0Z,ISB0Z,2,IFAIL) IF(IFAIL.EQ.0)THEN BZ=RES(1) ELSE BZ=0 ENDIF ENDIF ** Combined treatment if the wire distortion is taken into account. IF(IBXTYP.EQ.1.AND.IBYTYP.EQ.1.AND.IBZTYP.EQ.1.AND. - ALFA.NE.0)THEN * Reduce the coordinates in case of a periodic cell. IF(PERX)THEN XPOS=XIN-SX*ANINT(XIN/SX) ELSE XPOS=XIN ENDIF IF(PERY)THEN YPOS=YIN-SY*ANINT(YIN/SY) ELSE YPOS=YIN ENDIF * Next have the components of the field calculated. IF(.NOT.PERX.AND..NOT.PERY)CALL MAG00(XPOS,YPOS,BX,BY) IF( PERX.AND..NOT.PERY)CALL MAGX0(XPOS,YPOS,BX,BY) IF(.NOT.PERX.AND. PERY)CALL MAG0Y(XPOS,YPOS,BX,BY) IF( PERX.AND. PERY)CALL MAGXY(XPOS,YPOS,BX,BY) ENDIF *** Field map: interpolation. ELSE CALL MAGFMP(XIN,YIN,ZIN,BX,BY,BZ,ILOC) ENDIF *** Scale to V.microsec/cm2. BX=BX*BSCALE BY=BY*BSCALE BZ=BZ*BSCALE *** Calculate the norm, BTOT=SQRT(BX**2+BY**2+BZ**2) END +DECK,MAG00. SUBROUTINE MAG00(XIN,YIN,BX,BY) *----------------------------------------------------------------------- * MAG00 - Routine for magnetic field calculations non-periodic cells * (Last changed on 9/ 2/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,BFIELD. INTEGER I REAL XIN,YIN,BX,BY,XPOS,YPOS,R4,B1,B2 *** Loop over the wires. DO 10 I=1,NWIRE XPOS=XIN-X(I) YPOS=YIN-Y(I) R4 =(XPOS**2+YPOS**2)**2 IF(R4.LT.(0.5*D(I))**4)THEN BX=BX+ALFA*B0X BY=BY+ALFA*B0Y ELSE B1=(D(I)/2)**2*(XPOS**2-YPOS**2)/R4 B2=(D(I)/2)**2*(2*XPOS*YPOS)/R4 BX=BX+ALFA*( B0X*B1+B0Y*B2) BY=BY+ALFA*(-B0Y*B1+B0X*B2) ENDIF 10 CONTINUE END +DECK,MAGX0. SUBROUTINE MAGX0(XIN,YIN,BX,BY) *----------------------------------------------------------------------- * MAGX0 - Routine for magnetic field calculations x-periodic cells * (Last changed on 9/ 2/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,BFIELD. INTEGER I,J REAL XIN,YIN,BX,BY,XPOS,YPOS,R4,B1,B2 *** Loop over the periods. DO 10 J=-2,2 *** Loop over the wires. DO 20 I=1,NWIRE XPOS=XIN-X(I)+J*SX YPOS=YIN-Y(I) R4 =(XPOS**2+YPOS**2)**2 IF(R4.LT.(0.5*D(I))**4)THEN BX=BX+ALFA*B0X BY=BY+ALFA*B0Y ELSE B1=(D(I)/2)**2*(XPOS**2-YPOS**2)/R4 B2=(D(I)/2)**2*(2*XPOS*YPOS)/R4 BX=BX+ALFA*( B0X*B1+B0Y*B2) BY=BY+ALFA*(-B0Y*B1+B0X*B2) ENDIF 20 CONTINUE 10 CONTINUE END +DECK,MAG0Y. SUBROUTINE MAG0Y(XIN,YIN,BX,BY) *----------------------------------------------------------------------- * MAG0Y - Routine for magnetic field calculations y-periodic cells * (Last changed on 9/ 2/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,BFIELD. INTEGER I,J REAL XIN,YIN,BX,BY,XPOS,YPOS,R4,B1,B2 *** Loop over the periods. DO 10 J=-2,2 *** Loop over the wires. DO 20 I=1,NWIRE XPOS=XIN-X(I) YPOS=YIN-Y(I)+J*SY R4 =(XPOS**2+YPOS**2)**2 IF(R4.LT.(0.5*D(I))**4)THEN BX=BX+ALFA*B0X BY=BY+ALFA*B0Y ELSE B1=(D(I)/2)**2*(XPOS**2-YPOS**2)/R4 B2=(D(I)/2)**2*(2*XPOS*YPOS)/R4 BX=BX+ALFA*( B0X*B1+B0Y*B2) BY=BY+ALFA*(-B0Y*B1+B0X*B2) ENDIF 20 CONTINUE 10 CONTINUE END +DECK,MAGXY. SUBROUTINE MAGXY(XIN,YIN,BX,BY) *----------------------------------------------------------------------- * MAGXY - Routine for magnetic field calculations (bi-periodic cells) * (Last changed on 9/ 2/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,BFIELD. INTEGER I,J,K REAL XIN,YIN,BX,BY,XPOS,YPOS,R4,B1,B2 *** Loop over the periods. DO 10 K=-2,2 DO 20 J=-2,2 *** Loop over the wires. DO 30 I=1,NWIRE XPOS=XIN-X(I)+K*SX YPOS=YIN-Y(I)+J*SY R4 =(XPOS**2+YPOS**2)**2 IF(R4.LT.(0.5*D(I))**4)THEN BX=BX+ALFA*B0X BY=BY+ALFA*B0Y ELSE B1=(D(I)/2)**2*(XPOS**2-YPOS**2)/R4 B2=(D(I)/2)**2*(2*XPOS*YPOS)/R4 BX=BX+ALFA*( B0X*B1+B0Y*B2) BY=BY+ALFA*(-B0Y*B1+B0X*B2) ENDIF 30 CONTINUE 20 CONTINUE 10 CONTINUE END +DECK,MAGFMP. SUBROUTINE MAGFMP(XIN,YIN,ZIN,BX,BY,BZ,ILOC) *----------------------------------------------------------------------- * MAGFMP - Interpolates the B field map at (XPOS,YPOS,ZPOS). * (Last changed on 30/ 4/99.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,FIELDMAP. +SEQ,CELLDATA. +SEQ,CONSTANTS. REAL XIN,YIN,ZIN,XPOS,YPOS,ZPOS,BX,BY,BZ,XNEW,YNEW,ZNEW, - T1,T2,T3,T4,AUXPHI,AUXR,AROT,XAUX,YAUX INTEGER ILOC,IMAP,NX,NY,NZ LOGICAL MIRRX,MIRRY,MIRRZ *** Initial values. BX=0 BY=0 BZ=0 ILOC=0 XPOS=XIN YPOS=YIN ZPOS=ZIN *** First see whether we at all have a grid. IF(.NOT.MAPFLG(1))RETURN *** If chamber is periodic, reduce to the cell volume. MIRRX=.FALSE. IF(PERX)THEN XPOS=XMMIN+MOD(XPOS-XMMIN,XMMAX-XMMIN) IF(XPOS.LT.XMMIN)XPOS=XPOS+(XMMAX-XMMIN) ELSEIF(PERMX)THEN XNEW=XMMIN+MOD(XPOS-XMMIN,XMMAX-XMMIN) IF(XNEW.LT.XMMIN)XNEW=XNEW+(XMMAX-XMMIN) NX=NINT((XNEW-XPOS)/(XMMAX-XMMIN)) IF(NX.NE.2*(NX/2))THEN XNEW=XMMIN+XMMAX-XNEW MIRRX=.TRUE. ENDIF XPOS=XNEW ENDIF IF(PERAX.AND.(ZPOS.NE.0.OR.YPOS.NE.0))THEN AUXR=SQRT(ZPOS**2+YPOS**2) AUXPHI=ATAN2(ZPOS,YPOS) AROT=(XAMAX-XAMIN)*ANINT((AUXPHI-0.5*(XAMIN+XAMAX))/ - (XAMAX-XAMIN)) IF(AUXPHI-AROT.LT.XAMIN)AROT=AROT-(XAMAX-XAMIN) IF(AUXPHI-AROT.GT.XAMAX)AROT=AROT+(XAMAX-XAMIN) AUXPHI=AUXPHI-AROT YPOS=AUXR*COS(AUXPHI) ZPOS=AUXR*SIN(AUXPHI) ENDIF MIRRY=.FALSE. IF(PERY)THEN YPOS=YMMIN+MOD(YPOS-YMMIN,YMMAX-YMMIN) IF(YPOS.LT.YMMIN)YPOS=YPOS+(YMMAX-YMMIN) ELSEIF(PERMY)THEN YNEW=YMMIN+MOD(YPOS-YMMIN,YMMAX-YMMIN) IF(YNEW.LT.YMMIN)YNEW=YNEW+(YMMAX-YMMIN) NY=NINT((YNEW-YPOS)/(YMMAX-YMMIN)) IF(NY.NE.2*(NY/2))THEN YNEW=YMMIN+YMMAX-YNEW MIRRY=.TRUE. ENDIF YPOS=YNEW ENDIF IF(PERAY.AND.(XPOS.NE.0.OR.ZPOS.NE.0))THEN AUXR=SQRT(XPOS**2+ZPOS**2) AUXPHI=ATAN2(XPOS,ZPOS) AROT=(YAMAX-YAMIN)*ANINT((AUXPHI-0.5*(YAMIN+YAMAX))/ - (YAMAX-YAMIN)) IF(AUXPHI-AROT.LT.YAMIN)AROT=AROT-(YAMAX-YAMIN) IF(AUXPHI-AROT.GT.YAMAX)AROT=AROT+(YAMAX-YAMIN) AUXPHI=AUXPHI-AROT ZPOS=AUXR*COS(AUXPHI) XPOS=AUXR*SIN(AUXPHI) ENDIF MIRRZ=.FALSE. IF(PERZ)THEN ZPOS=ZMMIN+MOD(ZPOS-ZMMIN,ZMMAX-ZMMIN) IF(ZPOS.LT.ZMMIN)ZPOS=ZPOS+(ZMMAX-ZMMIN) ELSEIF(PERMZ)THEN ZNEW=ZMMIN+MOD(ZPOS-ZMMIN,ZMMAX-ZMMIN) IF(ZNEW.LT.ZMMIN)ZNEW=ZNEW+(ZMMAX-ZMMIN) NZ=NINT((ZNEW-ZPOS)/(ZMMAX-ZMMIN)) IF(NZ.NE.2*(NZ/2))THEN ZNEW=ZMMIN+ZMMAX-ZNEW MIRRZ=.TRUE. ENDIF ZPOS=ZNEW ENDIF IF(PERAZ.AND.(YPOS.NE.0.OR.XPOS.NE.0))THEN AUXR=SQRT(YPOS**2+XPOS**2) AUXPHI=ATAN2(YPOS,XPOS) AROT=(ZAMAX-ZAMIN)*ANINT((AUXPHI-0.5*(ZAMIN+ZAMAX))/ - (ZAMAX-ZAMIN)) IF(AUXPHI-AROT.LT.ZAMIN)AROT=AROT-(ZAMAX-ZAMIN) IF(AUXPHI-AROT.GT.ZAMAX)AROT=AROT+(ZAMAX-ZAMIN) AUXPHI=AUXPHI-AROT XPOS=AUXR*COS(AUXPHI) YPOS=AUXR*SIN(AUXPHI) ENDIF *** Locate the point. CALL MAPIND(XPOS,YPOS,ZPOS,T1,T2,T3,T4,IMAP) IF(IMAP.LE.0.OR.IMAP.GT.NMAP)THEN ILOC=-6 RETURN ENDIF *** Nbxt perform a 3-dimensional interpolation, linear ... IF((MAPTYP.EQ.11.OR.MAPTYP.EQ.12.OR.MAPTYP.EQ.13).AND. - MAPORD.EQ.1)THEN IF(MAPFLG(6))BX=BXMAP(IMAP,1)*T1+BXMAP(IMAP,2)*T2+ - BXMAP(IMAP,3)*T3+BXMAP(IMAP,4)*T4 IF(MAPFLG(7))BY=BYMAP(IMAP,1)*T1+BYMAP(IMAP,2)*T2+ - BYMAP(IMAP,3)*T3+BYMAP(IMAP,4)*T4 IF(MAPFLG(8))BZ=BZMAP(IMAP,1)*T1+BZMAP(IMAP,2)*T2+ - BZMAP(IMAP,3)*T3+BZMAP(IMAP,4)*T4 * or quadratic. ELSEIF(MAPTYP.EQ.12.AND.MAPORD.EQ.2)THEN IF(MAPFLG(6))BX= - BXMAP(IMAP,1)*T1*(2*T1-1)+BXMAP(IMAP,2)*T2*(2*T2-1)+ - BXMAP(IMAP,3)*T3*(2*T3-1)+BXMAP(IMAP,4)*T4*(2*T4-1)+ - 4*BXMAP(IMAP,5)*T1*T2+4*BXMAP(IMAP,6)*T1*T3+ - 4*BXMAP(IMAP,7)*T1*T4+4*BXMAP(IMAP,8)*T2*T3+ - 4*BXMAP(IMAP,9)*T2*T4+4*BXMAP(IMAP,10)*T3*T4 IF(MAPFLG(7))BY= - BYMAP(IMAP,1)*T1*(2*T1-1)+BYMAP(IMAP,2)*T2*(2*T2-1)+ - BYMAP(IMAP,3)*T3*(2*T3-1)+BYMAP(IMAP,4)*T4*(2*T4-1)+ - 4*BYMAP(IMAP,5)*T1*T2+4*BYMAP(IMAP,6)*T1*T3+ - 4*BYMAP(IMAP,7)*T1*T4+4*BYMAP(IMAP,8)*T2*T3+ - 4*BYMAP(IMAP,9)*T2*T4+4*BYMAP(IMAP,10)*T3*T4 IF(MAPFLG(8))BZ= - BZMAP(IMAP,1)*T1*(2*T1-1)+BZMAP(IMAP,2)*T2*(2*T2-1)+ - BZMAP(IMAP,3)*T3*(2*T3-1)+BZMAP(IMAP,4)*T4*(2*T4-1)+ - 4*BZMAP(IMAP,5)*T1*T2+4*BZMAP(IMAP,6)*T1*T3+ - 4*BZMAP(IMAP,7)*T1*T4+4*BZMAP(IMAP,8)*T2*T3+ - 4*BZMAP(IMAP,9)*T2*T4+4*BZMAP(IMAP,10)*T3*T4 *** Or perform a 2-dimensional interpolation, linear ... ELSEIF((MAPTYP.EQ.1.OR.MAPTYP.EQ.2.OR.MAPTYP.EQ.3).AND. - MAPORD.EQ.1)THEN IF(MAPFLG(6))BX= - BXMAP(IMAP,1)*T1+BXMAP(IMAP,2)*T2+BXMAP(IMAP,3)*T3 IF(MAPFLG(7))BY= - BYMAP(IMAP,1)*T1+BYMAP(IMAP,2)*T2+BYMAP(IMAP,3)*T3 IF(MAPFLG(8))BZ= - BZMAP(IMAP,1)*T1+BZMAP(IMAP,2)*T2+BZMAP(IMAP,3)*T3 * or quadratic. ELSEIF(MAPTYP.EQ.2.AND.MAPORD.EQ.2)THEN IF(MAPFLG(6))BX= - BXMAP(IMAP,1)*T1*(2*T1-1)+BXMAP(IMAP,2)*T2*(2*T2-1)+ - BXMAP(IMAP,3)*T3*(2*T3-1)+4*BXMAP(IMAP,4)*T1*T2+ - 4*BXMAP(IMAP,5)*T1*T3+4*BXMAP(IMAP,6)*T2*T3 IF(MAPFLG(7))BY= - BYMAP(IMAP,1)*T1*(2*T1-1)+BYMAP(IMAP,2)*T2*(2*T2-1)+ - BYMAP(IMAP,3)*T3*(2*T3-1)+4*BYMAP(IMAP,4)*T1*T2+ - 4*BYMAP(IMAP,5)*T1*T3+4*BYMAP(IMAP,6)*T2*T3 IF(MAPFLG(8))BZ= - BZMAP(IMAP,1)*T1*(2*T1-1)+BZMAP(IMAP,2)*T2*(2*T2-1)+ - BZMAP(IMAP,3)*T3*(2*T3-1)+4*BZMAP(IMAP,4)*T1*T2+ - 4*BZMAP(IMAP,5)*T1*T3+4*BZMAP(IMAP,6)*T2*T3 *** Or an interpolation on a regular hbxahedron, linear. ELSEIF(MAPTYP.EQ.14)THEN IF(MAPFLG(6))BX= - BXMAP(IMAP,1)*(1-T1)*(1-T2)*(1-T3)+ - BXMAP(IMAP,2)* T1 *(1-T2)*(1-T3)+ - BXMAP(IMAP,3)* T1 * T2 *(1-T3)+ - BXMAP(IMAP,4)*(1-T1)* T2 *(1-T3)+ - BXMAP(IMAP,5)*(1-T1)*(1-T2)* T3 + - BXMAP(IMAP,6)* T1 *(1-T2)* T3 + - BXMAP(IMAP,7)* T1 * T2 * T3 + - BXMAP(IMAP,8)*(1-T1)* T2 * T3 IF(MAPFLG(7))BY= - BYMAP(IMAP,1)*(1-T1)*(1-T2)*(1-T3)+ - BYMAP(IMAP,2)* T1 *(1-T2)*(1-T3)+ - BYMAP(IMAP,3)* T1 * T2 *(1-T3)+ - BYMAP(IMAP,4)*(1-T1)* T2 *(1-T3)+ - BYMAP(IMAP,5)*(1-T1)*(1-T2)* T3 + - BYMAP(IMAP,6)* T1 *(1-T2)* T3 + - BYMAP(IMAP,7)* T1 * T2 * T3 + - BYMAP(IMAP,8)*(1-T1)* T2 * T3 IF(MAPFLG(8))BZ= - BZMAP(IMAP,1)*(1-T1)*(1-T2)*(1-T3)+ - BZMAP(IMAP,2)* T1 *(1-T2)*(1-T3)+ - BZMAP(IMAP,3)* T1 * T2 *(1-T3)+ - BZMAP(IMAP,4)*(1-T1)* T2 *(1-T3)+ - BZMAP(IMAP,5)*(1-T1)*(1-T2)* T3 + - BZMAP(IMAP,6)* T1 *(1-T2)* T3 + - BZMAP(IMAP,7)* T1 * T2 * T3 + - BZMAP(IMAP,8)*(1-T1)* T2 * T3 *** Or an unknown case. ELSE ILOC=-10 RETURN ENDIF *** Apply mirror imaging. IF(MIRRX)BX=-BX IF(MIRRY)BY=-BY IF(MIRRZ)BZ=-BZ *** Rotate the field. IF(PERAX)THEN CALL CFMCTP(BY,BZ,XAUX,YAUX,1) YAUX=YAUX+AROT*180/PI CALL CFMPTC(XAUX,YAUX,BY,BZ,1) ENDIF IF(PERAY)THEN CALL CFMCTP(BZ,BX,XAUX,YAUX,1) YAUX=YAUX+AROT*180/PI CALL CFMPTC(XAUX,YAUX,BZ,BX,1) ENDIF IF(PERAZ)THEN CALL CFMCTP(BX,BY,XAUX,YAUX,1) YAUX=YAUX+AROT*180/PI CALL CFMPTC(XAUX,YAUX,BX,BY,1) ENDIF *** And store material index. IF(MATMAP(IMAP).EQ.IDRMAT.OR..NOT.MAPFLG(9))THEN ILOC=0 ELSE ILOC=-5 ENDIF END +DECK,EFQA00. SUBROUTINE EFQA00(IFAIL) *----------------------------------------------------------------------- * EFQA00 - Routine preparing the field calculations by filling the * capacitance matrix. This routines handles configurations * with not more than one plane in either x or y and not more * than one dielectricum in total. * VARIABLES : No local variables. *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,CAPACMATRIX. COMMON /TMPA00/ EPSMT1,EPSMT2 *** Check the configuration of dielectrica is acceptable. IF(NXMATT+NYMATT.GT.1.OR. - (NXMATT.EQ.1.AND.XMATT(1,3).EQ.0.AND.XMATT(1,4).EQ.0).OR. - (NYMATT.EQ.1.AND.YMATT(1,3).EQ.0.AND.YMATT(1,4).EQ.0))THEN PRINT *,' ###### EFQA00 ERROR : The configuration of'// - ' dielectrica can not yet be handled ; cell rejected.' IFAIL=1 RETURN ELSE PRINT *,' ------ EFQA00 MESSAGE : Potentials handled by'// - ' experimental routine.' ENDIF *** Prepare some auxilliary variables for dielectrica. YNMATX=.FALSE. YNMATY=.FALSE. COMATX=0.0 COMATY=0.0 EPSMT1=0.0 EPSMT2=0.0 IF(NXMATT.EQ.1)THEN YNMATX=.TRUE. IF(XMATT(1,3).NE.0)COMATX=XMATT(1,2) IF(XMATT(1,4).NE.0)COMATX=XMATT(1,1) EPSMT1=(1-XMATT(1,5))/(1+XMATT(1,5)) EPSMT2=2/(1+XMATT(1,5)) ELSEIF(NYMATT.EQ.1)THEN YNMATY=.TRUE. IF(YMATT(1,3).NE.0)COMATY=YMATT(1,2) IF(YMATT(1,4).NE.0)COMATY=YMATT(1,1) EPSMT1=(1-YMATT(1,5))/(1+YMATT(1,5)) EPSMT2=2/(1+YMATT(1,5)) ENDIF *** Loop over all wire combinations. DO 10 I=1,NWIRE A(I,I)=0.25*D(I)**2 *** Take care of the equipotential planes. IF(YNPLAX)A(I,I)=A(I,I)/(2.0*(X(I)-COPLAX))**2 IF(YNPLAY)A(I,I)=A(I,I)/(2.0*(Y(I)-COPLAY))**2 *** Take care of combinations of equipotential planes. IF(YNPLAX.AND.YNPLAY)A(I,I)=4.0*A(I,I)*((X(I)-COPLAX)**2+ - (Y(I)-COPLAY)**2) *** Before adding dielectrica, take the log. A(I,I)=-0.5*LOG(A(I,I)) *** One x-dielectricum. IF(YNMATX)THEN * Dielectricum charge. A(I,I)=A(I,I)-EPSMT1*LOG(2*ABS(X(I)-COMATX)) * Add single plane reflected dielectricum charges. IF(YNPLAX)A(I,I)=A(I,I)+ - EPSMT1*LOG(ABS(2*COPLAX-2*COMATX+X(I))) IF(YNPLAY)A(I,I)=A(I,I)+ - EPSMT1*0.5*LOG((2*COMATX-X(I))**2+(2*COPLAY-Y(I))**2) * Add double plane reflected dielectricum charges. IF(YNPLAX.AND.YNPLAY)A(I,I)=A(I,I)- - EPSMT1*0.5*LOG((2*COPLAX-2*COMATX+X(I))**2+ - (2*COPLAY-Y(I))**2) *** One y-dielectricum. ELSEIF(YNMATY)THEN * Dielectricum charge. A(I,I)=A(I,I)-EPSMT1*LOG(2*ABS(Y(I)-COMATY)) * Add single plane reflected dielectricum charges. IF(YNPLAX)A(I,I)=A(I,I)+ - EPSMT1*0.5*LOG((2*COPLAX-X(I))**2+(2*COMATY-Y(I))**2) IF(YNPLAY)A(I,I)=A(I,I)+ - EPSMT1*LOG(ABS(2*COPLAY-2*COMATY+Y(I))) * Add double plane reflected dielectricum charges. IF(YNPLAX.AND.YNPLAY)A(I,I)=A(I,I)- - EPSMT1*0.5*LOG((2*COPLAX-X(I))**2+ - (2*COPLAY-2*COMATY+Y(I))**2) ENDIF *** Loop over all other wires for the off-diagonal elements. DO 20 J=I+1,NWIRE A(I,J)=(X(I)-X(J))**2+(Y(I)-Y(J))**2 *** Take care of equipotential planes. IF(YNPLAX)A(I,J)=A(I,J)/((X(I)+X(J)-2.*COPLAX)**2+(Y(I)-Y(J))**2) IF(YNPLAY)A(I,J)=A(I,J)/((X(I)-X(J))**2+(Y(I)+Y(J)-2.*COPLAY)**2) *** Take care of pairs of equipotential planes in different directions. IF(YNPLAX.AND.YNPLAY)A(I,J)= - A(I,J)*((X(I)+X(J)-2.*COPLAX)**2+(Y(I)+Y(J)-2.*COPLAY)**2) *** Take the log before adding dielectrica. A(I,J)=-0.5*LOG(A(I,J)) *** One x-dielectricum. IF(YNMATX)THEN * Dielectricum charge. A(I,J)=A(I,J)-EPSMT1*0.5* - LOG((X(I)+X(J)-2*COMATX)**2+(Y(I)-Y(J))**2) * Add single plane reflected dielectricum charges. IF(YNPLAX)A(I,J)=A(I,J)+ - EPSMT1*0.5*LOG((2*COPLAX-2*COMATX+X(I)-X(J))**2+ - (Y(I)-Y(J))**2) IF(YNPLAY)A(I,J)=A(I,J)+ - EPSMT1*0.5*LOG((X(I)+X(J)-2*COMATX)**2+ - (Y(I)+Y(J)-2*COPLAY)**2) * Add double plane reflected dielectricum charges. IF(YNPLAX.AND.YNPLAY)A(I,J)=A(I,J)- - EPSMT1*0.5*LOG((2*COPLAX-2*COMATX+X(I)-X(J))**2+ - (Y(I)+Y(J)-2*COPLAY)**2) *** One y-dielectricum. ELSEIF(YNMATY)THEN * Dielectricum charge. A(I,J)=A(I,J)-EPSMT1*0.5* - LOG((X(I)-X(J))**2+(Y(I)+Y(J)-2*COMATY)**2) * Add single plane reflected dielectricum charges. IF(YNPLAX)A(I,J)=A(I,J)+ - EPSMT1*0.5*LOG((X(I)+X(J)-2*COPLAX)**2+ - (Y(I)+Y(J)-2*COMATY)**2) IF(YNPLAY)A(I,J)=A(I,J)+ - EPSMT1*0.5*LOG((X(I)-X(J))**2+ - (2*COPLAY-2*COMATY+Y(I)-Y(J))**2) * Add double plane reflected dielectricum charges. IF(YNPLAX.AND.YNPLAY)A(I,J)=A(I,J)- - EPSMT1*0.5*LOG((X(I)+X(J)-2*COPLAX)**2+ - (2*COPLAY-2*COMATY+Y(I)-Y(J))**2) ENDIF *** Copy this to A(J,I) since the capacitance matrix is symmetric. A(J,I)=A(I,J) 20 CONTINUE 10 CONTINUE *** Call CHARGE to calculate the charges really. CALL CHARGE(IFAIL) END +DECK,EFDA00. SUBROUTINE EFDA00(XPOS,YPOS,EX,EY,VOLT,IOPT) *----------------------------------------------------------------------- * EFDA00 - Subroutine performing the actual field calculations in case * the charges have been prepared by EFQA00. * VARIABLES : R2 : Potential before taking -log(sqrt(...)) * EX, EY : x,y-component of the electric field. * ETOT : Magnitude of electric field. * VOLT : Potential. * EXHELP etc : One term in the series to be summed. * (XPOS,YPOS): The position where the field is calculated. *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,CELLDATA. COMMON /TMPA00/ EPSMT1,EPSMT2 *** Initialise the potential and the electric field. EX=0.0 EY=0.0 VOLT=V0 *** Loop over all wires. DO 10 I=1,NWIRE *** Calculate the field in case there are no planes. R2=(XPOS-X(I))**2+(YPOS-Y(I))**2 EXHELP=(XPOS-X(I))/R2 EYHELP=(YPOS-Y(I))/R2 *** Take care of a plane at constant x. IF(YNPLAX)THEN XXMIRR=X(I)+(XPOS-2.0*COPLAX) R2PLAN=XXMIRR**2+(YPOS-Y(I))**2 EXHELP=EXHELP-XXMIRR/R2PLAN EYHELP=EYHELP-(YPOS-Y(I))/R2PLAN R2=R2/R2PLAN ENDIF *** Take care of a plane at constant y. IF(YNPLAY)THEN YYMIRR=Y(I)+(YPOS-2.0*COPLAY) R2PLAN=(XPOS-X(I))**2+YYMIRR**2 EXHELP=EXHELP-(XPOS-X(I))/R2PLAN EYHELP=EYHELP-YYMIRR/R2PLAN R2=R2/R2PLAN ENDIF *** Take care of pairs of planes. IF(YNPLAX.AND.YNPLAY)THEN R2PLAN=XXMIRR**2+YYMIRR**2 EXHELP=EXHELP+XXMIRR/R2PLAN EYHELP=EYHELP+YYMIRR/R2PLAN R2=R2*R2PLAN ENDIF *** Calculate the electric field and the potential. IF((YNMATX.AND.((XPOS.LT.COMATX.AND.XMATT(1,3).NE.0).OR. - (XPOS.GT.COMATX.AND.XMATT(1,4).NE.0))).OR. - (YNMATY.AND.((YPOS.LT.COMATY.AND.YMATT(1,3).NE.0).OR. - (YPOS.GT.COMATY.AND.YMATT(1,4).NE.0))))THEN IF(IOPT.NE.0)VOLT=VOLT-0.5*E(I)*EPSMT2*LOG(R2) EX=EX+E(I)*EPSMT2*EXHELP EY=EY+E(I)*EPSMT2*EYHELP ELSE IF(IOPT.NE.0)VOLT=VOLT-0.5*E(I)*LOG(R2) EX=EX+E(I)*EXHELP EY=EY+E(I)*EYHELP ENDIF *** Dielectric mediums, no planes. IF(YNMATX.AND.((XPOS.GT.COMATX.AND.XMATT(1,3).NE.0).OR. - (XPOS.LT.COMATX.AND.XMATT(1,4).NE.0)))THEN IF(IOPT.NE.0)VOLT=VOLT-E(I)*EPSMT1*0.5* - LOG((XPOS+X(I)-2*COMATX)**2+(YPOS-Y(I))**2) EX=EX-E(I)*EPSMT1*0.5*(XPOS+X(I)-2*COMATX)/ - SQRT((XPOS+X(I)-2*COMATX)**2+(YPOS-Y(I))**2) EY=EY-E(I)*EPSMT1*0.5*(YPOS-Y(I))/ - SQRT((XPOS+X(I)-2*COMATX)**2+(YPOS-Y(I))**2) ENDIF IF(YNMATY.AND.((YPOS.GT.COMATY.AND.YMATT(1,3).NE.0).OR. - (YPOS.LT.COMATY.AND.YMATT(1,4).NE.0)))THEN IF(IOPT.NE.0)VOLT=VOLT-E(I)*EPSMT1*0.5* - LOG((YPOS+Y(I)-2*COMATY)**2+(XPOS-X(I))**2) EX=EX-E(I)*EPSMT1*0.5*(YPOS+Y(I)-2*COMATY)/ - SQRT((YPOS+Y(I)-2*COMATY)**2+(XPOS-X(I))**2) EY=EY-E(I)*EPSMT1*0.5*(XPOS-X(I))/ - SQRT((YPOS+Y(I)-2*COMATY)**2+(XPOS-X(I))**2) ENDIF *** Finish the loop over the wires. 10 CONTINUE END +DECK,EFCCAL. SUBROUTINE EFCCAL(INSTR,IFAIL) *----------------------------------------------------------------------- * EFCCAL - Processes electric and magnetic field related procedure * calls. * (Last changed on 20/ 1/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,ALGDATA. +SEQ,MATDATA. +SEQ,FIELDMAP. +SEQ,PARAMETERS. INTEGER INSTR,IFAIL,IFAIL1,IPROC,NARG,ISTR,ILOC,IAUX,NU,NV,NC, - IREF(9),ISLOT(9),NDAT,MATSLT,ISIZ(MXMDIM),IDIM,I,J,IMAP REAL BTOT,XPOS,YPOS,ZPOS,T1,T2,T3,T4,VXMIN,VYMIN,VXMAX,VYMAX CHARACTER*80 TITLE EXTERNAL MATSLT *** Assume the CALL will fail. IFAIL=1 *** Make sure that a cell is available IF(.NOT.CELSET)THEN PRINT *,' !!!!!! EFCCAL WARNING : Cell data not available'// - ' ; call not executed.' RETURN ENDIF *** Some easy reference variables. NARG=INS(INSTR,3) IPROC=INS(INSTR,1) *** Electric field in 2 dimensions. IF(IPROC.EQ.-301)THEN * Check number of arguments. IF(NARG.LT.3.OR.NARG.GT.8)THEN PRINT *,' !!!!!! EFCCAL WARNING : Incorrect number'// - ' of arguments for ELECTRIC_FIELD.' RETURN * Check argument mode. ELSEIF((MODARG(1).NE.2.AND.MODARG(1).NE.5).OR. - (MODARG(2).NE.2.AND.MODARG(2).NE.5))THEN PRINT *,' !!!!!! EFCCAL WARNING : Some arguments of'// - ' ELECTRIC_FIELD are of incorrect type.' RETURN * Check the the results can be transferred back. ELSEIF((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 *,' !!!!!! EFCCAL WARNING : Some arguments'// - ' of ELECTRIC_FIELD can not be modified.' RETURN ENDIF * Clear variables that will be overwritten. DO 200 ISTR=3,NARG CALL ALGREU(NINT(ARG(ISTR)),MODARG(ISTR),ARGREF(ISTR,1)) 200 CONTINUE ** Carry out the calculation, first for all scalar arguments. IF(MODARG(1).EQ.2.AND.MODARG(2).EQ.2)THEN CALL EFIELD(ARG(1),ARG(2),0.0,ARG(3), - ARG(4),ARG(5),ARG(6),ARG(7),1,ILOC) MODARG(3)=2 MODARG(4)=2 MODARG(5)=2 MODARG(6)=2 MODARG(7)=2 IF(NARG.GE.8)THEN IF(ILOC.EQ.-10)THEN CALL STRBUF('STORE',IAUX, - 'Unknown potential',17,IFAIL1) ELSEIF(ILOC.EQ.-5)THEN CALL STRBUF('STORE',IAUX, - 'In a material',13,IFAIL1) ELSEIF(ILOC.EQ.-6)THEN CALL STRBUF('STORE',IAUX, - 'Outside mesh',12,IFAIL1) ELSEIF(ILOC.LT.0)THEN CALL STRBUF('STORE',IAUX, - 'Outside plane',13,IFAIL1) ELSEIF(ILOC.EQ.0)THEN CALL STRBUF('STORE',IAUX, - 'Normal',6,IFAIL1) ELSEIF(ILOC.LE.NWIRE)THEN CALL STRBUF('STORE',IAUX,'In an '// - WIRTYP(ILOC)//' wire',12,IFAIL1) ELSE CALL STRBUF('STORE',IAUX,'Unknown',7,IFAIL1) ENDIF ARG(8)=REAL(IAUX) MODARG(8)=1 * Error processing. IF(IFAIL1.NE.0) - PRINT *,' !!!!!! EFCCAL WARNING : '// - 'Error storing a string for ELECTRIC_FIELD.' ENDIF ** At least one of them is a matrix. ELSE * Figure out what the dimensions are. NDAT=-1 DO 30 I=1,2 IF(MODARG(I).EQ.5)THEN IREF(I)=NINT(ARG(I)) ISLOT(I)=MATSLT(IREF(I)) IF(ISLOT(I).LE.0)THEN PRINT *,' !!!!!! EFCCAL WARNING : Unable'// - ' locate a input matrix.' RETURN ELSEIF(MMOD(ISLOT(I)).NE.2)THEN PRINT *,' !!!!!! EFCCAL WARNING : x, y'// - ' Or z matrix of incorrect type.' RETURN ENDIF IF(NDAT.LT.0)THEN NDAT=MLEN(ISLOT(I)) DO 10 J=1,MDIM(ISLOT(I)) ISIZ(J)=MSIZ(ISLOT(I),J) 10 CONTINUE IDIM=MDIM(ISLOT(I)) ELSEIF(NDAT.NE.MLEN(ISLOT(I)))THEN PRINT *,' !!!!!! EFCCAL WARNING : x, y'// - ' And z have inconsistent lengths.' RETURN ENDIF ENDIF 30 CONTINUE IF(NDAT.LT.1)THEN PRINT *,' !!!!!! EFCCAL WARNING : Unable'// - ' to find an x, y or z matrix.' RETURN ENDIF * Now book matrices for the missing elements and initialise them. DO 40 I=1,2 IF(MODARG(I).NE.5)THEN CALL MATADM('ALLOCATE',IREF(I),IDIM,ISIZ,2,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! EFCCAL WARNING : Unable'// - ' to get a replacement matrix.' RETURN ENDIF ISLOT(I)=MATSLT(IREF(I)) IF(ISLOT(I).LE.0)THEN PRINT *,' !!!!!! EFCCAL WARNING : Unable'// - ' to locate a replacement matrix.' RETURN ENDIF DO 50 J=1,MLEN(ISLOT(I)) MVEC(MORG(ISLOT(I))+J)=ARG(I) 50 CONTINUE ENDIF 40 CONTINUE * Allocate the 6 output arrays (Ex, Ey, Ez, E, V, status). DO 20 I=4,9 CALL MATADM('ALLOCATE',IREF(I),IDIM,ISIZ,2,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! EFCCAL WARNING : Unable'// - ' to get an output matrix.' RETURN ENDIF 20 CONTINUE * And finally locate all 9 matrices. DO 60 I=1,9 IF(I.EQ.3)GOTO 60 ISLOT(I)=MATSLT(IREF(I)) IF(ISLOT(I).LE.0)THEN PRINT *,' !!!!!! EFCCAL WARNING : Unable'// - ' to locate an input or output matrix.' RETURN ENDIF 60 CONTINUE * And compute the data. DO 70 I=1,NDAT CALL EFIELD(MVEC(MORG(ISLOT(1))+I), - MVEC(MORG(ISLOT(2))+I),0.0, - MVEC(MORG(ISLOT(4))+I),MVEC(MORG(ISLOT(5))+I), - MVEC(MORG(ISLOT(6))+I),MVEC(MORG(ISLOT(7))+I), - MVEC(MORG(ISLOT(8))+I),1,ILOC) MVEC(MORG(ISLOT(9))+I)=REAL(ILOC) 70 CONTINUE * Delete temporary input matrices. DO 80 I=1,2 IF(MODARG(I).NE.5)THEN ISIZ(1)=NDAT CALL MATADM('DELETE',IREF(I),1,ISIZ,2,IFAIL1) IF(IFAIL1.NE.0)PRINT *,' !!!!!! EFCCAL WARNING'// - ' : Unable to delete a replacement matrix.' ENDIF 80 CONTINUE * And save the requested output matrices, delete the others. DO 90 I=4,9 IF(NARG.GE.I-1)THEN ARG(I-1)=IREF(I) MODARG(I-1)=5 ELSE ISIZ(1)=NDAT CALL MATADM('DELETE',IREF(I),1,ISIZ,2,IFAIL1) IF(IFAIL1.NE.0)PRINT *,' !!!!!! EFCCAL WARNING'// - ' : Unable to delete an unused output.' ENDIF 90 CONTINUE ENDIF *** Electric field in 3 dimensions. ELSEIF(IPROC.EQ.-302)THEN * Check number of arguments. IF(NARG.LT.4.OR.NARG.GT.9)THEN PRINT *,' !!!!!! EFCCAL WARNING : Incorrect number'// - ' of arguments for ELECTRIC_FIELD_3.' RETURN * Check argument mode. ELSEIF((MODARG(1).NE.2.AND.MODARG(1).NE.5).OR. - (MODARG(2).NE.2.AND.MODARG(2).NE.5).OR. - (MODARG(3).NE.2.AND.MODARG(3).NE.5))THEN PRINT *,' !!!!!! EFCCAL WARNING : Some arguments of'// - ' ELECTRIC_FIELD_3 are of incorrect type.' RETURN * Check the the results can be transferred back. ELSEIF((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))THEN PRINT *,' !!!!!! EFCCAL WARNING : Some arguments'// - ' of ELECTRIC_FIELD_3 can not be modified.' RETURN ENDIF * Variables already in use ? DO 210 ISTR=4,9 CALL ALGREU(NINT(ARG(ISTR)),MODARG(ISTR),ARGREF(ISTR,1)) 210 CONTINUE ** Carry out the calculation, first for all scalar arguments. IF(MODARG(1).EQ.2.AND.MODARG(2).EQ.2.AND. - MODARG(3).EQ.2)THEN CALL EFIELD(ARG(1),ARG(2),ARG(3), - ARG(4),ARG(5),ARG(6),ARG(7),ARG(8),1,ILOC) MODARG(4)=2 MODARG(5)=2 MODARG(6)=2 MODARG(7)=2 MODARG(8)=2 IF(NARG.GE.9)THEN IF(ILOC.EQ.-10)THEN CALL STRBUF('STORE',IAUX, - 'Unknown potential',17,IFAIL1) ELSEIF(ILOC.EQ.-5)THEN CALL STRBUF('STORE',IAUX, - 'In a material',13,IFAIL1) ELSEIF(ILOC.EQ.-6)THEN CALL STRBUF('STORE',IAUX, - 'Outside mesh',12,IFAIL1) ELSEIF(ILOC.LT.0)THEN CALL STRBUF('STORE',IAUX, - 'Outside plane',13,IFAIL1) ELSEIF(ILOC.EQ.0)THEN CALL STRBUF('STORE',IAUX, - 'Normal',6,IFAIL1) ELSEIF(ILOC.LE.NWIRE)THEN CALL STRBUF('STORE',IAUX,'In an '// - WIRTYP(ILOC)//' wire',12,IFAIL1) ELSE CALL STRBUF('STORE',IAUX,'Unknown',7,IFAIL1) ENDIF ARG(9)=REAL(IAUX) MODARG(9)=1 * Error processing. IF(IFAIL1.NE.0) - PRINT *,' !!!!!! EFCCAL WARNING : '// - 'Error storing a string for'// - ' ELECTRIC_FIELD_3.' ENDIF ** At least one of them is a matrix. ELSE * Figure out what the dimensions are. NDAT=-1 DO 130 I=1,3 IF(MODARG(I).EQ.5)THEN IREF(I)=NINT(ARG(I)) ISLOT(I)=MATSLT(IREF(I)) IF(ISLOT(I).LE.0)THEN PRINT *,' !!!!!! EFCCAL WARNING : Unable'// - ' locate a input matrix.' RETURN ELSEIF(MMOD(ISLOT(I)).NE.2)THEN PRINT *,' !!!!!! EFCCAL WARNING : x, y'// - ' Or z matrix of incorrect type.' RETURN ENDIF IF(NDAT.LT.0)THEN NDAT=MLEN(ISLOT(I)) DO 110 J=1,MDIM(ISLOT(I)) ISIZ(J)=MSIZ(ISLOT(I),J) 110 CONTINUE IDIM=MDIM(ISLOT(I)) ELSEIF(NDAT.NE.MLEN(ISLOT(I)))THEN PRINT *,' !!!!!! EFCCAL WARNING : x, y'// - ' And z have inconsistent lengths.' RETURN ENDIF ENDIF 130 CONTINUE IF(NDAT.LT.1)THEN PRINT *,' !!!!!! EFCCAL WARNING : Unable'// - ' to find an x, y or z matrix.' RETURN ENDIF * Now book matrices for the missing elements and initialise them. DO 140 I=1,3 IF(MODARG(I).NE.5)THEN CALL MATADM('ALLOCATE',IREF(I),IDIM,ISIZ,2,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! EFCCAL WARNING : Unable'// - ' to get a replacement matrix.' RETURN ENDIF ISLOT(I)=MATSLT(IREF(I)) IF(ISLOT(I).LE.0)THEN PRINT *,' !!!!!! EFCCAL WARNING : Unable'// - ' to locate a replacement matrix.' RETURN ENDIF DO 150 J=1,MLEN(ISLOT(I)) MVEC(MORG(ISLOT(I))+J)=ARG(I) 150 CONTINUE ENDIF 140 CONTINUE * Allocate the 6 output arrays (Ex, Ey, Ez, E, V, status). DO 120 I=4,9 CALL MATADM('ALLOCATE',IREF(I),IDIM,ISIZ,2,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! EFCCAL WARNING : Unable'// - ' to get an output matrix.' RETURN ENDIF 120 CONTINUE * And finally locate all 9 matrices. DO 160 I=1,9 ISLOT(I)=MATSLT(IREF(I)) IF(ISLOT(I).LE.0)THEN PRINT *,' !!!!!! EFCCAL WARNING : Unable'// - ' to locate an input or output array.' RETURN ENDIF 160 CONTINUE * And compute the data. DO 170 I=1,NDAT CALL EFIELD(MVEC(MORG(ISLOT(1))+I), - MVEC(MORG(ISLOT(2))+I),MVEC(MORG(ISLOT(3))+I), - MVEC(MORG(ISLOT(4))+I),MVEC(MORG(ISLOT(5))+I), - MVEC(MORG(ISLOT(6))+I),MVEC(MORG(ISLOT(7))+I), - MVEC(MORG(ISLOT(8))+I),1,ILOC) MVEC(MORG(ISLOT(9))+I)=REAL(ILOC) 170 CONTINUE * Delete temporary input matrices. DO 180 I=1,3 IF(MODARG(I).NE.5)THEN ISIZ(1)=NDAT CALL MATADM('DELETE',IREF(I),1,ISIZ,2,IFAIL1) IF(IFAIL1.NE.0)PRINT *,' !!!!!! EFCCAL WARNING'// - ' : Unable to delete a replacement array.' ENDIF 180 CONTINUE * And save the requested output matrices, delete the others. DO 190 I=4,9 IF(NARG.GE.I)THEN ARG(I)=IREF(I) MODARG(I)=5 ELSE ISIZ(1)=NDAT CALL MATADM('DELETE',IREF(I),1,ISIZ,2,IFAIL1) IF(IFAIL1.NE.0)PRINT *,' !!!!!! EFCCAL WARNING'// - ' : Unable to delete an unused output.' ENDIF 190 CONTINUE ENDIF *** Force field in 2 dimensions. ELSEIF(IPROC.EQ.-303)THEN * Check number of arguments. IF(NARG.NE.4)THEN PRINT *,' !!!!!! EFCCAL WARNING : Incorrect number'// - ' of arguments for FORCE_FIELD.' RETURN * Check argument mode. ELSEIF(MODARG(1).NE.2.OR.MODARG(2).NE.2)THEN PRINT *,' !!!!!! EFCCAL WARNING : Some arguments of'// - ' FORCE_FIELD are of incorrect type.' RETURN * Check the the results can be transferred back. ELSEIF(ARGREF(3,1).GE.2.OR.ARGREF(4,1).GE.2)THEN PRINT *,' !!!!!! EFCCAL WARNING : Some arguments'// - ' of FORCE_FIELD can not be modified.' RETURN ENDIF * Variables already in use ? CALL ALGREU(NINT(ARG(3)),MODARG(3),ARGREF(3,1)) CALL ALGREU(NINT(ARG(4)),MODARG(4),ARGREF(4,1)) * Carry out the calculation. CALL FFDBG(ARG(1),ARG(2),ARG(3),ARG(4)) MODARG(3)=2 MODARG(4)=2 *** Magnetic field in 2 dimensions. ELSEIF(IPROC.EQ.-304)THEN * Check number of arguments. IF(NARG.LT.5.OR.NARG.GT.6)THEN PRINT *,' !!!!!! EFCCAL WARNING : Incorrect number'// - ' of arguments for MAGNETIC_FIELD.' RETURN * Check argument mode. ELSEIF(MODARG(1).NE.2.OR.MODARG(2).NE.2)THEN PRINT *,' !!!!!! EFCCAL WARNING : Some arguments of'// - ' MAGNETIC_FIELD are of incorrect type.' RETURN * Check the the results can be transferred back. ELSEIF(ARGREF(3,1).GE.2.OR.ARGREF(4,1).GE.2.OR. - ARGREF(5,1).GE.2.OR. - (NARG.GE.6.AND.ARGREF(6,1).GE.2))THEN PRINT *,' !!!!!! EFCCAL WARNING : Some arguments'// - ' of MAGNETIC_FIELD can not be modified.' RETURN ENDIF * Variables already in use ? DO 220 ISTR=3,NARG CALL ALGREU(NINT(ARG(ISTR)),MODARG(ISTR),ARGREF(ISTR,1)) 220 CONTINUE * Carry out the calculation. CALL BFIELD(ARG(1),ARG(2),0.0,ARG(3),ARG(4),ARG(5),BTOT) MODARG(3)=2 MODARG(4)=2 MODARG(5)=2 IF(NARG.GE.6)THEN ARG(6)=BTOT MODARG(6)=2 ENDIF *** Magnetic field in 3 dimensions. ELSEIF(IPROC.EQ.-305)THEN * Check number of arguments. IF(NARG.LT.6.OR.NARG.GT.7)THEN PRINT *,' !!!!!! EFCCAL WARNING : Incorrect number'// - ' of arguments for MAGNETIC_FIELD_3.' RETURN * Check argument mode. ELSEIF(MODARG(1).NE.2.OR.MODARG(2).NE.2.OR. - MODARG(3).NE.2)THEN PRINT *,' !!!!!! EFCCAL WARNING : Some arguments of'// - ' MAGNETIC_FIELD_3 are of incorrect type.' RETURN * Check the the results can be transferred back. ELSEIF(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))THEN PRINT *,' !!!!!! EFCCAL WARNING : Some arguments'// - ' of MAGNETIC_FIELD_3 can not be modified.' RETURN ENDIF * Variables already in use ? DO 230 ISTR=4,NARG CALL ALGREU(NINT(ARG(ISTR)),MODARG(ISTR),ARGREF(ISTR,1)) 230 CONTINUE * Carry out the calculation. CALL BFIELD(ARG(1),ARG(2),ARG(3),ARG(4),ARG(5),ARG(6),BTOT) MODARG(3)=2 MODARG(4)=2 MODARG(5)=2 MODARG(6)=2 IF(NARG.GE.7)THEN ARG(7)=BTOT MODARG(7)=2 ENDIF *** Charge integration in 2 and 3 dimensions. ELSEIF(IPROC.EQ.-306)THEN * Check number of arguments. IF(NARG.LT.4.OR.NARG.GT.5)THEN PRINT *,' !!!!!! EFCCAL WARNING : Incorrect number'// - ' of arguments for INTEGRATE_CHARGE.' RETURN * Check argument mode. ELSEIF(MODARG(1).NE.2.OR.MODARG(2).NE.2.OR. - (NARG.EQ.5.AND.MODARG(3).NE.2))THEN PRINT *,' !!!!!! EFCCAL WARNING : Some arguments of'// - ' INTEGRATE_CHARGE are of incorrect type.' RETURN * Check the the results can be transferred back. ELSEIF(ARGREF(NARG,1).GE.2)THEN PRINT *,' !!!!!! EFCCAL WARNING : The result'// - ' of INTEGRATE_CHARGE can not be assigned.' RETURN ENDIF * Variables already in use ? CALL ALGREU(NINT(ARG(NARG)),MODARG(NARG),ARGREF(NARG,1)) * Carry out the calculation. IF(NARG.EQ.4)THEN CALL FLDIN2(ARG(1),ARG(2),ARG(3),ARG(4)) MODARG(4)=2 ELSE CALL FLDIN3(ARG(1),ARG(2),ARG(3),ARG(4),ARG(5)) MODARG(5)=2 ENDIF *** Flux integration over a parallelogram. ELSEIF(IPROC.EQ.-307)THEN * Check number of arguments. IF(NARG.LT.10.OR.NARG.GT.12)THEN PRINT *,' !!!!!! EFCCAL WARNING : Incorrect number'// - ' of arguments for INTEGRATE_FLUX.' 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. - MODARG(5).NE.2.OR.MODARG(6).NE.2.OR. - MODARG(7).NE.2.OR.MODARG(8).NE.2.OR. - MODARG(9).NE.2.OR. - (NARG.GE.11.AND.MODARG(11).NE.2).OR. - (NARG.GE.12.AND.MODARG(12).NE.2))THEN PRINT *,' !!!!!! EFCCAL WARNING : Some arguments of'// - ' INTEGRATE_FLUX are of incorrect type.' RETURN * Check the the results can be transferred back. ELSEIF(ARGREF(10,1).GE.2)THEN PRINT *,' !!!!!! EFCCAL WARNING : The result'// - ' of INTEGRATE_FLUX can not be assigned.' RETURN ENDIF * Variables already in use ? CALL ALGREU(NINT(ARG(10)),MODARG(10),ARGREF(10,1)) * Fetch the number of integration points, if present. NU=20 NV=20 IF(NARG.GE.11)NU=NINT(ARG(11)) IF(NARG.GE.12)NV=NINT(ARG(12)) * Integrate the flux. CALL FLDIN4(ARG(1),ARG(2),ARG(3),ARG(4),ARG(5), - ARG(6),ARG(7),ARG(8),ARG(9),ARG(10),NU,NV) MODARG(10)=2 *** Returns map indices. ELSEIF(IPROC.EQ.-310)THEN * See whether there is a field map at all. IF(NMAP.LE.0.OR..NOT.MAPFLG(1))THEN PRINT *,' !!!!!! EFCCAL WARNING : There is no'// - ' field map; MAP_INDEX not executed.' RETURN * Check number of arguments. ELSEIF((MAPTYP.EQ.1.OR.MAPTYP.EQ.2.OR.MAPTYP.EQ.3).AND. - NARG.NE.3.AND.NARG.NE.6)THEN PRINT *,' !!!!!! EFCCAL WARNING : The map is made of'// - ' triangles; provide 3 or 6 arguments.' RETURN ELSEIF((MAPTYP.EQ.4.OR.MAPTYP.EQ.5.OR.MAPTYP.EQ.6).AND. - NARG.NE.3.AND.NARG.NE.5)THEN PRINT *,' !!!!!! EFCCAL WARNING : The map is made of'// - ' parallelograms; provide 3 or 5 arguments.' RETURN ELSEIF((MAPTYP.EQ.11.OR.MAPTYP.EQ.12.OR.MAPTYP.EQ.13).AND. - NARG.NE.4.AND.NARG.NE.8)THEN PRINT *,' !!!!!! EFCCAL WARNING : The map is made of'// - ' tetrahedrons; provide 4 or 8 arguments.' RETURN ELSEIF((MAPTYP.EQ.14.OR.MAPTYP.EQ.15.OR.MAPTYP.EQ.16).AND. - NARG.NE.4.AND.NARG.NE.7)THEN PRINT *,' !!!!!! EFCCAL WARNING : The map is made of'// - ' parallelepipeds; provide 4 or 7 arguments.' RETURN ELSEIF(MAPTYP.LE.0.OR.(MAPTYP.GE.7.AND.MAPTYP.LE.10).OR. - MAPTYP.GE.17)THEN PRINT *,' !!!!!! EFCCAL WARNING : Unknown element'// - ' type; MAP_INDEX not executed.' RETURN * Check argument mode and return possibilities. ELSEIF( - (NARG.EQ.3.AND. - (MODARG(1).NE.2.OR.MODARG(2).NE.2.OR. - ARGREF(3,1).GE.2)).OR. - (NARG.EQ.4.AND. - (MODARG(1).NE.2.OR.MODARG(2).NE.2.OR. - MODARG(3).NE.2.OR.ARGREF(4,1).GE.2)).OR. - (NARG.EQ.6.AND. - (MODARG(1).NE.2.OR.MODARG(2).NE.2.OR. - ARGREF(3,1).GE.2.OR.ARGREF(4,1).GE.2.OR. - ARGREF(5,1).GE.2.OR.ARGREF(6,1).GE.2)).OR. - (NARG.EQ.8.AND. - (MODARG(1).NE.2.OR.MODARG(2).NE.2.OR. - MODARG(3).NE.2.OR. - ARGREF(4,1).GE.2.OR.ARGREF(5,1).GE.2.OR. - ARGREF(6,1).GE.2.OR.ARGREF(7,1).GE.2.OR. - ARGREF(8,1).GE.2)))THEN PRINT *,' !!!!!! EFCCAL WARNING : Some arguments of'// - ' MAP_INDEX are of incorrect type.' RETURN ENDIF * Find the map indices. XPOS=ARG(1) YPOS=ARG(2) IF(MAPTYP.GT.10)THEN ZPOS=ARG(3) ELSE ZPOS=0 ENDIF CALL MAPIND(XPOS,YPOS,ZPOS,T1,T2,T3,T4,IMAP) IF(IMAP.LE.0)THEN PRINT *,' !!!!!! EFCCAL WARNING : Point is not'// - ' located in an element.' RETURN ENDIF * Variables already in use ? IF(MAPTYP.GT.10)THEN DO 240 I=4,NARG CALL ALGREU(NINT(ARG(I)),MODARG(I),ARGREF(I,1)) 240 CONTINUE ELSE DO 250 I=3,NARG CALL ALGREU(NINT(ARG(I)),MODARG(I),ARGREF(I,1)) 250 CONTINUE ENDIF * Return the results. IF(MAPTYP.GT.10)THEN ARG(4)=IMAP ARG(5)=T1 ARG(6)=T2 ARG(7)=T3 ARG(8)=T4 MODARG(4)=2 MODARG(5)=2 MODARG(6)=2 MODARG(7)=2 MODARG(8)=2 ELSE ARG(3)=IMAP ARG(4)=T1 ARG(5)=T2 ARG(6)=T3 MODARG(3)=2 MODARG(4)=2 MODARG(5)=2 MODARG(6)=2 ENDIF *** Return the volume element. ELSEIF(IPROC.EQ.-311)THEN * See whether there is a field map at all. IF(NMAP.LE.0.OR..NOT.MAPFLG(1))THEN PRINT *,' !!!!!! EFCCAL WARNING : There is no'// - ' field map; MAP_ELEMENT not executed.' RETURN * Check number of arguments. ELSEIF((MAPTYP.EQ.1.OR.MAPTYP.EQ.2.OR.MAPTYP.EQ.3).AND. - NARG.NE.7)THEN PRINT *,' !!!!!! EFCCAL WARNING : The map is made of'// - ' triangles; provide 7 arguments.' RETURN ELSEIF((MAPTYP.EQ.4.OR.MAPTYP.EQ.5.OR.MAPTYP.EQ.6).AND. - NARG.NE.7)THEN PRINT *,' !!!!!! EFCCAL WARNING : The map is made of'// - ' parallelograms; provide 7 arguments.' RETURN ELSEIF((MAPTYP.EQ.11.OR.MAPTYP.EQ.12.OR.MAPTYP.EQ.13).AND. - NARG.NE.13)THEN PRINT *,' !!!!!! EFCCAL WARNING : The map is made of'// - ' tetrahedrons; provide 13 arguments.' RETURN ELSEIF((MAPTYP.EQ.14.OR.MAPTYP.EQ.15.OR.MAPTYP.EQ.16).AND. - NARG.NE.13)THEN PRINT *,' !!!!!! EFCCAL WARNING : The map is made of'// - ' parallelepipeds; provide 13 arguments.' RETURN * Check argument mode and return possibilities. ELSEIF(MODARG(1).NE.2.OR. - (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.GE.10.AND.ARGREF(10,1).GE.2).OR. - (NARG.GE.11.AND.ARGREF(11,1).GE.2).OR. - (NARG.GE.12.AND.ARGREF(12,1).GE.2).OR. - (NARG.GE.13.AND.ARGREF(13,1).GE.2))THEN PRINT *,' !!!!!! EFCCAL WARNING : Some arguments of'// - ' MAP_ELEMENT are of incorrect type.' RETURN * Verify map type. ELSEIF(MAPTYP.LE.0.OR.(MAPTYP.GE.7.AND.MAPTYP.LE.10).OR. - MAPTYP.GE.17)THEN PRINT *,' !!!!!! EFCCAL WARNING : Unknown element'// - ' type; MAP_ELEMENT not executed.' RETURN * Verify that the element is within range. ELSEIF(NINT(ARG(1)).LT.1.OR.NINT(ARG(1)).GT.NMAP)THEN PRINT *,' !!!!!! EFCCAL WARNING : MAP_ELEMENT not'// - ' executed, element is out of range.' RETURN ENDIF * Variables already in use ? DO 260 I=2,NARG CALL ALGREU(NINT(ARG(I)),MODARG(I),ARGREF(I,1)) 260 CONTINUE * Return the element. IF(MAPTYP.GE.1.AND.MAPTYP.LE.6)THEN ARG(2)= XMAP(NINT(ARG(1)),1) ARG(3)= YMAP(NINT(ARG(1)),1) ARG(4)= XMAP(NINT(ARG(1)),2) ARG(5)= YMAP(NINT(ARG(1)),2) ARG(6)= XMAP(NINT(ARG(1)),3) ARG(7)= YMAP(NINT(ARG(1)),3) ELSEIF(MAPTYP.GE.11.AND.MAPTYP.LE.16)THEN ARG(2)= XMAP(NINT(ARG(1)),1) ARG(3)= YMAP(NINT(ARG(1)),1) ARG(4)= ZMAP(NINT(ARG(1)),1) ARG(5)= XMAP(NINT(ARG(1)),2) ARG(6)= YMAP(NINT(ARG(1)),2) ARG(7)= ZMAP(NINT(ARG(1)),2) ARG(8)= XMAP(NINT(ARG(1)),3) ARG(9)= YMAP(NINT(ARG(1)),3) ARG(10)=ZMAP(NINT(ARG(1)),3) ARG(11)=XMAP(NINT(ARG(1)),4) ARG(12)=YMAP(NINT(ARG(1)),4) ARG(13)=ZMAP(NINT(ARG(1)),4) ENDIF DO 270 I=2,NARG MODARG(I)=2 270 CONTINUE *** Material index. ELSEIF(IPROC.EQ.-312)THEN * Check argument list. IF(NARG.LT.2.OR.NARG.GT.3.OR. - MODARG(1).NE.2.OR. - (NARG.GE.2.AND.ARGREF(2,1).GE.2).OR. - (NARG.GE.3.AND.ARGREF(3,1).GE.2))THEN PRINT *,' !!!!!! EFCCAL WARNING : Incorrect argument'// - ' list for MAP_MATERIAL' RETURN * Make sure the materials are known. ELSEIF(.NOT.MAPFLG(9))THEN PRINT *,' !!!!!! EFCCAL WARNING : Materials are not'// - ' defined; MAP_MATERIAL not executed.' RETURN * Make sure index is in range. ELSEIF(NINT(ARG(1)).LT.1.OR.NINT(ARG(1)).GT.NMAP)THEN PRINT *,' !!!!!! EFCCAL WARNING : Field map index is'// - ' out of range; MAP_MATERIAL not executed.' RETURN ENDIF * Clean up variables. DO 280 I=2,NARG CALL ALGREU(NINT(ARG(I)),MODARG(I),ARGREF(I,1)) 280 CONTINUE * Return the values. ARG(2)=REAL(MATMAP(NINT(ARG(1)))) IF(NINT(ARG(2)).GE.1.AND.NINT(ARG(2)).LE.NEPS)THEN ARG(3)=EPSMAT(NINT(ARG(2))) ELSE ARG(3)=-1 ENDIF MODARG(2)=2 MODARG(3)=2 *** Plot the field area. ELSEIF(IPROC.EQ.-320)THEN * Check arguments. IF((NARG.NE.0.AND.NARG.NE.1).OR. - (NARG.EQ.1.AND.MODARG(1).NE.1))THEN PRINT *,' !!!!!! EFCCAL WARNING : Incorrect list'// - ' of arguments for PLOT_FIELD_AREA; no plot.' RETURN ENDIF * See whether there is a title. IF(NARG.EQ.1)THEN CALL STRBUF('READ',NINT(ARG(1)),TITLE,NC,IFAIL1) ELSEIF(CELLID.EQ.' ')THEN TITLE='Layout of the cell' NC=18 ELSE TITLE=CELLID NC=LEN(CELLID) ENDIF * Plot the frame. CALL GRASET(PXMIN,PYMIN,PZMIN,PXMAX,PYMAX,PZMAX) CALL GRCELL(VXMIN,VYMIN,VXMAX,VYMAX,TITLE(1:NC)) *** Unknown electric field operation. ELSE PRINT *,' !!!!!! EFCCAL WARNING : Unknown procedure code'// - ' received; nothing done.' IFAIL=1 RETURN ENDIF *** Seems to have worked. IFAIL=0 END +PATCH,DRIFT. +DECK,DRFINP. SUBROUTINE DRFINP *----------------------------------------------------------------------- * DRFINP - Routine reading instructions with regard to the drift line * and equal time contours and calling the appropriate routine * VARIABLES : STRING : (parts of) the instruction read by INPWRD * VTEST : Used for drift velocity printing. * (Last changed on 10/ 7/99.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,BFIELD. +SEQ,DRIFTLINE. +SEQ,GASDATA. +SEQ,PRINTPLOT. +SEQ,PARAMETERS. +SEQ,CONSTANTS. CHARACTER*(MXCHAR) STRING DOUBLE PRECISION VTEST(3) INTEGER INPCMP,INPTYP,NWORD,IFAIL,IFAIL1,IFAIL2,IFAIL3,NLINER,NC, - NGRIDR,NGRDXR,NGRDYR,ILOC,ILOC1,ILOC2,I,INEXT,NLTR,NLTRR, - ITEST,NTEST REAL XTEST,YTEST,ZTEST,EXTEST,EYTEST,EZTEST,ETEST,VOLT,QTEST, - TMIN,TMAX,SMIN,SMAX,AMIN,AMAX,BMIN,BMAX,CPU,RNDM LOGICAL FLAG(MXWORD+3),LDIFF,LTOWN,LATTA EXTERNAL INPCMP,INPTYP,RNDM +SELF,IF=AST. EXTERNAL ASTCCH +SELF. *** Define some formats 1020 FORMAT(' Current number of grid points is ',I3,' by ',I3,'.') 1040 FORMAT(' Distance between equal time contours ',F10.3, - ' [microsec]') *** Identify the routine, if requested. IF(LIDENT)PRINT *,' /// ROUTINE DRFINP ///' *** Print a heading for the drift section. WRITE(LUNOUT,'(''1'')') PRINT *,' ================================================' PRINT *,' ========== Start of drift section ==========' PRINT *,' ================================================' PRINT *,' ' *** Check that valid gas data are present. IF(.NOT.GASOK(1))THEN PRINT *,' ###### DRFINP ERROR : The drift velocity data'// - ' are missing; this section can not be executed.' CALL SKIP RETURN ENDIF *** Set default area. CALL GRASET(DXMIN,DYMIN,DZMIN,DXMAX,DYMAX,DZMAX) *** Start an input loop. CALL INPPRM('Drift','NEW-PRINT') 10 CONTINUE CALL INPWRD(NWORD) +SELF,IF=AST. *** Set up ASTCCH as the condition handler. CALL LIB$ESTABLISH(ASTCCH) +SELF. CALL INPSTR(1,1,STRING,NC) *** Skip if the line is blank. IF(NWORD.EQ.0)GOTO 10 *** Return to main program if & is the first character. IF(STRING(1:1).EQ.'&')THEN RETURN *** Look for the AREA instruction. ELSEIF(INPCMP(1,'AREA').NE.0)THEN CALL CELVIE(DXMIN,DYMIN,DZMIN,DXMAX,DYMAX,DZMAX) CALL INPERR *** ARRIVAL-TIME-DISTRIBUTION. ELSEIF(INPCMP(1,'ARR#IVAL-#TIME-#DISTRIBUTION').NE.0)THEN CALL DRFARR *** Cluster study. ELSEIF(INPCMP(1,'CL#USTERING-#HISTOGRAMS').NE.0)THEN CALL DRFCLS *** Look for the keyword DRIFT. ELSEIF(INPCMP(1,'DR#IFT').NE.0)THEN CALL DRFDRF *** Look for the EPSILON keyword. ELSEIF(INPCMP(1,'EPS#ILON').NE.0)THEN PRINT *,' !!!!!! DRFINP WARNING : This parameter should'// - ' be changed from INTEGRATION-PARAMETERS.' *** Look for the keyword GRAPHICS. ELSEIF(INPCMP(1,'GRA#PHICS-#INPUT').NE.0)THEN CALL DRFGRA *** Look for the keyword GRID. ELSEIF(INPCMP(1,'GRI#D').NE.0)THEN IF(NWORD.EQ.1)THEN WRITE(LUNOUT,1020) NGRIDX,NGRIDY ELSEIF(NWORD.EQ.2)THEN CALL INPCHK(2,1,IFAIL1) CALL INPRDI(2,NGRIDR,25) IF(NGRIDR.LE.1.OR.NGRIDR.GT.MXGRID) - CALL INPMSG(2,'GRID out of range 2 -> MXGRID.') IF(IFAIL1.NE.0.OR.NGRIDR.LE.1.OR.NGRIDR.GT.MXGRID)THEN PRINT *,' !!!!!! DRFINP WARNING : GRID statement', - ' ignored because of syntax or value errors.' ELSE NGRIDX=NGRIDR NGRIDY=NGRIDR ENDIF ELSEIF(NWORD.EQ.3)THEN CALL INPCHK(2,1,IFAIL1) CALL INPCHK(3,1,IFAIL2) CALL INPRDI(2,NGRDXR,25) CALL INPRDI(3,NGRDYR,25) IF(NGRDXR.LE.1.OR.NGRDXR.GT.MXGRID) - CALL INPMSG(2,'out of the range 2 -> MXGRID. ') IF(NGRDYR.LE.1.OR.NGRDYR.GT.MXGRID) - CALL INPMSG(2,'out of the range 2 -> MXGRID. ') IF(IFAIL1.NE.0.OR.NGRDXR.LE.1.OR.NGRDXR.GT.MXGRID.OR. - NGRDYR.LE.1.OR.NGRDYR.GT.MXGRID)THEN PRINT *,' !!!!!! DRFINP WARNING : GRID statement', - ' ignored because of syntax or value errors.' ELSE NGRIDX=NGRDXR NGRIDY=NGRDYR ENDIF ELSE PRINT *,' !!!!!! DRFINP WARNING : GRID requires 1'// - ' or 2 arguments ; the instruction is ignored.' ENDIF CALL INPERR *** Integration parameters. ELSEIF(INPCMP(1,'INT#EGRATION-#PARAMETERS').NE.0)THEN CALL DLCPAR *** Look for the keyword LINE and find NLINED. ELSEIF(INPCMP(1,'L#INES').NE.0)THEN IF(NWORD.EQ.1)THEN WRITE(LUNOUT,'('' Number of drift lines is '',I4, - ''.'')') NLINED ELSEIF(NWORD.EQ.2)THEN CALL INPCHK(2,1,IFAIL1) CALL INPRDI(2,NLINER,0) IF(IFAIL1.EQ.0.AND.NLINER.LE.0)CALL INPMSG(2, - 'number of drift lines not > 0 ') IF(IFAIL1.NE.0.OR.NLINER.LE.0)THEN PRINT *,' !!!!!! DRFINP WARNING : LINES is'// - ' ignored because of (syntax) errors.' ELSE NLINED=NLINER ENDIF ELSE PRINT *,' !!!!!! DRFINP WARNING : LINES needs one'// - ' argument ; instruction is ignored.' ENDIF CALL INPERR *** Print the Lorentz angle. ELSEIF(INPCMP(1,'LO#RENTZ-#ANGLE').NE.0)THEN IF(.NOT.MAGOK)THEN PRINT *,' ------ DRFINP MESSAGE : The magnetic field'// - ' is off; Lorentz angle by definition zero.' ELSEIF(NWORD.LT.3.OR.NWORD.GT.4)THEN PRINT *,' !!!!!! DRFINP WARNING : The LORENT-ANGLE'// - ' instruction takes 2 arguments; ignored.' ELSE CALL INPCHK(2,2,IFAIL1) CALL INPCHK(3,2,IFAIL2) CALL INPCHK(4,2,IFAIL3) CALL INPRDR(2,XTEST,0.0) CALL INPRDR(3,YTEST,0.0) CALL INPRDR(4,ZTEST,0.0) IF(IFAIL1+IFAIL2+IFAIL3.NE.0)THEN PRINT *,' !!!!!! DRFINP WARNING : LORENTZ-ANGLE'// - ' ignored because of syntax errors.' CALL INPERR GOTO 10 ENDIF IF(POLAR)THEN CALL CFMPTR(XTEST,YTEST,XTEST,YTEST,1,IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' ++++++ DRFINP DEBUG : Illegal'// - ' coordinates; no output.' CALL INPERR GOTO 10 ENDIF ENDIF CALL EFIELD(XTEST,YTEST,ZTEST, - EXTEST,EYTEST,EZTEST,ETEST,VOLT, - 0,ILOC1) CALL DLCVEL(DBLE(XTEST),DBLE(YTEST),DBLE(ZTEST), - VTEST,-1.0,1,ILOC2) IF(ILOC1.NE.0.OR.ILOC2.NE.0.OR.ETEST.EQ.0.OR. - VTEST(1)**2+VTEST(2)**2.EQ.0)THEN PRINT *,' !!!!!! DRFINP WARNING : Lorentz angle'// - ' not computed (e.g. in a wire).' ELSE WRITE(LUNOUT,'(/'' Lorentz angle is: '',E15.8, - '' degrees.'')') 180.0*ACOS(MAX(-1.0,MIN(1.0, - REAL((EXTEST*VTEST(1)+EYTEST*VTEST(2)+ - EZTEST*VTEST(3))/(ETEST*(SQRT(VTEST(1)**2+ - VTEST(2)**2+VTEST(3)**2)))))))/PI ENDIF ENDIF CALL INPERR *** Minimisation. ELSEIF(INPCMP(1,'MIN#IMISE').NE.0)THEN CALL DRFMIN *** Look for the keyword OPTIONS: ELSEIF(INPCMP(1,'OPT#IONS').NE.0)THEN IF(NWORD.EQ.1)THEN WRITE(LUNOUT,'(/ - '' LOCAL OPTIONS CURRENTLY IN EFFECT:''// - '' Plotting of the drift lines'', - '' (DRIFT-PLOT): '',L1/ - '' Printing of drift line details'', - '' (DRIFT-PRINT): '',L1/ - '' Plotting of a table of contour'', - '' heights (KEY): '',L1/ - '' Contour all media (T) or drift'', - '' medium (F): '',L1/ - '' Plot wires by markers'', - '' (WIRE-MARKERS): '',L1/ - '' Check for multiple field map indices:'', - '' '',L1/)') - LDRPLT,LDRPRT,LKEYPL,LCNTAM,LWRMRK,LMAPCH ELSE DO 40 I=2,NWORD * search for plotting of drift lines option, IF(INPCMP(I,'NOD#RIFT-PL#OT').NE.0)THEN LDRPLT=.FALSE. ELSEIF(INPCMP(I,'D#RIFT-PL#OT').NE.0)THEN LDRPLT=.TRUE. * search for printing-of-drift lines option ELSEIF(INPCMP(I,'NOD#RIFT-PR#INT').NE.0)THEN LDRPRT=.FALSE. ELSEIF(INPCMP(I,'D#RIFT-PR#INT').NE.0)THEN LDRPRT=.TRUE. * Look for the contour key plotting option. ELSEIF(INPCMP(I,'NOK#EY-#PLOT').NE.0)THEN LKEYPL=.FALSE. ELSEIF(INPCMP(I,'K#EY-#PLOT').NE.0)THEN LKEYPL=.TRUE. * Contour drawing options. ELSEIF(INPCMP(I,'CONT#OUR-ALL-#MEDIA').NE.0)THEN LCNTAM=.TRUE. ELSEIF(INPCMP(I,'CONT#OUR-DR#IFT-#MEDIUM')+ - INPCMP(I,'CONT#OUR-DR#IFT-#MEDIA').NE.0)THEN LCNTAM=.FALSE. * Wires drawn as markers. ELSEIF(INPCMP(I,'NOW#IRE-M#ARKERS').NE.0)THEN LWRMRK=.FALSE. ELSEIF(INPCMP(I,'W#IRE-M#ARKERS').NE.0)THEN LWRMRK=.TRUE. * Detect multiple map indices. ELSEIF(INPCMP(I,'CH#ECK-MAP-#INDICES')+ - INPCMP(I,'CH#ECK-MAP-#INDEXING').NE.0)THEN LMAPCH=.TRUE. ELSEIF(INPCMP(I,'NOCH#ECK-MAP-#INDICES')+ - INPCMP(I,'NOCH#ECK-MAP-#INDEXING').NE.0)THEN LMAPCH=.FALSE. * Invalid option if not yet recognised. ELSE CALL INPMSG(I,'the option is not known. ') ENDIF 40 CONTINUE ENDIF CALL INPERR *** PLOT: plot various drift related items. ELSEIF(INPCMP(1,'PL#OT-#FIELD').NE.0)THEN CALL DRFPLT *** PREPARE-TRACK: Prepare a drifting information table. ELSEIF(INPCMP(1,'PR#EPARE-#TRACK').NE.0.AND..NOT.TRFLAG(1))THEN PRINT *,' !!!!!! DRFINP WARNING : Track preparation'// - ' must be done after track definition.' * Track has indeed been defined. ELSEIF(INPCMP(1,'PR#EPARE-#TRACK').NE.0)THEN * Initial option values. LDIFF=GASOK(3) LTOWN=GASOK(4) LATTA=GASOK(6) NLTR=NLINED * Flag recognised keywords. DO 30 I=1,NWORD+3 FLAG(I)=.FALSE. IF(INPCMP(I,'A#TTACHMENT-#COEFFICIENT')+ - INPCMP(I,'D#IFFUSION-#COEFFICIENT')+ - INPCMP(I,'L#INES')+ - INPCMP(I,'NOA#TTACHMENT-#COEFFICIENT')+ - INPCMP(I,'NOD#IFFUSION-#COEFFICIENT')+ - INPCMP(I,'NOT#OWNSEND-#COEFFICIENT')+ - INPCMP(I,'T#OWNSEND-#COEFFICIENT').NE.0)FLAG(I)=.TRUE. 30 CONTINUE * Loop over the parameter string. INEXT=2 DO 20 I=2,NWORD IF(I.LT.INEXT)GOTO 20 * Check for the number of drift-lines to be used. IF(INPCMP(I,'L#INES').NE.0)THEN IF(I+1.GT.NWORD.OR.FLAG(I+1))THEN CALL INPMSG(I,'The argument is missing. ') ELSEIF(INPTYP(I+1).LE.0)THEN CALL INPMSG(I+1,'The argument is not numeric. ') INEXT=I+2 ELSE CALL INPCHK(I+1,1,IFAIL) CALL INPRDI(I+1,NLTRR,NLTR) IF(IFAIL.EQ.0.AND.NLTRR.LT.4)THEN CALL INPMSG(I+1, - 'At least 4 lines are needed. ') ELSEIF(IFAIL.EQ.0.AND.NLTRR.GT.MXLIST-4)THEN CALL INPMSG(I+1, - 'Not more than MXLIST-4 lines. ') ELSEIF(IFAIL.EQ.0)THEN NLTR=NLTRR ENDIF INEXT=I+2 ENDIF * Check for the diffusion options. ELSEIF(INPCMP(I,'D#IFFUSION-#COEFFICIENT').NE.0)THEN IF(.NOT.GASOK(3))THEN CALL INPMSG(I,'No diffusion data are present.') ELSE LDIFF=.TRUE. ENDIF ELSEIF(INPCMP(I,'NOD#IFFUSION-#COEFFICIENT').NE.0)THEN LDIFF=.FALSE. * Check for the Townsend options. ELSEIF(INPCMP(I,'T#OWNSEND-#COEFFICIENT').NE.0)THEN IF(.NOT.GASOK(4))THEN CALL INPMSG(I,'No Townsend data are present. ') ELSE LTOWN=.TRUE. ENDIF ELSEIF(INPCMP(I,'NOT#OWNSEND-#COEFFICIENT').NE.0)THEN LTOWN=.FALSE. * Check for the attachment options. ELSEIF(INPCMP(I,'A#TTACHMENT-#COEFFICIENT').NE.0)THEN IF(.NOT.GASOK(6))THEN CALL INPMSG(I,'No attachment data are present') ELSE LATTA=.TRUE. ENDIF ELSEIF(INPCMP(I,'NOA#TTACHMENT-#COEFFICIENT').NE.0)THEN LATTA=.FALSE. * Unrecognised option. ELSE CALL INPMSG(I,'Invalid option, ignored. ') ENDIF 20 CONTINUE * Dump error messages. CALL INPERR * Call the preparation routine with proper arguments. CALL DLCTRP(XT0,YT0,ZT0,XT1,YT1,ZT1,LDIFF,LTOWN,LATTA,NLTR, - TMIN,TMAX,SMIN,SMAX,AMIN,AMAX,BMIN,BMAX,IFAIL) *** Look for the SELECT instruction. ELSEIF(INPCMP(1,'SEL#ECT').NE.0)THEN CALL CELSEL *** Test drift line calculation. ELSEIF(INPCMP(1,'SIN#GLE').NE.0)THEN CALL DRFSIN *** Test drift speed calculation. ELSEIF(INPCMP(1,'SP#EED').NE.0)THEN PRINT *,' ++++++ DRFINP DEBUG : SPEED start.' QTEST=-1.0 ITEST=1 CALL INPCHK(2,2,IFAIL1) CALL INPCHK(3,2,IFAIL2) CALL INPCHK(4,2,IFAIL3) CALL INPRDR(2,XTEST,0.0) CALL INPRDR(3,YTEST,0.0) CALL INPRDR(4,ZTEST,0.0) DO 60 I=5,NWORD IF(INPCMP(I,'E#LECTRON').NE.0)THEN ITEST=1 ELSEIF(INPCMP(I,'I#ON').NE.0)THEN IF(GASOK(2))THEN ITEST=2 ELSE CALL INPMSG(I,'ion mobility data missing. ') ENDIF ELSEIF(INPCMP(I,'POS#ITIVE').NE.0)THEN QTEST=+1.0 ELSEIF(INPCMP(I,'NEG#ATIVE').NE.0)THEN QTEST=-1.0 ELSE CALL INPMSG(I,'The option is not known. ') ENDIF 60 CONTINUE CALL INPERR IF(IFAIL1+IFAIL2+IFAIL3.NE.0)GOTO 10 IF(POLAR)THEN CALL CFMPTR(XTEST,YTEST,XTEST,YTEST,1,IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' ++++++ DRFINP DEBUG : Illegal'// - ' coordinates; no output.' GOTO 10 ENDIF ENDIF CALL DLCVEL(DBLE(XTEST),DBLE(YTEST),DBLE(ZTEST), - VTEST,QTEST,ITEST,ILOC) PRINT 3030,(VTEST(I),I=1,3),PGAS 3030 FORMAT(' Vx=',E15.8,' Vy=',E15.8,' Vz=',E15.8, - ' PGAS=',F10.1) IF(POLAR)PRINT *,' (These are internal velocity components)' PRINT *,' ++++++ DRFINP DEBUG : SPEED end.' *** Drift time table printing. ELSEIF(INPCMP(1,'TAB#LE').NE.0)THEN CALL DRFTAB *** Time drift line calculation. ELSEIF(INPCMP(1,'TIME').NE.0)THEN PRINT *,' ++++++ DRFINP DEBUG : TIME start.' CALL INPCHK(2,1,IFAIL1) CALL INPRDI(2,NTEST,10) CALL INPERR QTEST=-1.0 PRINT *,' Drift line table:' PRINT *,' ' CALL TIMED(CPU) DO 3050 I=1,NTEST XTEST=DXMIN+RNDM(I) *(DXMAX-DXMIN) YTEST=DYMIN+RNDM(I+1)*(DYMAX-DYMIN) CALL DLCALC(XTEST,YTEST,0.0,QTEST,1) 3060 FORMAT(' Line ',I3,' steps=',I3,' start at (x,y)=',2F15.8, - ' drift time=',F15.8,' microsec') 3065 FORMAT(' Line ',I3,' steps=',I3,' start at (r,phi)=',2F15.8, - ' drift time=',F15.8,' microsec') IF(POLAR)THEN CALL CFMRTP(XTEST,YTEST,XTEST,YTEST,1) PRINT 3065,I,NU,XTEST,YTEST,TU(NU) ELSE PRINT 3060,I,NU,XTEST,YTEST,TU(NU) ENDIF 3050 CONTINUE CALL TIMED(CPU) PRINT *,' ' PRINT *,' Total CPU time used=',CPU,' seconds' CALL TIMLOG('< TIME: drift lines > ') PRINT *,' ++++++ DRFINP DEBUG : TIME end.' *** Timing distributions. ELSEIF(INPCMP(1,'TIMING-#HISTOGRAMS').NE.0)THEN CALL DRFTIM *** Look for the instruction TRACK. ELSEIF(INPCMP(1,'TR#ACK').NE.0)THEN CALL TRAREA *** Look for the TRAP instruction. ELSEIF(INPCMP(1,'TRAP').NE.0)THEN PRINT *,' !!!!!! DRFINP WARNING : This parameter should'// - ' changed from INTEGRATION-PARAMETERS.' *** Read track information from a dataset if GET is the command. ELSEIF(INPCMP(1,'GET-TR#ACK').NE.0)THEN CALL DLCTRG(IFAIL) *** Write the track data if WRITE-TRACK is a keyword. ELSEIF(INPCMP(1,'WR#ITE-T#RACK').NE.0)THEN CALL DLCTRW *** Search for the XTPLOT instruction. ELSEIF(INPCMP(1,'XT-#PLOT').NE.0)THEN IF(POLAR)THEN PRINT *,' !!!!!! DRFINP WARNING : This instruction'// - ' is not valid for polar cells; not executed.' ELSE CALL DRFXTP ENDIF *** Writing out of equal time contours. ELSEIF(INPCMP(1,'WR#ITE-EQ#UAL-TIM#E-#CONTOURS')+ - INPCMP(1,'WR#ITE-ISO#CHRONES').NE.0)THEN CALL DRFEQW *** It is not possible to get here if the keyword is recognised. ELSE CALL INPSTR(1,1,STRING,NC) PRINT *,' !!!!!! DRFINP WARNING : '//STRING(1:NC)//' is'// - ' not a valid instruction ; it is ignored.' ENDIF *** End of the loop; go for another iteration. GOTO 10 END +DECK,DRFARR. SUBROUTINE DRFARR *----------------------------------------------------------------------- * DRFARR - Computes the arrival time distribution of the M'th electron * from a given track. * VARIABLES : * (Last changed on 8/ 2/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,SOLIDS. +SEQ,GASDATA. +SEQ,DRIFTLINE. +SEQ,PARAMETERS. +SEQ,PRINTPLOT. +SEQ,CONSTANTS. INTEGER MXELEC PARAMETER(MXELEC=10) *** Declarations, start setting the max number of histogram channels. CHARACTER*(MXCHAR) STRING CHARACTER*(MXNAME) FILE CHARACTER*80 TITLE CHARACTER*29 REMARK CHARACTER*15 STR1,STR2,STR3,STR4,STRID CHARACTER*8 TIME,DATE,MEMBER CHARACTER*1 STEP,SCAN REAL ARRTIM(2,MXPART),XPL(MXLIST),YPL(MXLIST),THRESH,THRR, - ARRLIS(MXLIST,4+3*MXELEC),TSTEP,TEMIN,TEMAX,TGMIN,TGMAX, - UARMIN,UARMAX,VARMIN,VARMAX,UARMIR,UARMAR,VARMIR,VARMAR, - UAROFF,WAROFF,XW,YW,ZW, - USTEP,USTEPR,TANPHI,ANGLER,TFORC1,TFORC2,XCL,YCL,ZCL,ECL, - ACL,BCL,FCL,SCL,TCL,RNDNOR,HGMIN,HGMAX,HEMIN,HEMAX, - SMIN,SMAX,AMIN,AMAX,BMIN,BMAX,TMAX INTEGER ARRFLG(MXLIST),IRFTEL(MXELEC),IRFXEL(MXELEC), - IRFXGL,IRFTGL,IRFNCL,IRFNEL,NCLUS,NCHA,NCHAR,NPLOT, - MELEC(MXELEC),NELEC(MXELEC),ISIZ(1),IDIM(1),NCFILE,NCMEMB, - NCREM,NLTR,NLTRR,JSEL,JALL,JOVER, - INEXT,NWORD,NRNDM,NRNDMR,IORDER, - IORDR,KELEC,MR,IW,ISWCNT,IXM,IXP,IX,IFAIL,IFAIL1,IFAIL2, - IFAIL3,IFAIL4,IFAIL5,IFAIL6,NGLOB,NPART,IPRT,IRNDM,NPAIR, - ICL,ICLS,INPCMP,INPTYP,NGBIN,I,J,K,II, - NGENT,NEBIN,NEENT,NC1,NC2,NC3,NC4,NCID,NC,IOS,IPLANE,ISOLID LOGICAL FLAG(MXWORD+3),LARRWR,LGLBPL,LELEPL,LARRPL,TEAUTO,TGAUTO, - LGLBPR,LELEPR,LARRPR,WFORCE,LHISKP,LEXIST,LSET,LDIFF, - LATTAC,LARRKP,DONE,OK,EXMEMB EXTERNAL RNDNOR,INPCMP,INPTYP +SELF,IF=SAVE. SAVE NRNDM,NCHA,KELEC,MELEC,TANPHI,LGLBPL,LELEPL,LARRPL,THRESH, - IORDER,LGLBPR,LELEPR,LARRPR,TEAUTO,TGAUTO,LHISKP, - LARRKP +SELF. *** Initialise those variables that are kept across calls. DATA NRNDM /1000/, NCHA /100/, IORDER /2/ DATA KELEC /1/, MELEC /MXELEC*25/ DATA TANPHI /0.0/, THRESH /0.5 / DATA LGLBPL /.FALSE./, LELEPL /.FALSE./, LARRPL /.TRUE./ DATA LGLBPR /.FALSE./, LELEPR /.FALSE./, LARRPR /.FALSE./ DATA TEAUTO /.TRUE. /, TGAUTO /.FALSE./, LATTAC /.FALSE./ DATA LHISKP /.FALSE./, LARRKP /.FALSE./ *** Make sure the cell is not in polar coordinates. IF(POLAR)THEN PRINT *,' ###### DRFARR ERROR : The ARRIVAL function'// - ' can not be applied to polar geometries.' RETURN ENDIF *** Initialise various variables being reset at each call. FILE=' ' MEMBER='< none >' REMARK='None' NCFILE=1 NCMEMB=8 NCREM=4 LARRWR=.FALSE. STEP='X' SCAN='Y' UARMIN=DXMIN UARMAX=DXMAX VARMIN=DYMIN VARMAX=DYMAX WAROFF=0 CALL ROUND(UARMIN,UARMAX,20,'SMALLER,COARSER',USTEP) NLTR=NLINED WFORCE=.FALSE. TFORC1=-1.0 TFORC2=-1.0 JSEL=0 JALL=0 JOVER=0 LDIFF=GASOK(3) OK=.TRUE. *** Examine the input line, flag the known words. CALL INPNUM(NWORD) DO 10 I=2,NWORD IF( INPCMP(I,'ATT#ACHMENT')+INPCMP(I,'NOATT#ACHMENT')+ - INPCMP(I,'BIN#S')+ - INPCMP(I,'DA#TASET')+INPCMP(I,'REM#ARK')+ - INPCMP(I,'DIFF#USION')+INPCMP(I,'NODIFF#USION')+ - INPCMP(I,'EL#ECTRONS')+ - INPCMP(I,'ITER#ATE')+INPCMP(I,'ITER#ATIONS')+ - INPCMP(I,'KEEP-HIST#OGRAMS')+INPCMP(I,'NOKEEP-HIST#OGRAMS')+ - INPCMP(I,'KEEP-RES#ULTS')+INPCMP(I,'NOKEEP-RES#ULTS')+ - INPCMP(I,'LIN#ES')+ - INPCMP(I,'PL#OT-ALL-#ELECTRONS')+ - INPCMP(I,'NOPL#OT-ALL-#ELECTRONS')+ - INPCMP(I,'PL#OT-SEL#ECTED-#ELECTRONS')+ - INPCMP(I,'NOPL#OT-SEL#ECTED-#ELECTRONS')+ - INPCMP(I,'OFF#SET')+ - INPCMP(I,'PL#OT-O#VERVIEW')+INPCMP(I,'NOPL#OT-O#VERVIEW')+ - INPCMP(I,'POL#YNOMIAL-ORD#ER')+ - INPCMP(I,'PR#INT-ALL-#ELECTRONS')+ - INPCMP(I,'NOPR#INT-ALL-#ELECTRONS')+ - INPCMP(I,'PR#INT-SEL#ECTED-#ELECTRONS')+ - INPCMP(I,'NOPR#INT-SEL#ECTED-#ELECTRONS')+ - INPCMP(I,'PR#INT-O#VERVIEW')+INPCMP(I,'NOPR#INT-O#VERVIEW')+ - INPCMP(I,'SC#AN')+INPCMP(I,'ST#EP')+ - INPCMP(I,'THR#ESHOLD')+INPCMP(I,'T#IME-WIN#DOW').NE.0)THEN FLAG(I)=.TRUE. ELSE FLAG(I)=.FALSE. ENDIF 10 CONTINUE FLAG(NWORD+1)=.TRUE. FLAG(NWORD+2)=.TRUE. FLAG(NWORD+3)=.TRUE. INEXT=2 *** Read in detail. DO 20 I=2,NWORD IF(I.LT.INEXT)GOTO 20 ** Time window. IF(INPCMP(I,'T#IME-WIN#DOW').NE.0)THEN IF(INPCMP(I+1,'AUTO#MATIC').NE.0)THEN TEAUTO=.TRUE. WFORCE=.FALSE. INEXT=I+2 ELSEIF(INPCMP(I+1,'FULL-#RANGE').NE.0)THEN TEAUTO=.FALSE. WFORCE=.FALSE. INEXT=I+2 ELSEIF(I+2.GT.NWORD.OR.FLAG(I+1).OR.FLAG(I+2))THEN CALL INPMSG(I,'This keyword has 2 arguments. ') OK=.FALSE. INEXT=I+3 ELSEIF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2)THEN CALL INPMSG(I+1,'This should be a real argument') OK=.FALSE. INEXT=I+3 ELSEIF(INPTYP(I+2).NE.1.AND.INPTYP(I+2).NE.2)THEN CALL INPMSG(I+2,'This should be a real argument') OK=.FALSE. INEXT=I+3 ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPCHK(I+2,2,IFAIL2) CALL INPRDR(I+1,TFORC1,-1.0) CALL INPRDR(I+2,TFORC2,-1.0) IF(IFAIL1.NE.0.OR.IFAIL2.NE.0.OR. - TFORC1.LT.0.0.OR.TFORC2.LT.0.0.OR. - TFORC1.EQ.TFORC2)THEN CALL INPMSG(I+1,'Window incorrectly specified. ') CALL INPMSG(I+2,'(See preceding message.) ') OK=.FALSE. ELSE WFORCE=.TRUE. TEAUTO=.FALSE. ENDIF INEXT=I+3 ENDIF ** The BINS keyword. ELSEIF(INPCMP(I,'BIN#S').NE.0)THEN IF(I+1.GT.NWORD.OR.FLAG(I+1))THEN CALL INPMSG(I,'This keyword has one argument.') OK=.FALSE. ELSEIF(INPTYP(I+1).NE.1)THEN CALL INPMSG(I+1,'This is an integer argument. ') OK=.FALSE. ELSE CALL INPCHK(I+1,1,IFAIL) CALL INPRDI(I+1,NCHAR,MXCHA) IF(NCHAR.LE.1.OR.NCHAR.GT.MXCHA)THEN CALL INPMSG(I+1,'Inacceptable number of bins. ') OK=.FALSE. ELSE NCHA=NCHAR ENDIF ENDIF INEXT=I+2 ** Histogram keeping option. ELSEIF(INPCMP(I,'KEEP-HIST#OGRAMS').NE.0)THEN LHISKP=.TRUE. ELSEIF(INPCMP(I,'NOKEEP-HIST#OGRAMS').NE.0)THEN LHISKP=.FALSE. ** Results keeping option. ELSEIF(INPCMP(I,'KEEP-RES#ULTS').NE.0)THEN LARRKP=.TRUE. ELSEIF(INPCMP(I,'NOKEEP-RES#ULTS').NE.0)THEN LARRKP=.FALSE. ** Read the output data set name. ELSEIF(INPCMP(I,'DA#TASET').NE.0)THEN IF(FLAG(I+1))THEN CALL INPMSG(I,'Should have an argument. ') OK=.FALSE. ELSE CALL INPSTR(I+1,I+1,STRING,NCFILE) FILE=STRING INEXT=I+2 IF(.NOT.FLAG(I+2))THEN CALL INPSTR(I+2,I+2,STRING,NCMEMB) MEMBER=STRING INEXT=I+3 ENDIF LARRWR=.TRUE. ENDIF ** Read the first and last particle to be considered. ELSEIF(INPCMP(I,'EL#ECTRONS').NE.0)THEN KELEC=0 DO 21 J=I+1,NWORD IF(FLAG(J))THEN GOTO 22 ELSEIF(KELEC.GE.MXELEC)THEN CALL INPMSG(J,'No room to store this electron') OK=.FALSE. GOTO 21 ELSE KELEC=KELEC+1 ENDIF IF(INPCMP(J,'L#AST').NE.0)THEN MELEC(KELEC)=0 INEXT=J+1 ELSEIF(INPCMP(J,'ONE-B#UT-#LAST').NE.0)THEN MELEC(KELEC)=-1 INEXT=J+1 ELSEIF(INPCMP(J,'TW#O-B#UT-#LAST').NE.0)THEN MELEC(KELEC)=-2 INEXT=J+1 ELSEIF(INPCMP(J,'TH#REE-B#UT-#LAST').NE.0)THEN MELEC(KELEC)=-3 INEXT=J+1 ELSEIF(INPTYP(J).NE.1)THEN CALL INPMSG(J,'This argument is an integer. ') OK=.FALSE. INEXT=J KELEC=KELEC-1 ELSE CALL INPCHK(J,1,IFAIL) CALL INPRDI(J,MR,5) IF(MR.LT.1-MXPART.AND.IFAIL.EQ.0)THEN CALL INPMSG(J,'Smaller than 1-MXPART. ') OK=.FALSE. KELEC=KELEC-1 ELSEIF(MR.GT.MXPART.AND.IFAIL.EQ.0)THEN CALL INPMSG(J,'Larger than MXPART. ') OK=.FALSE. KELEC=KELEC-1 ELSEIF(IFAIL.EQ.0)THEN MELEC(KELEC)=MR ENDIF INEXT=J+1 ENDIF 21 CONTINUE 22 CONTINUE IF(KELEC.LE.0)THEN CALL INPMSG(I,'Should have an argument. ') OK=.FALSE. KELEC=1 MELEC(1)=5 ENDIF ** Number of lines to be used for track preparation. ELSEIF(INPCMP(I,'LINE#S').NE.0)THEN IF(FLAG(I+1))THEN CALL INPMSG(I,'Specify number of drift-lines.') OK=.FALSE. ELSEIF(INPTYP(I+1).NE.1)THEN CALL INPMSG(I,'This is an integer argument. ') OK=.FALSE. ELSE CALL INPCHK(I+1,1,IFAIL) CALL INPRDI(I+1,NLTRR,NLTR) IF(NLTRR.LT.4.AND.IFAIL.EQ.0)THEN CALL INPMSG(I+1,'At least 4 lines are needed. ') OK=.FALSE. ELSEIF(NLTRR.GT.MXLIST.AND.IFAIL.EQ.0)THEN CALL INPMSG(I+1,'Not more than MXLIST lines. ') OK=.FALSE. ELSEIF(IFAIL.EQ.0)THEN NLTR=NLTRR ENDIF INEXT=I+2 ENDIF ** The ITERATIONS keyword. ELSEIF(INPCMP(I,'ITER#ATIONS')+INPCMP(I,'ITER#ATE').NE.0)THEN IF(I+1.GT.NWORD)THEN CALL INPMSG(I,'This keyword has one argument.') OK=.FALSE. ELSEIF(INPTYP(I+1).NE.1)THEN CALL INPMSG(I,'This is an integer argument. ') OK=.FALSE. ELSE CALL INPCHK(I+1,1,IFAIL) CALL INPRDI(I+1,NRNDMR,NRNDM) IF(NRNDMR.LT.1)THEN CALL INPMSG(I+1,'At least 1 iteration needed. ') OK=.FALSE. ELSE NRNDM=NRNDMR ENDIF ENDIF INEXT=I+2 ** Include diffusion and attachment, if required. ELSEIF(INPCMP(I,'DIFF#USION').NE.0)THEN IF(GASOK(3))THEN LDIFF=.TRUE. ELSE CALL INPMSG(I,'No diffusion data available.') OK=.FALSE. ENDIF ELSEIF(INPCMP(I,'NODIFF#USION').NE.0)THEN LDIFF=.FALSE. ELSEIF(INPCMP(I,'ATT#ACHMENT').NE.0)THEN IF(GASOK(6))THEN LATTAC=.TRUE. ELSE CALL INPMSG(I,'No attachment data available.') OK=.FALSE. ENDIF ELSEIF(INPCMP(I,'NOATT#ACHMENT').NE.0)THEN LATTAC=.FALSE. ** Plot options. ELSEIF(INPCMP(I,'PL#OT-ALL-#ELECTRONS').NE.0)THEN LGLBPL=.TRUE. ELSEIF(INPCMP(I,'NOPL#OT-ALL-#ELECTRONS').NE.0)THEN LGLBPL=.FALSE. ELSEIF(INPCMP(I,'PL#OT-SEL#ECTED-#ELECTRONS').NE.0)THEN LELEPL=.TRUE. ELSEIF(INPCMP(I,'NOPL#OT-SEL#ECTED-#ELECTRONS').NE.0)THEN LELEPL=.FALSE. ELSEIF(INPCMP(I,'PL#OT-O#VERVIEW').NE.0)THEN LARRPL=.TRUE. ELSEIF(INPCMP(I,'NOPL#OT-O#VERVIEW').NE.0)THEN LARRPL=.FALSE. ** Print options. ELSEIF(INPCMP(I,'PR#INT-ALL-#ELECTRONS').NE.0)THEN LGLBPR=.TRUE. ELSEIF(INPCMP(I,'NOPR#INT-ALL-#ELECTRONS').NE.0)THEN LGLBPR=.FALSE. ELSEIF(INPCMP(I,'PR#INT-SEL#ECTED-#ELECTRONS').NE.0)THEN LELEPR=.TRUE. ELSEIF(INPCMP(I,'NOPR#INT-SEL#ECTED-#ELECTRONS').NE.0)THEN LELEPR=.FALSE. ELSEIF(INPCMP(I,'PR#INT-O#VERVIEW').NE.0)THEN LARRPR=.TRUE. ELSEIF(INPCMP(I,'NOPR#INT-O#VERVIEW').NE.0)THEN LARRPR=.FALSE. ** The POLYNOMIAL-ORDER keyword. ELSEIF(INPCMP(I,'POL#YNOMIAL-ORD#ER').NE.0)THEN IF(I+1.GT.NWORD)THEN CALL INPMSG(I,'This keyword has one argument.') OK=.FALSE. ELSEIF(INPCMP(I+1,'LIN#EAR').NE.0)THEN IORDER=1 INEXT=I+2 ELSEIF(INPCMP(I+1,'QUAD#RATIC')+ - INPCMP(I+1,'PARA#BOLIC').NE.0)THEN IORDER=2 INEXT=I+2 ELSEIF(INPCMP(I+1,'CUB#IC').NE.0)THEN IORDER=3 INEXT=I+2 ELSEIF(INPTYP(I+1).NE.1)THEN CALL INPMSG(I,'This is an integer argument. ') OK=.FALSE. ELSE CALL INPCHK(I+1,1,IFAIL) CALL INPRDI(I+1,IORDR,IORDER) IF(IORDR.LT.1.OR.IORDR.GT.10)THEN CALL INPMSG(I+1,'Not in the range [1,10]. ') OK=.FALSE. ELSE IORDER=IORDR ENDIF INEXT=I+2 ENDIF ** Read the remark to be added to the dataset. ELSEIF(INPCMP(I,'REM#ARK').NE.0)THEN IF(FLAG(I+1))THEN CALL INPMSG(I,'Should have an argument. ') OK=.FALSE. ELSE CALL INPSTR(I+1,I+1,STRING,NCREM) REMARK=STRING INEXT=I+2 ENDIF ** Read the threshold value. ELSEIF(INPCMP(I,'THR#ESHOLD').NE.0)THEN IF(FLAG(I+1))THEN CALL INPMSG(I,'Should have an argument. ') OK=.FALSE. ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,THRR,THRESH) IF(IFAIL1.EQ.0.AND.(THRR.LE.0.0.OR.THRR.GE.1.0))THEN CALL INPMSG(I+1,'The threshold range is <0,1>. ') OK=.FALSE. ELSEIF(IFAIL1.EQ.0)THEN THRESH=THRR ENDIF INEXT=I+2 ENDIF ** Stepping direction. ELSEIF(INPCMP(I,'ST#EP').NE.0)THEN * Find out direction. IF(INPCMP(I+1,'X').NE.0)THEN STEP='X' UARMIN=DXMIN UARMAX=DXMAX CALL ROUND(UARMIN,UARMAX,20,'SMALLER,COARSER',USTEP) ELSEIF(INPCMP(I+1,'Y').NE.0)THEN STEP='Y' UARMIN=DYMIN UARMAX=DYMAX CALL ROUND(UARMIN,UARMAX,20,'SMALLER,COARSER',USTEP) ELSEIF(INPCMP(I+1,'Z').NE.0)THEN STEP='Z' UARMIN=DZMIN UARMAX=DZMAX CALL ROUND(UARMIN,UARMAX,20,'SMALLER,COARSER',USTEP) ELSE CALL INPMSG(I,'Not followed by a direction.') OK=.FALSE. INEXT=I+1 GOTO 20 ENDIF INEXT=I+2 * Scan the sub-keywords. DO 30 J=I+2,NWORD IF(J.LT.INEXT)GOTO 30 IF(FLAG(J))THEN INEXT=J GOTO 20 * Range. ELSEIF(INPCMP(J,'RAN#GE').NE.0)THEN IF(FLAG(J+1).OR.FLAG(J+2).OR. - (INPTYP(J+1).NE.1.AND.INPTYP(J+1).NE.2).OR. - (INPTYP(J+2).NE.1.AND.INPTYP(J+2).NE.2))THEN CALL INPMSG(J,'Should have 2 real arguments.') OK=.FALSE. ELSE CALL INPCHK(J+1,2,IFAIL1) CALL INPCHK(J+2,2,IFAIL2) IF(STEP.EQ.'X')THEN CALL INPRDR(J+1,UARMIR,DXMIN) CALL INPRDR(J+2,UARMAR,DXMAX) ELSEIF(STEP.EQ.'Y')THEN CALL INPRDR(J+1,UARMIR,DYMIN) CALL INPRDR(J+2,UARMAR,DYMAX) ELSEIF(STEP.EQ.'Z')THEN CALL INPRDR(J+1,UARMIR,DZMIN) CALL INPRDR(J+2,UARMAR,DZMAX) ENDIF IF(UARMIR.EQ.UARMAR)THEN CALL INPMSG(J+1,'Zero range not permitted.') CALL INPMSG(J+2,'See preceding message.') OK=.FALSE. ELSEIF((STEP.EQ.'X'.AND.( - MAX(UARMIR,UARMAR).LT.DXMIN.OR. - MIN(UARMIR,UARMAR).GT.DXMAX)).OR. - (STEP.EQ.'Y'.AND.( - MAX(UARMIR,UARMAR).LT.DYMIN.OR. - MIN(UARMIR,UARMAR).GT.DYMAX)).OR. - (STEP.EQ.'Z'.AND.( - MAX(UARMIR,UARMAR).LT.DZMIN.OR. - MIN(UARMIR,UARMAR).GT.DZMAX)))THEN CALL INPMSG(J+1,'Range not inside the area.') CALL INPMSG(J+2,'See preceding message.') OK=.FALSE. ELSE IF(STEP.EQ.'X')THEN UARMIN=MAX(DXMIN,MIN(UARMIR,UARMAR)) UARMAX=MIN(DXMAX,MAX(UARMIR,UARMAR)) ELSEIF(STEP.EQ.'Y')THEN UARMIN=MAX(DYMIN,MIN(UARMIR,UARMAR)) UARMAX=MIN(DYMAX,MAX(UARMIR,UARMAR)) ELSEIF(STEP.EQ.'Z')THEN UARMIN=MAX(DZMIN,MIN(UARMIR,UARMAR)) UARMAX=MIN(DZMAX,MAX(UARMIR,UARMAR)) ENDIF ENDIF INEXT=J+3 ENDIF * Step size. ELSEIF(INPCMP(J,'INCR#EMENT').NE.0)THEN IF(FLAG(J+1).OR. - (INPTYP(J+1).NE.1.AND.INPTYP(J+1).NE.2))THEN CALL INPMSG(J,'Should have 1 real argument.') OK=.FALSE. ELSE CALL INPCHK(J+1,2,IFAIL) CALL INPRDR(J+1,USTEPR,USTEP) IF(USTEPR.LE.0)THEN CALL INPMSG(J+1, - 'The step size must be positive') OK=.FALSE. ELSE USTEP=USTEPR ENDIF INEXT=J+2 ENDIF * Unknown sub-keyword. ELSE CALL INPMSG(J,'Not a sub-keyword of STEP.') ENDIF 30 CONTINUE ** Scanning direction. ELSEIF(INPCMP(I,'SC#AN').NE.0)THEN * Find out direction. IF(INPCMP(I+1,'X').NE.0)THEN SCAN='X' VARMIN=DXMIN VARMAX=DXMAX ELSEIF(INPCMP(I+1,'Y').NE.0)THEN SCAN='Y' VARMIN=DYMIN VARMAX=DYMAX ELSEIF(INPCMP(I+1,'Z').NE.0)THEN SCAN='Z' VARMIN=DZMIN VARMAX=DZMAX ELSE CALL INPMSG(I,'Not followed by a direction.') OK=.FALSE. INEXT=I+1 GOTO 20 ENDIF INEXT=I+2 * Scan for sub-keywords. DO 40 J=I+2,NWORD IF(J.LT.INEXT)GOTO 40 IF(FLAG(J))THEN INEXT=J GOTO 20 * Range. ELSEIF(INPCMP(J,'RAN#GE').NE.0)THEN IF(FLAG(J+1).OR.FLAG(J+2).OR. - (INPTYP(J+1).NE.1.AND.INPTYP(J+1).NE.2).OR. - (INPTYP(J+2).NE.1.AND.INPTYP(J+2).NE.2))THEN CALL INPMSG(J,'Should have 2 real arguments.') OK=.FALSE. ELSE CALL INPCHK(J+1,2,IFAIL1) CALL INPCHK(J+2,2,IFAIL2) IF(STEP.EQ.'X')THEN CALL INPRDR(J+1,VARMIR,DXMIN) CALL INPRDR(J+2,VARMAR,DXMAX) ELSEIF(STEP.EQ.'Y')THEN CALL INPRDR(J+1,VARMIR,DYMIN) CALL INPRDR(J+2,VARMAR,DYMAX) ELSEIF(STEP.EQ.'Z')THEN CALL INPRDR(J+1,VARMIR,DZMIN) CALL INPRDR(J+2,VARMAR,DZMAX) ENDIF IF(VARMIR.EQ.VARMAR)THEN CALL INPMSG(J+1,'Zero range not permitted.') CALL INPMSG(J+2,'See preceding message.') OK=.FALSE. ELSEIF((SCAN.EQ.'X'.AND.( - MAX(VARMIR,VARMAR).LT.DXMIN.OR. - MIN(VARMIR,VARMAR).GT.DXMAX)).OR. - (SCAN.EQ.'Y'.AND.( - MAX(VARMIR,VARMAR).LT.DYMIN.OR. - MIN(VARMIR,VARMAR).GT.DYMAX)).OR. - (SCAN.EQ.'Z'.AND.( - MAX(VARMIR,VARMAR).LT.DZMIN.OR. - MIN(VARMIR,VARMAR).GT.DZMAX)))THEN CALL INPMSG(J+1,'Range not inside the area.') CALL INPMSG(J+2,'See preceding message.') OK=.FALSE. ELSE IF(SCAN.EQ.'X')THEN VARMIN=MAX(DXMIN,MIN(VARMIR,VARMAR)) VARMAX=MIN(DXMAX,MAX(VARMIR,VARMAR)) ELSEIF(SCAN.EQ.'Y')THEN VARMIN=MAX(DYMIN,MIN(VARMIR,VARMAR)) VARMAX=MIN(DYMAX,MAX(VARMIR,VARMAR)) ELSEIF(SCAN.EQ.'Z')THEN VARMIN=MAX(DZMIN,MIN(VARMIR,VARMAR)) VARMAX=MIN(DZMAX,MAX(VARMIR,VARMAR)) ENDIF ENDIF INEXT=J+3 ENDIF * Angle. ELSEIF(INPCMP(J,'ANG#LE').NE.0)THEN IF(FLAG(J+1).OR. - (INPTYP(J+1).NE.1.AND.INPTYP(J+1).NE.2))THEN CALL INPMSG(J,'Should have 1 real argument.') OK=.FALSE. ELSE CALL INPCHK(J+1,2,IFAIL) CALL INPRDR(J+1,ANGLER,180.0*ATAN(TANPHI)/PI) IF(ABS(ANGLER).GE.80)THEN CALL INPMSG(J+1, - 'Not within the range [-80,80].') OK=.FALSE. ELSE TANPHI=TAN(PI*ANGLER/180.0) ENDIF INEXT=J+2 ENDIF * Unknown sub-keywords. ELSE CALL INPMSG(J,'Not a sub-keyword of SCAN.') ENDIF 40 CONTINUE ** Offset of the plane. ELSEIF(INPCMP(I,'OFF#SET').NE.0)THEN IF(FLAG(I+1))THEN CALL INPMSG(I,'Should have an argument. ') OK=.FALSE. ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,WAROFF,0.0) INEXT=I+2 ENDIF ** The option is not known to the program. ELSE CALL INPMSG(I,'The option is not known. ') OK=.FALSE. ENDIF 20 CONTINUE * Display error messages. CALL INPERR *** Check the presence of sufficient gas data. IF((.NOT.GASOK(1)).OR.(.NOT.(GASOK(5).OR.HEEDOK)).OR. - (LDIFF.AND..NOT.GASOK(3)).OR. - (LATTAC.AND..NOT.GASOK(6)))THEN PRINT *,' ###### DRFARR ERROR : Insufficient gas data'// - ' to perform the calculations; ARRIVAL not executed.' RETURN ENDIF *** Tell if diffusion is not taken into account. IF(.NOT.LDIFF)PRINT *,' ------ DRFARR MESSAGE : Diffusion will'// - ' not be taken into account.' *** Check the length of the various strings. IF(NCFILE.GT.MXNAME)THEN PRINT *,' !!!!!! DRFARR WARNING : The dataset name is too'// - ' long and is truncated to '//FILE//'.' OK=.FALSE. NCFILE=MXNAME ENDIF IF(NCMEMB.GT.8)THEN PRINT *,' !!!!!! DRFARR WARNING : The member name is too'// - ' long and is truncated to '//MEMBER//'.' OK=.FALSE. NCMEMB=8 ENDIF IF(NCREM.GT.29)THEN PRINT *,' !!!!!! DRFARR WARNING : The remark is too'// - ' long and is truncated to '//REMARK//'.' OK=.FALSE. NCREM=29 ENDIF * Check whether the member already exists. IF(LARRWR)THEN CALL DSNREM(FILE(1:NCFILE),MEMBER(1:NCMEMB),'ARRIVAL', - EXMEMB) IF(JEXMEM.EQ.2.AND.EXMEMB)THEN PRINT *,' ------ DRFARR MESSAGE : A copy of the'// - ' member exists; new member will be appended.' ELSEIF(JEXMEM.EQ.3.AND.EXMEMB)THEN PRINT *,' !!!!!! DRFARR WARNING : A copy of the'// - ' member exists already; member will not be'// - ' written.' LARRWR=.FALSE. OK=.FALSE. ENDIF ENDIF *** Print some debugging output, to check correct input handling. IF(LDEBUG)THEN WRITE(LUNOUT,'('' ++++++ DRFARR DEBUG : '', - ''Step in '',A,'' range: '',2E12.5,'' increment: '', - E12.5/26X, - ''Scan in '',A,'' range: '',2E12.5,'' tan(angle): '', - E12.5/26X,''Offset '',E12.5/ - 26X,''bins='',I3,'', lines='',I3,'', order='',I3/ - 26X,''threshold='',E12.5)') - STEP,UARMIN,UARMAX,USTEP, - SCAN,VARMIN,VARMAX,TANPHI, - NCHA,NLTR,IORDER,THRESH WRITE(LUNOUT,'(26X,''Selected electrons: '',100(I3:))') - (MELEC(I),I=1,KELEC) IF(LARRWR)THEN WRITE(LUNOUT,'(/26X,''Output dataset="'',A, - ''", member="'',A,''"''/26X,''Remark="'',A, - ''"'')') FILE(1:NCFILE),MEMBER(1:NCMEMB), - REMARK(1:NCREM) ELSE WRITE(LUNOUT,'(/26X,''No dataset output.'')') ENDIF ENDIF *** Quit now if OK is no longer true and if JFAIL is set. IF(JFAIL.EQ.2.AND..NOT.OK)THEN PRINT *,' ###### DRFARR ERROR : Instruction is not'// - ' carried out because of the above errors.' RETURN ELSEIF(JFAIL.EQ.3.AND..NOT.OK)THEN PRINT *,' ###### DRFARR ERROR : Program terminated'// - ' because of the above errors.' CALL QUIT ENDIF *** Check the parameters, first orthogonality. IF(SCAN.EQ.STEP)THEN PRINT *,' !!!!!! DRFARR WARNING : The scanning and the'// - ' stepping direction coincide; not executed.' RETURN ELSEIF( - (((SCAN.EQ.'X'.AND.STEP.EQ.'Y').OR. - (SCAN.EQ.'Y'.AND.STEP.EQ.'X')).AND. - (DZMIN-WAROFF)*(WAROFF-DZMAX).LT.0).OR. - (((SCAN.EQ.'X'.AND.STEP.EQ.'Z').OR. - (SCAN.EQ.'Z'.AND.STEP.EQ.'X')).AND. - (DYMIN-WAROFF)*(WAROFF-DYMAX).LT.0).OR. - (((SCAN.EQ.'Y'.AND.STEP.EQ.'Y').OR. - (SCAN.EQ.'Z'.AND.STEP.EQ.'Z')).AND. - (DXMIN-WAROFF)*(WAROFF-DXMAX).LT.0))THEN PRINT *,' !!!!!! DRFARR WARNING : The plane offset'// - ' is located outside the area; not executed.' RETURN ENDIF *** Initialise progress printing. CALL PROINT('ARRIVAL',3,6) *** Loop over the electrodes by requested drift status code. CALL PROFLD(1,'Electrodes',REAL(5+NWIRE+NSOLID)) ISWCNT=0 DO 100 IW=-15,2*MXWIRE+MXSOLI * References. IPLANE=0 ISOLID=0 * Skip the tube if non-existing / non-selected / out of area. IF(IW.EQ.-15)THEN ISWCNT=ISWCNT+1 CALL PROSTA(1,REAL(ISWCNT)) IF((.NOT.TUBE).OR.INDPLA(5).EQ.0)GOTO 100 IF((DXMIN-COTUBE)*(COTUBE-DXMAX).LT.0.OR. - (DYMIN-COTUBE)*(COTUBE-DYMAX).LT.0)GOTO 100 IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DRFARR DEBUG :'', - '' Tube selected.'')') XW=0 YW=0 ZW=0 STRID='the tube' NCID=8 * Skip non-existing / non-selected / out of range planes. ELSEIF(IW.GE.-14.AND.IW.LE.-11)THEN ISWCNT=ISWCNT+1 CALL PROSTA(1,REAL(ISWCNT)) IPLANE=-(IW+10) IF((.NOT.YNPLAN(IPLANE)).OR.INDPLA(IPLANE).EQ.0)GOTO 100 IF(IPLANE.LE.2.AND. - (DXMIN-COPLAN(IPLANE))*(COPLAN(IPLANE)-DXMAX).LT.0) - GOTO 100 IF(IPLANE.GT.2.AND. - (DYMIN-COPLAN(IPLANE))*(COPLAN(IPLANE)-DYMAX).LT.0) - GOTO 100 IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DRFARR DEBUG :'', - '' Plane '',I1,'' selected.'')') IPLANE IF(IPLANE.LE.2)THEN XW=COPLAN(IPLANE) YW=0 ELSE XW=0 YW=COPLAN(IPLANE) ENDIF ZW=0 CALL OUTFMT(REAL(IPLANE),2,STR1,NC1,'LEFT') STRID='plane '//STR1(1:NC1) NCID=6+NC1 * Status codes between -10 and 0 are not of interest. ELSEIF(IW.GE.-10.AND.IW.LE.0)THEN GOTO 100 * Skip non-existing / non-selected / out of range wires. ELSEIF(IW.GE.1.AND.IW.LE.NWIRE)THEN ISWCNT=ISWCNT+1 CALL PROSTA(1,REAL(ISWCNT)) IF(INDSW(IW).EQ.0)GOTO 100 IF((DXMIN-X(IW))*(X(IW)-DXMAX).LT.0.OR. - (DYMIN-Y(IW))*(Y(IW)-DYMAX).LT.0)GOTO 100 IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DRFARR DEBUG :'', - '' Wire '',I1,'' selected.'')') IW XW=X(IW) YW=Y(IW) ZW=0 CALL OUTFMT(REAL(IW),2,STR1,NC1,'LEFT') STRID='wire '//STR1(1:NC1) NCID=5+NC1 * Non-existent wires and replicas are of no interest. ELSEIF(IW.GE.NWIRE+1.AND.IW.LE.2*MXWIRE)THEN GOTO 100 * Skip solids that were not selected. ELSEIF(IW.GE.2*MXWIRE+1.AND.IW.LE.2*MXWIRE+NSOLID)THEN ISWCNT=ISWCNT+1 CALL PROSTA(1,REAL(ISWCNT)) ISOLID=IW-2*MXWIRE IF(INDSOL(ISOLID).EQ.0)GOTO 100 IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DRFARR DEBUG :'', - '' Solid '',I1,'' selected.'')') ISOLID IF(ISOLTP(ISOLID).EQ.1)THEN XW=REAL(CBUF(ISTART(J)+3)) YW=REAL(CBUF(ISTART(J)+4)) ZW=REAL(CBUF(ISTART(J)+5)) ELSEIF(ISOLTP(ISOLID).EQ.2)THEN XW=REAL(CBUF(ISTART(J)+6)) YW=REAL(CBUF(ISTART(J)+7)) ZW=REAL(CBUF(ISTART(J)+8)) ELSEIF(ISOLTP(ISOLID).EQ.3)THEN XW=REAL(CBUF(ISTART(J)+4)) YW=REAL(CBUF(ISTART(J)+5)) ZW=REAL(CBUF(ISTART(J)+6)) ELSEIF(ISOLTP(ISOLID).EQ.4)THEN XW=REAL(CBUF(ISTART(J)+2)) YW=REAL(CBUF(ISTART(J)+3)) ZW=REAL(CBUF(ISTART(J)+4)) ELSE PRINT *,' !!!!!! DLCARR WARNING : Found a solid of'// - ' unknown type; skipped.' GOTO 100 ENDIF CALL OUTFMT(REAL(ISOLID),2,STR1,NC1,'LEFT') STRID='solid '//STR1(1:NC1) NCID=6+NC1 * Non-existent solids are to be skipped. ELSEIF(IW.GT.2*MXWIRE+NSOLID)THEN GOTO 100 ENDIF *** Compute a reasonable range, first set the reference. IF(STEP.EQ.'X')THEN UAROFF=XW ELSEIF(STEP.EQ.'Y')THEN UAROFF=YW ELSEIF(STEP.EQ.'Z')THEN UAROFF=ZW ENDIF * Compute a range of increments. IXM=NINT((UARMIN-UAROFF)/USTEP)-1 IXP=NINT((UARMAX-UAROFF)/USTEP)+1 * Fix for the case one is very near an edge. IF(UARMIN-USTEP*0.001.GT.UAROFF+IXM*USTEP)IXM=IXM+1 IF(UARMAX+USTEP*0.001.LT.UAROFF+IXP*USTEP)IXP=IXP-1 IF(UARMIN-USTEP*0.001.GT.UAROFF+IXM*USTEP)IXM=IXM+1 IF(UARMAX+USTEP*0.001.LT.UAROFF+IXP*USTEP)IXP=IXP-1 * Make sure that the number of steps doesn't exceed MXLIST. IF(IXP-IXM+1.GT.MXLIST)THEN PRINT *,' !!!!!! DRFARR WARNING : No arrival time plot'// - ' for electrode ',IW,' because MXLIST is too small.' PRINT *,' Consider making X-STEP'// - ' larger or choose a smaller X-RANGE.' GOTO 100 ENDIF *** Loop over the x points. CALL PROFLD(2,'Steps',REAL(IXP-IXM+1)) DO 110 IX=IXM,IXP CALL PROSTA(2,REAL(IX-IXM+1)) * Initial values for the table. ARRLIS(IX-IXM+1,1)=UAROFF+IX*USTEP DO 111 I=2,4+3*MXELEC ARRLIS(IX-IXM+1,I)=0.0 111 CONTINUE ARRFLG(IX-IXM+1)=0 *** Establish track begin and end points for this coordinate. IF(STEP.EQ.'X'.AND.SCAN.EQ.'Y')THEN XT0=UAROFF+IX*USTEP+TANPHI*(VARMIN-YW) XT1=UAROFF+IX*USTEP+TANPHI*(VARMAX-YW) YT0=VARMIN YT1=VARMAX ZT0=WAROFF ZT1=WAROFF CALL CLIP(XT0,YT0,XT1,YT1,DXMIN,MAX(DYMIN,VARMIN), - DXMAX,MIN(DYMAX,VARMAX),IFAIL) ELSEIF(STEP.EQ.'X'.AND.SCAN.EQ.'Z')THEN XT0=UAROFF+IX*USTEP+TANPHI*(VARMIN-ZW) XT1=UAROFF+IX*USTEP+TANPHI*(VARMAX-ZW) YT0=WAROFF YT1=WAROFF ZT0=VARMIN ZT1=VARMAX CALL CLIP(XT0,ZT0,XT1,ZT1,DXMIN,MAX(DZMIN,VARMIN), - DXMAX,MIN(DZMAX,VARMAX),IFAIL) ELSEIF(STEP.EQ.'Y'.AND.SCAN.EQ.'X')THEN XT0=VARMIN XT1=VARMAX YT0=UAROFF+IX*USTEP+TANPHI*(VARMIN-XW) YT1=UAROFF+IX*USTEP+TANPHI*(VARMAX-XW) ZT0=WAROFF ZT1=WAROFF CALL CLIP(YT0,XT0,YT1,XT1,DYMIN,MAX(DXMIN,VARMIN), - DYMAX,MIN(DXMAX,VARMAX),IFAIL) ELSEIF(STEP.EQ.'Y'.AND.SCAN.EQ.'Z')THEN XT0=WAROFF XT1=WAROFF YT0=UAROFF+IX*USTEP+TANPHI*(VARMIN-ZW) YT1=UAROFF+IX*USTEP+TANPHI*(VARMAX-ZW) ZT0=VARMIN ZT1=VARMAX CALL CLIP(YT0,ZT0,YT1,ZT1,DYMIN,MAX(DZMIN,VARMIN), - DYMAX,MIN(DZMAX,VARMAX),IFAIL) ELSEIF(STEP.EQ.'Z'.AND.SCAN.EQ.'X')THEN XT0=VARMIN XT1=VARMAX YT0=WAROFF YT1=WAROFF ZT0=UAROFF+IX*USTEP+TANPHI*(VARMIN-XW) ZT1=UAROFF+IX*USTEP+TANPHI*(VARMAX-XW) CALL CLIP(ZT0,XT0,ZT1,XT1,DZMIN,MAX(DXMIN,VARMIN), - DZMAX,MIN(DXMAX,VARMAX),IFAIL) ELSEIF(STEP.EQ.'Z'.AND.SCAN.EQ.'Y')THEN XT0=WAROFF XT1=WAROFF YT0=VARMIN YT1=VARMAX ZT0=UAROFF+IX*USTEP+TANPHI*(VARMIN-YW) ZT1=UAROFF+IX*USTEP+TANPHI*(VARMAX-YW) CALL CLIP(ZT0,YT0,ZT1,YT1,DZMIN,MAX(DYMIN,VARMIN), - DZMAX,MIN(DYMAX,VARMAX),IFAIL) ELSE PRINT *,' !!!!!! DRFARR WARNING : Unknown pair of'// - ' stepping and scanning directions; skipped.' GOTO 100 ENDIF * Display the track. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DRFARR DEBUG : From: '', - ''('',E15.8,'','',E15.8,'','',E15.8,'')''/26X,''To: '', - ''('',E15.8,'','',E15.8,'','',E15.8,'').'')') - XT0,YT0,ZT0,XT1,YT1,ZT1 * Be sure the at least part of the track is located inside the area. IF(IFAIL.NE.0)THEN ARRFLG(IX-IXM+1)=-1 PRINT *,' !!!!!! DRFARR WARNING : The track is located'// - ' outside the drift-area; no further computations.' GOTO 110 ENDIF * Declare the track as set. TRFLAG(1)=.TRUE. *** Prepare the track for interpolation, prepare progress print. CALL PRORED(3) CALL PROFLD(3,'Track preparation',-1.0) CALL PROSTA(3,0.0) * Prepare the track, drift-time and diffusion needed only. CALL DLCTRP(XT0,YT0,ZT0,XT1,YT1,ZT1, - LDIFF,.FALSE.,LATTAC,NLTR,TGMIN,TGMAX, - SMIN,SMAX,AMIN,AMAX,BMIN,BMAX,IFAIL) IF(IFAIL.NE.0)THEN ARRFLG(IX-IXM+1)=-2 PRINT *,' !!!!!! DRFARR WARNING : Track preparation has'// - ' failed; no further arrival time computations.' GOTO 110 ELSEIF(TGMIN.GE.TGMAX)THEN ARRFLG(IX-IXM+1)=-3 PRINT *,' !!!!!! DRFARR WARNING : The range of arrival'// - ' time for the track is nill; no further computations.' GOTO 110 ENDIF * Round these values to obtain a sensible time scale. IF(LDIFF)THEN TGMIN=TGMIN-5*SMAX TGMAX=TGMAX+5*SMAX ENDIF CALL ROUND(TGMIN,TGMAX,NCHA,'LARGER',TSTEP) IF(TGMIN.LT.0.0)TGMIN=TGMIN+TSTEP*(1+INT(ABS(TGMIN/TSTEP))) TEMIN=TGMIN TEMAX=TGMAX *** Allocate histogram storage, tell that we do this. CALL PROFLD(3,'Histogram allocation',-1.0) CALL PROSTA(3,0.0) * Timing histograms with forced time window. IF(WFORCE)THEN CALL HISADM('ALLOCATE',IRFTGL,NCHA, - TFORC1,TFORC2,.FALSE.,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' ###### DRFARR ERROR : Unable to obtain'// - ' histogram space (all, t) ; end of calculations.' RETURN ENDIF DO 112 I=1,KELEC CALL HISADM('ALLOCATE',IRFTEL(I),NCHA, - TFORC1,TFORC2,.FALSE.,IFAIL2) IF(IFAIL2.NE.0)THEN PRINT *,' ###### DRFARR ERROR : Unable to obtain'// - ' histogram space (sel, t) ; end of calculations.' RETURN ENDIF 112 CONTINUE * Timing histograms with automatic time window. ELSE CALL HISADM('ALLOCATE',IRFTGL,NCHA, - TGMIN,TGMAX,TGAUTO,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' ###### DRFARR ERROR : Unable to obtain'// - ' histogram space (all, t) ; end of calculations.' RETURN ENDIF DO 113 I=1,KELEC CALL HISADM('ALLOCATE',IRFTEL(I),NCHA, - TEMIN,TEMAX,TEAUTO,IFAIL2) IF(IFAIL2.NE.0)THEN PRINT *,' ###### DRFARR ERROR : Unable to obtain'// - ' histogram space (sel, t) ; end of calculations.' RETURN ENDIF 113 CONTINUE ENDIF * Origin histograms, also reset the counter. IF(SCAN.EQ.'X')THEN CALL HISADM('ALLOCATE',IRFXGL,NCHA,XT0,XT1,.FALSE.,IFAIL3) ELSEIF(SCAN.EQ.'Y')THEN CALL HISADM('ALLOCATE',IRFXGL,NCHA,YT0,YT1,.FALSE.,IFAIL3) ELSEIF(SCAN.EQ.'Z')THEN CALL HISADM('ALLOCATE',IRFXGL,NCHA,ZT0,ZT1,.FALSE.,IFAIL3) ENDIF IF(IFAIL3.NE.0)THEN PRINT *,' ###### DRFARR ERROR : Unable to allocate'// - ' histogram (origin all) ; end of calculations.' RETURN ENDIF DO 114 I=1,KELEC IF(SCAN.EQ.'X')THEN CALL HISADM('ALLOCATE',IRFXEL(I),NCHA,XT0,XT1,.FALSE., - IFAIL4) ELSEIF(SCAN.EQ.'Y')THEN CALL HISADM('ALLOCATE',IRFXEL(I),NCHA,YT0,YT1,.FALSE., - IFAIL4) ELSEIF(SCAN.EQ.'Z')THEN CALL HISADM('ALLOCATE',IRFXEL(I),NCHA,ZT0,ZT1,.FALSE., - IFAIL4) ENDIF IF(IFAIL4.NE.0)THEN PRINT *,' ###### DRFARR ERROR : Unable to allocate'// - ' histogram (origin selected) ; end of calculations.' RETURN ENDIF NELEC(I)=0 114 CONTINUE * Cluster count histograms and counter. CALL HISADM('INTEGER',IRFNCL,NCHA,0.0,0.0,.TRUE.,IFAIL5) CALL HISADM('INTEGER',IRFNEL,NCHA,0.0,0.0,.TRUE.,IFAIL6) IF(IFAIL5.NE.0.OR.IFAIL6.NE.0)THEN PRINT *,' ###### DRFARR ERROR : Unable to obtain'// - ' histogram space (cluster) ; end of calculations.' RETURN ENDIF NGLOB=0 * Debugging output. IF(LDEBUG)PRINT *,' ++++++ DRFARR DEBUG : Time range: Tmin=', - TGMIN,', Tmax=',TGMAX IF(LDEBUG)PRINT *,' Autoscaling '// - ' global=',TGAUTO,', selected=',TEAUTO IF(LDEBUG)PRINT *,' Forced window: ', - WFORCE,' Range: ',TFORC1,TFORC2 *** Loop over the tracks, start progress printing. CALL PROFLD(3,'Tracks',REAL(NRNDM)) CALL PROSTA(3,0.0) IF(NRNDM.LE.10)THEN IPRT=1 ELSE IPRT=10**(INT(LOG10(REAL(2*NRNDM)))-1) ENDIF * Loop over the tracks. DO 140 IRNDM=1,NRNDM IF(IRNDM.EQ.IPRT*(IRNDM/IPRT))CALL PROSTA(3,REAL(IRNDM)) * Initialise clustering. CALL TRACLI * Reset number of electrons accumulated. NPART=0 NCLUS=0 ** Return to this point for a new cluster. 150 CONTINUE * Generate a new point on the track. CALL TRACLS(XCL,YCL,ZCL,ECL,NPAIR,DONE,IFAIL1) * Check whether there was a mistake. IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! DRFARR WARNING : Clustering error;'// - ' point skipped.' ARRFLG(IX-IXM+1)=-6 CALL HISADM('DELETE',IRFTGL,0,0.0,0.0,.TRUE.,IFAIL) CALL HISADM('DELETE',IRFXGL,0,0.0,0.0,.TRUE.,IFAIL) DO 155 I=1,KELEC CALL HISADM('DELETE',IRFTEL(I),0,0.0,0.0,.TRUE.,IFAIL) CALL HISADM('DELETE',IRFXEL(I),0,0.0,0.0,.TRUE.,IFAIL) 155 CONTINUE CALL HISADM('DELETE',IRFNCL,0,0.0,0.0,.TRUE.,IFAIL) CALL HISADM('DELETE',IRFNEL,0,0.0,0.0,.TRUE.,IFAIL) IF(LHISKP)PRINT *,' !!!!!! DRFARR WARNING : Histograms'// - ' not kept - no entries.' GOTO 110 * Check whether this was beyond the last cluster. ELSEIF(DONE)THEN GOTO 170 ENDIF * Increment cluster count. NCLUS=NCLUS+1 * Find the drift time and the diffusion coefficient for this point. CALL DLCTRI(XCL,YCL,ZCL,TCL,ICL,SCL,ACL,BCL,FCL, - LDIFF,.FALSE.,LATTAC,IFAIL) * Skip the rest if the status code doesn't match. IF(ICL.NE.IW.OR.IFAIL.NE.0)GOTO 150 * Apply the attachment coefficient if available. IF(LATTAC.AND.GASOK(6))NPAIR=NINT(REAL(NPAIR)*BCL) ** Generate the individual arrival times within the cluster. DO 160 ICLS=1,NPAIR * Increment counter. IF(NPART.GE.MXPART)THEN PRINT *,' !!!!!! DRFARR WARNING : Too many particles'// - ' generated on the track; increase MXPART.' GOTO 140 ENDIF NPART=NPART+1 * Register the time. IF(LDIFF)THEN ARRTIM(1,NPART)=RNDNOR(TCL,SCL) ELSE ARRTIM(1,NPART)=TCL ENDIF CALL HISENT(IRFTGL,ARRTIM(1,NPART),1.0) * Register the origin. IF(SCAN.EQ.'X')THEN ARRTIM(2,NPART)=XCL ELSEIF(SCAN.EQ.'Y')THEN ARRTIM(2,NPART)=YCL ELSEIF(SCAN.EQ.'Z')THEN ARRTIM(2,NPART)=ZCL ENDIF CALL HISENT(IRFXGL,ARRTIM(2,NPART),1.0) * Increment overall electron counter. NGLOB=NGLOB+1 160 CONTINUE * Next cluster. GOTO 150 * Last cluster done. 170 CONTINUE ** Enter the electron count. CALL HISENT(IRFNCL,REAL(NCLUS),1.0) CALL HISENT(IRFNEL,REAL(NPART),1.0) * Find the M'th particle to arrive and enter in a histogram. IF(NPART.GE.1)THEN CALL SORTRQ(ARRTIM,2,NPART,1) DO 161 I=1,KELEC IF(MELEC(I).GT.0.AND.MELEC(I).LE.NPART.AND.NPART.GT.0)THEN CALL HISENT(IRFTEL(I),ARRTIM(1,MELEC(I)),1.0) CALL HISENT(IRFXEL(I),ARRTIM(2,MELEC(I)),1.0) NELEC(I)=NELEC(I)+1 ELSEIF(MELEC(I).LE.0.AND.MELEC(I)+NPART.GE.1)THEN CALL HISENT(IRFTEL(I),ARRTIM(1,NPART+MELEC(I)),1.0) CALL HISENT(IRFXEL(I),ARRTIM(2,NPART+MELEC(I)),1.0) NELEC(I)=NELEC(I)+1 ENDIF 161 CONTINUE ENDIF * Proceed with the next random cycle. 140 CONTINUE *** Check we did indeed collect something. IF(NGLOB.LE.0)THEN ARRFLG(IX-IXM+1)=-4 CALL HISADM('DELETE',IRFTGL,0,0.0,0.0,.TRUE.,IFAIL) CALL HISADM('DELETE',IRFXGL,0,0.0,0.0,.TRUE.,IFAIL) CALL HISADM('DELETE',IRFNCL,0,0.0,0.0,.TRUE.,IFAIL) CALL HISADM('DELETE',IRFNEL,0,0.0,0.0,.TRUE.,IFAIL) DO 142 I=1,KELEC CALL HISADM('DELETE',IRFTEL(I),0,0.0,0.0,.TRUE.,IFAIL) CALL HISADM('DELETE',IRFXEL(I),0,0.0,0.0,.TRUE.,IFAIL) 142 CONTINUE IF(LHISKP)PRINT *,' !!!!!! DRFARR WARNING : Histograms'// - ' not kept - no entries.' GOTO 110 ENDIF * Inform about progress. CALL PROFLD(3,'Extracting data',-1.0) CALL PROSTA(3,0.0) *** Obtain average, median and spread; first all electrons. CALL HISINQ(IRFTGL,LEXIST,LSET,NGBIN,HGMIN,HGMAX,NGENT, - ARRLIS(IX-IXM+1,2),ARRLIS(IX-IXM+1,4)) IF(LEXIST.AND.NGENT*(HGMAX-HGMIN).GT.0)THEN CALL HISSCL(IRFTGL,REAL(NGBIN)/REAL(NGENT*(HGMAX-HGMIN))) CALL HISINV(IRFTGL,THRESH,ARRLIS(IX-IXM+1,3),IORDER,IFAIL1) CALL HISSCL(IRFTGL,REAL(NGENT*(HGMAX-HGMIN))/REAL(NGBIN)) ELSE IFAIL1=1 ENDIF * Same for selected electron. IFAIL2=0 DO 141 I=1,KELEC CALL HISINQ(IRFTEL(I),LEXIST,LSET,NEBIN,HEMIN,HEMAX,NEENT, - ARRLIS(IX-IXM+1,2+3*I),ARRLIS(IX-IXM+1,4+3*I)) IF(LEXIST.AND.NEENT*(HEMAX-HEMIN).GT.0)THEN CALL HISSCL(IRFTEL(I),REAL(NEBIN)/REAL(NEENT*(HEMAX-HEMIN))) CALL HISINV(IRFTEL(I),THRESH,ARRLIS(IX-IXM+1,3+3*I), - IORDER,IFAIL2) CALL HISSCL(IRFTEL(I),REAL(NEENT*(HEMAX-HEMIN))/REAL(NEBIN)) ELSE IFAIL2=1 ENDIF 141 CONTINUE * Keep track of error conditions. IF(IFAIL1.NE.0.OR.IFAIL2.NE.0)ARRFLG(IX-IXM+1)=-5 * Plot the curves. IF(LELEPL)THEN * Inform about progress. CALL PROFLD(3,'Plot selected e-',-1.0) CALL PROSTA(3,0.0) CALL OUTFMT(UAROFF+IX*USTEP,2,STR1,NC1,'LEFT') DO 143 I=1,KELEC CALL OUTFMT(REAL(MELEC(I)),2,STR2,NC2,'LEFT') IF(MELEC(I).GT.0)THEN TITLE='Time electron '//STR2(1:NC2)//' to '// - STRID(1:NCID)//' from '//STR1(1:NC1)//' cm' NC=27+NC1+NC2+NCID ELSEIF(MELEC(I).EQ.0)THEN TITLE='Time last electron to '//STRID(1:NCID)// - ' from '//STR1(1:NC1)//' cm' NC=31+NC1+NCID ELSE TITLE='Time last'//STR2(1:NC2)//' electron'// - ' to '//STRID(1:NCID)//' from '//STR1(1:NC1)// - ' cm' NC=31+NC1+NC2+NCID ENDIF CALL HISPLT(IRFTEL(I),'Arrival time [microsec]', - TITLE(1:NC),.TRUE.) IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) IF(GASID.NE.' ')CALL GRCOMM(2,'Gas: '//GASID) CALL GRALOG(TITLE(1:NC)) CALL GRNEXT IF(MELEC(I).GT.0)THEN TITLE='Origin electron '//STR2(1:NC2)//' to '// - STRID(1:NCID)//' from '//STR1(1:NC1)//' cm' NC=29+NC1+NC2+NCID ELSEIF(MELEC(I).EQ.0)THEN TITLE='Origin last electron to '//STRID(1:NCID)// - ' from '//STR1(1:NC1)//' cm' NC=33+NC1+NCID ELSE TITLE='Origin last'//STR2(1:NC2)//' electron'// - ' to '//STRID(1:NCID)//' from '//STR1(1:NC1)// - ' cm' NC=33+NC1+NC2+NCID ENDIF CALL HISPLT(IRFXEL(I),'Origin [track coordinate]', - TITLE(1:NC),.TRUE.) IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) IF(GASID.NE.' ')CALL GRCOMM(2,'Gas: '//GASID) CALL GRALOG(TITLE(1:NC)) CALL GRNEXT 143 CONTINUE ENDIF IF(LELEPR)THEN * Inform about progress. CALL PROFLD(3,'Print selected e-',-1.0) CALL PROSTA(3,0.0) CALL OUTFMT(UAROFF+IX*USTEP,2,STR1,NC1,'LEFT') DO 144 I=1,KELEC CALL OUTFMT(REAL(MELEC(I)),2,STR2,NC2,'LEFT') IF(MELEC(I).GT.0)THEN TITLE='Time electron '//STR2(1:NC2)//' to '// - STRID(1:NCID)//' from '//STR1(1:NC1)//' cm' NC=27+NC1+NC2+NCID ELSEIF(MELEC(I).EQ.0)THEN TITLE='Time last electron to '//STRID(1:NCID)// - ' from '//STR1(1:NC1)//' cm' NC=31+NC1+NCID ELSE TITLE='Time last'//STR2(1:NC2)//' electron'// - ' to '//STRID(1:NCID)//' from '//STR1(1:NC1)// - ' cm' NC=31+NC1+NC2+NCID ENDIF CALL HISPRT(IRFTEL(I),'Arrival time [microsec]', - TITLE(1:NC)) IF(MELEC(I).GT.0)THEN TITLE='Origin electron '//STR2(1:NC2)//' to '// - STRID(1:NCID)//' from '//STR1(1:NC1)//' cm' NC=29+NC1+NC2+NCID ELSEIF(MELEC(I).EQ.0)THEN TITLE='Origin last electron to '//STRID(1:NCID)// - ' from '//STR1(1:NC1)//' cm' NC=33+NC1+NCID ELSE TITLE='Origin last'//STR2(1:NC2)//' electron'// - ' to '//STRID(1:NCID)//' from '//STR1(1:NC1)// - ' cm' NC=33+NC1+NC2+NCID ENDIF CALL HISPRT(IRFXEL(I),'Origin [track coordinate]', - TITLE(1:NC)) 144 CONTINUE ENDIF * Global plot. IF(LGLBPL)THEN * Inform about progress. CALL PROFLD(3,'Plot all e-',-1.0) CALL PROSTA(3,0.0) CALL OUTFMT(UAROFF+IX*USTEP,2,STR1,NC1,'LEFT') CALL HISPLT(IRFTGL,'Arrival time [microsec]', - 'Time all electrons to '//STRID(1:NCID)//' from '// - STR1(1:NC1)//' cm',.TRUE.) IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) IF(GASID.NE.' ')CALL GRCOMM(2,'Gas: '//GASID) CALL GRALOG('Overall arrival time distribution. ') CALL GRNEXT CALL HISPLT(IRFXGL,'Origin [cm]', - 'Origin all electrons to '//STRID(1:NCID)//' from '// - STR1(1:NC1)//' cm',.TRUE.) IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) IF(GASID.NE.' ')CALL GRCOMM(2,'Gas: '//GASID) CALL GRALOG('Origin of the electrons. ') CALL GRNEXT CALL HISPLT(IRFNCL,'Number of clusters', - 'Clusters per track at '//STR1(1:NC1)//' cm', - .TRUE.) IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) IF(GASID.NE.' ')CALL GRCOMM(2,'Gas: '//GASID) CALL GRALOG('Clusters per track. ') CALL GRNEXT CALL HISPLT(IRFNEL,'Number of electrons', - 'Accepted electrons at '//STR1(1:NC1)//' cm', - .TRUE.) IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) IF(GASID.NE.' ')CALL GRCOMM(2,'Gas: '//GASID) CALL GRALOG('Electrons per track. ') CALL GRNEXT ENDIF IF(LGLBPR)THEN * Inform about progress. CALL PROFLD(3,'Print all e-',-1.0) CALL PROSTA(3,0.0) CALL OUTFMT(UAROFF+IX*USTEP,2,STR1,NC1,'LEFT') CALL HISPRT(IRFTGL,'Arrival time [microsec]', - 'Time all electrons to '//STRID(1:NCID)//' from '// - STR1(1:NC1)//' cm') CALL HISPRT(IRFXGL,'y-Origin [cm]', - 'Origin all electrons to '//STRID(1:NCID)//' from '// - STR1(1:NC1)//' cm') ENDIF *** Get rid of the histograms, unless KEEP has been specified. IF(LHISKP)THEN * Inform about progress. CALL PROFLD(3,'Saving histograms',-1.0) CALL PROSTA(3,0.0) JALL=JALL+1 CALL OUTFMT(REAL(JALL),2,STR1,NC1,'LEFT') CALL HISSAV(IRFTGL,'ALL_'//STR1(1:NC1),IFAIL1) CALL OUTFMT(UAROFF+IX*USTEP,2,STR3,NC3,'LEFT') IF(IFAIL1.EQ.0)THEN PRINT *,' ------ DRFARR MESSAGE : Arrival time'// - ' histogram of all electrons to '// - STRID(1:NCID)//' from '//STR3(1:NC3)// - ' cm is kept as ALL_'//STR1(1:NC1)//'.' ELSE PRINT *,' !!!!!! DRFARR WARNING : Arrival time'// - ' histogram of all electrons to '// - STRID(1:NCID)//' from '//STR3(1:NC3)// - ' cm has not been saved.' CALL HISADM('DELETE',IRFTGL,0,0.0,0.0,.TRUE.,IFAIL) ENDIF DO 401 II=1,KELEC JSEL=JSEL+1 CALL OUTFMT(REAL(JSEL),2,STR4,NC4,'LEFT') CALL HISSAV(IRFTEL(II),'SEL_'//STR4(1:NC4),IFAIL1) CALL OUTFMT(REAL(MELEC(II)),2,STR1,NC1,'LEFT') CALL OUTFMT(UAROFF+IX*USTEP,2,STR3,NC3,'LEFT') IF(IFAIL1.EQ.0)THEN PRINT *,' ------ DRFARR MESSAGE : Arrival time'// - ' histogram of electron '//STR1(1:NC1)// - ' to '//STRID(1:NCID)//' from '// - STR3(1:NC3)//' cm is kept'// - ' as SEL_'//STR4(1:NC4)//'.' ELSE PRINT *,' !!!!!! DRFARR WARNING : Arrival time'// - ' histogram of electron '//STR1(1:NC1)// - ' to '//STRID(1:NCID)//' from '// - STR3(1:NC3)//' cm has not been saved.' CALL HISADM('DELETE',IRFTEL(II),0,0.0,0.0,.TRUE.,IFAIL) ENDIF 401 CONTINUE ELSE CALL HISADM('DELETE',IRFTGL,0,0.0,0.0,.TRUE.,IFAIL) DO 403 I=1,KELEC CALL HISADM('DELETE',IRFTEL(I),0,0.0,0.0,.TRUE.,IFAIL) 403 CONTINUE ENDIF CALL HISADM('DELETE',IRFXGL,0,0.0,0.0,.TRUE.,IFAIL) CALL HISADM('DELETE',IRFNCL,0,0.0,0.0,.TRUE.,IFAIL) CALL HISADM('DELETE',IRFNEL,0,0.0,0.0,.TRUE.,IFAIL) DO 404 I=1,KELEC CALL HISADM('DELETE',IRFXEL(I),0,0.0,0.0,.TRUE.,IFAIL) 404 CONTINUE *** Next x-coordinate. 110 CONTINUE *** End of full progress printing in 3 loops. CALL PRORED(2) *** Plot an overview for this wire. IF(LARRPL)THEN ** Inform about progress. CALL PROFLD(2,'Overview plots',-1.0) CALL PROSTA(2,0.0) ** Plots of the average arrival time. TMAX=-1.0 DO 210 I=1,IXP-IXM+1 IF(ARRFLG(I).NE.0)GOTO 210 DO 220 J=2,2+3*KELEC,3 TMAX=MAX(TMAX,ARRLIS(I,J)) 220 CONTINUE 210 CONTINUE * No valid data. IF(TMAX.LE.0.0)THEN PRINT *,' !!!!!! DRFARR WARNING : Insufficient'// - ' "average" data for '//STRID(1:NCID)// - '; plot not made.' ELSE * Open frame. CALL GRCART(ARRLIS(1,1),0.0,ARRLIS(IXP-IXM+1,1),TMAX, - 'Distance from electrode centre [cm]', - 'Drift time [microsec]', - 'Average arrival times for '//STRID(1:NCID)) * Add some comments. IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) IF(GASID.NE.' ')CALL GRCOMM(2,'Gas: '//GASID) IF(PARTID.NE.'Unknown') - CALL GRCOMM(3,'Particle: '//PARTID) CALL OUTFMT(180*ATAN(TANPHI)/PI,2,STR2,NC2,'LEFT') CALL GRCOMM(4,'Angle: '//STR2(1:NC2)//' degrees') * Plot each of the curves in turn. DO 230 I=2,2+3*KELEC,3 IF(I.EQ.2)THEN CALL GRATTS('FUNCTION-1','POLYLINE') CALL GRATTS('FUNCTION-1','POLYMARKER') ELSE CALL GRATTS('FUNCTION-2','POLYLINE') CALL GRATTS('FUNCTION-2','POLYMARKER') ENDIF NPLOT=0 DO 240 IX=1,IXP-IXM+1 IF(ARRFLG(IX).EQ.0)THEN NPLOT=NPLOT+1 XPL(NPLOT)=ARRLIS(IX,1) YPL(NPLOT)=ARRLIS(IX,I) ELSE IF(NPLOT.GT.1)THEN CALL GPL(NPLOT,XPL,YPL) ELSEIF(NPLOT.EQ.1)THEN CALL GPM(1,XPL,YPL) ENDIF NPLOT=0 ENDIF 240 CONTINUE IF(NPLOT.GT.1)THEN CALL GPL(NPLOT,XPL,YPL) ELSEIF(NPLOT.EQ.1)THEN CALL GPM(1,XPL,YPL) ENDIF 230 CONTINUE * Close plot, record. CALL GRALOG('Overview of average arrival times.') CALL GRNEXT ENDIF ** Plots of the median arrival time. TMAX=-1.0 DO 211 I=1,IXP-IXM+1 IF(ARRFLG(I).NE.0)GOTO 211 DO 221 J=3,3+3*KELEC,3 TMAX=MAX(TMAX,ARRLIS(I,J)) 221 CONTINUE 211 CONTINUE * No valid data. IF(TMAX.LE.0.0)THEN PRINT *,' !!!!!! DRFARR WARNING : Insufficient'// - ' "median" data for '//STRID(1:NCID)// - '; plot not made.' ELSE * Open frame. CALL GRCART(ARRLIS(1,1),0.0,ARRLIS(IXP-IXM+1,1),TMAX, - 'Distance from electrode centre [cm]', - 'Drift time [microsec]', - 'Median arrival times for '//STRID(1:NCID)) * Add some comments. IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) IF(GASID.NE.' ')CALL GRCOMM(2,'Gas: '//GASID) IF(PARTID.NE.'Unknown') - CALL GRCOMM(3,'Particle: '//PARTID) CALL OUTFMT(180*ATAN(TANPHI)/PI,2,STR2,NC2,'LEFT') CALL GRCOMM(4,'Angle: '//STR2(1:NC2)//' degrees') * Plot each of the curves in turn. DO 231 I=3,3+3*KELEC,3 IF(I.EQ.3)THEN CALL GRATTS('FUNCTION-1','POLYLINE') CALL GRATTS('FUNCTION-1','POLYMARKER') ELSE CALL GRATTS('FUNCTION-2','POLYLINE') CALL GRATTS('FUNCTION-2','POLYMARKER') ENDIF NPLOT=0 DO 241 IX=1,IXP-IXM+1 IF(ARRFLG(IX).EQ.0)THEN NPLOT=NPLOT+1 XPL(NPLOT)=ARRLIS(IX,1) YPL(NPLOT)=ARRLIS(IX,I) ELSE IF(NPLOT.GT.1)THEN CALL GPL(NPLOT,XPL,YPL) ELSEIF(NPLOT.EQ.1)THEN CALL GPM(1,XPL,YPL) ENDIF NPLOT=0 ENDIF 241 CONTINUE IF(NPLOT.GT.1)THEN CALL GPL(NPLOT,XPL,YPL) ELSEIF(NPLOT.EQ.1)THEN CALL GPM(1,XPL,YPL) ENDIF 231 CONTINUE * Close plot, record. CALL GRALOG('Overview of median arrival times.') CALL GRNEXT ENDIF ** Plots of the arrival time spreads. TMAX=-1.0 DO 212 I=1,IXP-IXM+1 IF(ARRFLG(I).NE.0)GOTO 212 DO 222 J=4,4+3*KELEC,3 TMAX=MAX(TMAX,ARRLIS(I,J)) 222 CONTINUE 212 CONTINUE * No valid data. IF(TMAX.LE.0.0)THEN PRINT *,' !!!!!! DRFARR WARNING : Insufficient'// - ' "spread" data for '//STRID(1:NCID)// - '; plot not made.' ELSE * Open frame. CALL GRCART(ARRLIS(1,1),0.0,ARRLIS(IXP-IXM+1,1),TMAX, - 'Distance from electrode centre [cm]', - 'RMS of arrival time [microsec]', - 'Arrival time spread for '//STRID(1:NCID)) * Add some comments. IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) IF(GASID.NE.' ')CALL GRCOMM(2,'Gas: '//GASID) IF(PARTID.NE.'Unknown') - CALL GRCOMM(3,'Particle: '//PARTID) CALL OUTFMT(180*ATAN(TANPHI)/PI,2,STR2,NC2,'LEFT') CALL GRCOMM(4,'Angle: '//STR2(1:NC2)//' degrees') * Plot each of the curves in turn. DO 232 I=4,4+3*KELEC,3 IF(I.EQ.4)THEN CALL GRATTS('FUNCTION-1','POLYLINE') CALL GRATTS('FUNCTION-1','POLYMARKER') ELSE CALL GRATTS('FUNCTION-2','POLYLINE') CALL GRATTS('FUNCTION-2','POLYMARKER') ENDIF NPLOT=0 DO 242 IX=1,IXP-IXM+1 IF(ARRFLG(IX).EQ.0)THEN NPLOT=NPLOT+1 XPL(NPLOT)=ARRLIS(IX,1) YPL(NPLOT)=ARRLIS(IX,I) ELSE IF(NPLOT.GT.1)THEN CALL GPL(NPLOT,XPL,YPL) ELSEIF(NPLOT.EQ.1)THEN CALL GPM(1,XPL,YPL) ENDIF NPLOT=0 ENDIF 242 CONTINUE IF(NPLOT.GT.1)THEN CALL GPL(NPLOT,XPL,YPL) ELSEIF(NPLOT.EQ.1)THEN CALL GPM(1,XPL,YPL) ENDIF 232 CONTINUE * Close plot, record. CALL GRALOG('Overview of arrival times spreads.') CALL GRNEXT ENDIF ENDIF *** Output the data to a dataset if requested. IF(LARRWR)THEN ** Inform about progress. CALL PROFLD(2,'Dataset output',-1.0) CALL PROSTA(2,0.0) ** Open the dataset. CALL DSNOPN(FILE,NCFILE,12,'WRITE-LIBRARY',IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! DRFARR WARNING : Opening the file'// - FILE(1:NCFILE)//' failed ; write flag cancelled.' LARRWR=.FALSE. ENDIF CALL DSNLOG(FILE,'Arrival ','Sequential','Write ') * Now write a heading record to the file. CALL DATTIM(DATE,TIME) IF(REMARK.NE.'None')THEN WRITE(12,'(''% Created '',A8,'' At '',A8,1X,A8, - '' ARRIVAL "'',A29,''"'')',ERR=2010,IOSTAT=IOS) - DATE,TIME,MEMBER,REMARK ELSE WRITE(12,'(''% Created '',A8,'' At '',A8,1X,A8, - '' ARRIVAL "'',A15,'' phi '',F9.2,''"'')', - ERR=2010,IOSTAT=IOS) - DATE,TIME,MEMBER,STRID,180*ATAN(TANPHI)/PI ENDIF * Specify the number of records to be written. WRITE(12,'('' Threshold setting: '',E15.8/ - '' Angle to vertical: '',E15.8/ - '' Random cycles: '',I10/ - '' Selected electrons:'',I10)',ERR=2010,IOSTAT=IOS) - THRESH,180*ATAN(TANPHI)/PI,NRNDM,KELEC * Indicate the columns. WRITE(12,'('' Distance Electron Average time'', - '' Threshold time Time spread Notes''/ - '' [cm] [microsec]'', - '' [microsec] [microsec]'')', - ERR=2010,IOSTAT=IOS) ** Write the data itself, interpreting the various flags. DO 300 IX=1,IXP-IXM+1 * Prepare a string containing roughly the data. IF(ARRFLG(IX).EQ.0)THEN WRITE(12,'(1X,E15.8,1X,'' all'',3(1X,E15.8), - 1X,''No problem'')',ERR=2010,IOSTAT=IOS) - (ARRLIS(IX,I),I=1,4) DO 301 K=1,KELEC WRITE(12,'(17X,I8,3(1X,E15.8))',ERR=2010,IOSTAT=IOS) - MELEC(K),(ARRLIS(IX,1+3*K+I),I=1,3) 301 CONTINUE ELSEIF(ARRFLG(IX).EQ.-1)THEN WRITE(12,'(1X,E15.8,1X,'' all'', - 3('' Not available''), - 1X,''! Track located outside the area.'')', - ERR=2010,IOSTAT=IOS) ARRLIS(IX,1) ELSEIF(ARRFLG(IX).EQ.-2)THEN WRITE(12,'(1X,E15.8,1X,'' all'', - 3('' Not available''), - 1X,''! Track preparation failed.'')', - ERR=2010,IOSTAT=IOS) ARRLIS(IX,1) ELSEIF(ARRFLG(IX).EQ.-3)THEN WRITE(12,'(1X,E15.8,1X,'' all'', - 3('' Not available''), - 1X,''! Track has zero time range.'')', - ERR=2010,IOSTAT=IOS) ARRLIS(IX,1) ELSEIF(ARRFLG(IX).EQ.-4)THEN WRITE(12,'(1X,E15.8,1X,'' all'', - 3('' Not available''), - 1X,''! No track data collected.'')', - ERR=2010,IOSTAT=IOS) ARRLIS(IX,1) ELSEIF(ARRFLG(IX).EQ.-5)THEN WRITE(12,'(1X,E15.8,1X,'' all'',3(1X,E15.8), - 1X,''! Poor statistics or data.'')', - ERR=2010,IOSTAT=IOS) (ARRLIS(IX,I),I=1,4) DO 302 K=1,KELEC WRITE(12,'(17X,I8,3(1X,E15.8))',ERR=2010,IOSTAT=IOS) - MELEC(K),(ARRLIS(IX,1+3*K+I),I=1,3) 302 CONTINUE ELSEIF(ARRFLG(IX).EQ.-6)THEN WRITE(12,'(1X,E15.8,1X,'' all'', - 3('' Not available''), - 1X,''! Clustering error.'')', - ERR=2010,IOSTAT=IOS) ARRLIS(IX,1) ELSE WRITE(12,'(1X,E15.8,1X,'' all'',3(1X,E15.8), - 1X,''# Unknown status flag.'')', - ERR=2010,IOSTAT=IOS) (ARRLIS(IX,I),I=1,4) DO 303 K=1,KELEC WRITE(12,'(17X,I8,3(1X,E15.8))',ERR=2010,IOSTAT=IOS) - MELEC(K),(ARRLIS(IX,1+3*K+I),I=1,3) 303 CONTINUE ENDIF 300 CONTINUE * Close the file, if openend. CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) ENDIF *** Save the results, if desired. IF(LARRKP)THEN * Store the matrix dimensions for all matrix saves. ISIZ(1)=IXP-IXM+1 IDIM(1)=MXLIST * Format the output sequence number. JOVER=JOVER+1 CALL OUTFMT(REAL(JOVER),2,STR1,NC1,'LEFT') * Save the x-coordinates. IF(STEP.EQ.'X')THEN CALL MATSAV(ARRLIS(1,1),1,IDIM,ISIZ, - 'X_'//STR1(1:NC1),IFAIL1) ELSEIF(STEP.EQ.'Y')THEN CALL MATSAV(ARRLIS(1,1),1,IDIM,ISIZ, - 'Y_'//STR1(1:NC1),IFAIL1) ELSEIF(STEP.EQ.'Z')THEN CALL MATSAV(ARRLIS(1,1),1,IDIM,ISIZ, - 'Z_'//STR1(1:NC1),IFAIL1) ENDIF * Save the all-electron x(t) relation. CALL MATSAV(ARRLIS(1,2),1,IDIM,ISIZ, - 'MEAN_'//STR1(1:NC1),IFAIL2) CALL MATSAV(ARRLIS(1,3),1,IDIM,ISIZ, - 'MEDIAN_'//STR1(1:NC1),IFAIL3) CALL MATSAV(ARRLIS(1,4),1,IDIM,ISIZ, - 'RMS_'//STR1(1:NC1),IFAIL4) IF(IFAIL1.NE.0.OR.IFAIL2.NE.0.OR.IFAIL3.NE.0.OR. - IFAIL4.NE.0)PRINT *,' !!!!!! DRFARR WARNING :'// - ' Error saving all-electron x(t) relation.' * Save the selected electron sequence numbers. DO 400 K=1,KELEC CALL OUTFMT(REAL(K),2,STR2,NC2,'LEFT') CALL NUMSAV(REAL(MELEC(K)),'E_'//STR2(1:NC2),IFAIL1) 400 CONTINUE IF(IFAIL1.NE.0)PRINT *,' !!!!!! DRFARR WARNING : Unable'// - ' to save the electron sequence numbers.' * Save the selected electron x(t) relations. DO 410 K=1,KELEC CALL OUTFMT(REAL(K),2,STR2,NC2,'LEFT') CALL MATSAV(ARRLIS(1,2+3*K),1,IDIM,ISIZ, - 'MEAN'//STR2(1:NC2)//'_'//STR1(1:NC1),IFAIL2) CALL MATSAV(ARRLIS(1,3+3*K),1,IDIM,ISIZ, - 'MEDIAN'//STR2(1:NC2)//'_'//STR1(1:NC1),IFAIL3) CALL MATSAV(ARRLIS(1,4+3*K),1,IDIM,ISIZ, - 'RMS'//STR2(1:NC2)//'_'//STR1(1:NC1),IFAIL4) IF(IFAIL2.NE.0.OR.IFAIL3.NE.0.OR.IFAIL4.NE.0) - PRINT *,' !!!!!! DRFARR WARNING : Error saving x(t)'// - ' for selected electron '//STR2(1:NC2)//'.' 410 CONTINUE ENDIF *** Proceed with the next wire. 100 CONTINUE *** End of progress printing. CALL PROEND *** Register the amount of CPU time used by this routine. CALL TIMLOG('Calculating arrival times: ') RETURN *** Handle I/O problems. 2010 CONTINUE PRINT *,' ###### DRFARR ERROR : Error while'// - ' writing the arrival data set ; attempt to close.' CALL INPIOS(IOS) CLOSE(UNIT=12,IOSTAT=IOS,ERR=2030) RETURN 2030 CONTINUE PRINT *,' ###### DRFARR ERROR : Unable to close the data set'// - ' of the arrival times ; results not predictable.' CALL INPIOS(IOS) END +DECK,DRFDRF. SUBROUTINE DRFDRF *----------------------------------------------------------------------- * DRFDRF - This routine makes drift line plots. * VARIABLES : TSTEPR : Value of TSTEP as read from the input file. * START : Sort of call, should be obvious. * LEQTPL : Plot equal time contours or not. * LLINPL : Plotting of the drift lines. * LLINPR : Printing of the drift lines. * TSTEP : Distance between equal time contours. * MARKER : If .TRUE., markers (*) will be plotted * instead of a solid line. * (Last changed on 27/ 3/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,GASDATA. +SEQ,PARAMETERS. +SEQ,DRIFTLINE. +SEQ,PRINTPLOT. +SEQ,CONSTANTS. LOGICAL LLINPL,LLINPR,LEQTPL,LDIFPL,LTIMPL,LVELPL,LAVAPL, - LFUNPL,MARKER,SIDE(4),FLAG(MXWORD+3),LDRMC,OK, - LEQRTR,LEQRWI,LEQRED,LEQRSO,LEQRZE CHARACTER*5 START CHARACTER*(MXCHAR) FUNCT REAL TSTEP,TSTEPR,Q,ANGMIN,ANGMAX,AMINR,AMAXR INTEGER NLINEE,NLINEW,NLINEV,NLINER,NCF,ITYPE,I,J,NWORD,INEXT, - INPCMP,INPTYP,IFAIL,IFAIL1,IFAIL2,ISOREV EXTERNAL INPCMP,INPTYP +SELF,IF=SAVE. SAVE LLINPL,LLINPR,LEQTPL,LDIFPL,LTIMPL,LVELPL,LAVAPL, - LFUNPL,SIDE,TSTEP,Q,START,ITYPE,FUNCT,LDRMC, - NLINEE,NLINEW,NLINEV, - LEQRTR,LEQRWI,LEQRED,LEQRSO,LEQRZE,ANGMIN,ANGMAX +SELF. *** Initialise the parameters with DATA statements. DATA LLINPL , LLINPR , LEQTPL , LDRMC - /.TRUE. , .FALSE., .FALSE., .FALSE./ DATA LTIMPL , LVELPL , LDIFPL , LAVAPL , LFUNPL - /.FALSE., .FALSE., .FALSE., .FALSE., .FALSE./ DATA (SIDE(I),I=1,4) /.TRUE.,.TRUE.,.FALSE.,.FALSE./ DATA MARKER /.FALSE./ DATA START/' '/ DATA FUNCT/' '/ DATA NCF/1/ DATA ITYPE/1/ DATA NLINEE/20/,NLINEW/20/,NLINEV/20/ DATA Q,TSTEP/-1.0,0.5/ DATA ANGMIN/0/,ANGMAX/6.2831853/ DATA LEQRTR , LEQRWI , LEQRED , LEQRSO , LEQRZE - /.TRUE. , .FALSE., .TRUE. , .FALSE., .TRUE./ *** Decode the argument sring. CALL INPNUM(NWORD) *** First mark the keywords. DO 10 I=1,MXWORD+3 IF(I.EQ.1.OR.I.GT.NWORD)THEN FLAG(I)=.TRUE. GOTO 10 ENDIF FLAG(I)=.FALSE. IF(INPCMP(I,'ANG#LES-#RANGE')+ - INPCMP(I,'A#VALANCHE-GR#APH')+ - INPCMP(I,'CONT#OUR-#INTERVAL')+ - INPCMP(I,'D#IFFUSION-GR#APH')+ INPCMP(I,'D#OWN')+ - INPCMP(I,'EDG#ES')+ INPCMP(I,'EL#ECTRON')+ - INPCMP(I,'F#UNCTION-GR#APH')+ INPCMP(I,'ISO#CHRONES')+ - INPCMP(I,'I#ON')+ - INPCMP(I,'L#EFT')+ INPCMP(I,'L#INE-PL#OT')+ - INPCMP(I,'L#INE-PR#INT')+ INPCMP(I,'MAR#KERS')+ - INPCMP(I,'M#ONTE-C#ARLO-#DRIFT')+INPCMP(I,'MC-#DRIFT')+ - INPCMP(I,'NEG#ATIVE')+ - INPCMP(I,'NOA#VALANCHE-GR#APH')+ - INPCMP(I,'NOCONT#OUR')+ - INPCMP(I,'NOD#IFFUSION-GR#APH')+ - INPCMP(I,'NOF#UNCTION-GR#APH')+INPCMP(I,'NOISO#CHRONES')+ - INPCMP(I,'NOL#INE-PL#OT')+ - INPCMP(I,'NOL#INE-PR#INT')+ INPCMP(I,'NOT#IME-GR#APH')+ - INPCMP(I,'NOM#ONTE-C#ARLO-#DRIFT')+ - INPCMP(I,'NOMC-#DRIFT')+ - INPCMP(I,'RUN#GE-K#UTTA-#DRIFT-#LINES')+ - INPCMP(I,'RKF-#DRIFT-#LINES')+ - INPCMP(I,'NOTD#OWN')+ INPCMP(I,'NOTL#EFT')+ - INPCMP(I,'NOTR#IGHT')+ INPCMP(I,'NOTU#P')+ - INPCMP(I,'NOV#ELOCITY-GR#APH')+INPCMP(I,'POS#ITIVE')+ - INPCMP(I,'REV#ERSE-#ISOCHRONES')+ - INPCMP(I,'R#IGHT')+ INPCMP(I,'SOL#ID')+ - INPCMP(I,'THR#ESHOLD')+ INPCMP(I,'LINE#S')+ - INPCMP(I,'T#IME-GR#APH')+ INPCMP(I,'TR#ACK')+ - INPCMP(I,'SOL#IDS')+ - INPCMP(I,'U#P')+ INPCMP(I,'V#ELOCITY-GR#APH')+ - INPCMP(I,'WIR#ES')+ - INPCMP(I,'ZER#OS').NE.0)FLAG(I)=.TRUE. 10 CONTINUE *** Initial settings. ISOREV=0 *** Next figure out which options are effectively there. INEXT=2 OK=.TRUE. DO 20 I=2,NWORD IF(I.LT.INEXT)GOTO 20 ** Check whether drift-lines have to start from the edges. IF(INPCMP(I,'EDG#ES').NE.0)THEN START='EDGE' DO 30 J=I+1,NWORD * Look for the subkeyword RIGHT, IF(INPCMP(J,'NOTR#IGHT')+ - INPCMP(J,'NOR#IGHT').NE.0)THEN SIDE(1)=.FALSE. ELSEIF(INPCMP(J,'R#IGHT').NE.0)THEN SIDE(1)=.TRUE. * Look for the subkeyword LEFT, ELSEIF(INPCMP(J,'NOTL#EFT')+ - INPCMP(J,'NOL#EFT').NE.0)THEN SIDE(2)=.FALSE. ELSEIF(INPCMP(J,'L#EFT').NE.0)THEN SIDE(2)=.TRUE. * Look for the subkeyword UP, ELSEIF(INPCMP(J,'NOTU#P')+ - INPCMP(J,'NOU#P').NE.0)THEN SIDE(3)=.FALSE. ELSEIF(INPCMP(J,'U#P').NE.0)THEN SIDE(3)=.TRUE. * Look for the subkeyword DOWN, ELSEIF(INPCMP(J,'NOTD#OWN')+ - INPCMP(J,'NOD#OWN').NE.0)THEN SIDE(4)=.FALSE. ELSEIF(INPCMP(J,'D#OWN').NE.0)THEN SIDE(4)=.TRUE. * Look for the grouped options. ELSEIF(INPCMP(J,'ALL').NE.0)THEN SIDE(1)=.TRUE. SIDE(2)=.TRUE. SIDE(3)=.TRUE. SIDE(4)=.TRUE. ELSEIF(INPCMP(J,'NONE').NE.0)THEN SIDE(1)=.FALSE. SIDE(2)=.FALSE. SIDE(3)=.FALSE. SIDE(4)=.FALSE. ELSEIF(INPCMP(J,'HOR#IZONTAL').NE.0)THEN SIDE(1)=.TRUE. SIDE(2)=.TRUE. ELSEIF(INPCMP(J,'NOHOR#IZONTAL')+ - INPCMP(J,'NOTHOR#IZONTAL').NE.0)THEN SIDE(1)=.FALSE. SIDE(2)=.FALSE. ELSEIF(INPCMP(J,'VERT#ICAL').NE.0)THEN SIDE(3)=.TRUE. SIDE(4)=.TRUE. ELSEIF(INPCMP(J,'NOVERT#ICAL')+ - INPCMP(J,'NOTVERT#ICAL').NE.0)THEN SIDE(3)=.FALSE. SIDE(4)=.FALSE. * Perhaps a number of lines. ELSEIF(INPCMP(J,'LINE#S').NE.0)THEN IF(INPTYP(J+1).NE.1.OR.FLAG(J+1))THEN CALL INPMSG(J,'Misses an integer argument') OK=.FALSE. INEXT=J+1 ELSE CALL INPCHK(J+1,1,IFAIL1) CALL INPRDI(J+1,NLINER,NLINEE) IF(NLINER.GT.0)THEN NLINEE=NLINER ELSE CALL INPMSG(J+1,'Should be at least 1') OK=.FALSE. ENDIF INEXT=J+2 ENDIF * Not known in this context, skip this processing. ELSE INEXT=J GOTO 20 ENDIF * Next subkeyword. 30 CONTINUE INEXT=NWORD+1 ** Check whether drift-lines have to start from the wire surfaces. ELSEIF(INPCMP(I,'WIR#ES').NE.0)THEN START='WIRE' DO 50 J=I+1,NWORD IF(J.LT.INEXT)GOTO 50 * Perhaps a number of lines. IF(INPCMP(J,'LINE#S').NE.0)THEN IF(INPTYP(J+1).NE.1.OR.FLAG(J+1))THEN CALL INPMSG(J,'Misses an integer argument') INEXT=J+1 OK=.FALSE. ELSE CALL INPCHK(J+1,1,IFAIL1) CALL INPRDI(J+1,NLINER,NLINEW) IF(NLINER.GT.0)THEN NLINEW=NLINER ELSE CALL INPMSG(J+1,'Should be at least 1') OK=.FALSE. ENDIF INEXT=J+2 ENDIF ELSEIF(INPCMP(J,'ANG#LES-#RANGE').NE.0)THEN IF(FLAG(J+1).OR.FLAG(J+2))THEN CALL INPMSG(J,'Takes 2 real arguments') INEXT=J+1 OK=.FALSE. ELSE CALL INPCHK(J+1,2,IFAIL1) CALL INPCHK(J+2,2,IFAIL2) CALL INPRDR(J+1,AMINR,ANGMIN*180/PI) CALL INPRDR(J+2,AMAXR,ANGMAX*180/PI) IF(IFAIL1.EQ.0.AND.IFAIL2.EQ.0.AND. - AMINR.EQ.AMAXR)THEN CALL INPMSG(J+1,'Zero range not permitted.') CALL INPMSG(J+2,'See previous message.') OK=.FALSE. ELSEIF(IFAIL1.EQ.0.AND.IFAIL2.EQ.0)THEN ANGMIN=AMINR*PI/180 ANGMAX=AMAXR*PI/180 ENDIF INEXT=J+3 ENDIF * Not known in this context, skip this processing. ELSE INEXT=J GOTO 20 ENDIF 50 CONTINUE ** Check whether drift-lines have to start from the wire surfaces. ELSEIF(INPCMP(I,'SOL#IDS').NE.0)THEN START='SOLID' DO 60 J=I+1,NWORD IF(J.LT.INEXT)GOTO 60 * Perhaps a number of lines. IF(INPCMP(J,'LINE#S').NE.0)THEN IF(INPTYP(J+1).NE.1.OR.FLAG(J+1))THEN CALL INPMSG(J,'Misses an integer argument') OK=.FALSE. INEXT=J+1 ELSE CALL INPCHK(J+1,1,IFAIL1) CALL INPRDI(J+1,NLINER,NLINEV) IF(NLINER.GT.0)THEN NLINEV=NLINER ELSE CALL INPMSG(J+1,'Should be at least 1') OK=.FALSE. ENDIF INEXT=J+2 ENDIF * Not known in this context, skip this processing. ELSE INEXT=J GOTO 20 ENDIF 60 CONTINUE ** Check whether drift-lines have to start from the track. ELSEIF(INPCMP(I,'TR#ACK').NE.0)THEN IF(TRFLAG(1))THEN START='TRACK' * Look for the subkeywords. DO 40 J=I+1,NWORD IF(J.LT.INEXT)GOTO 40 * Look for the line type of the graphs. IF(INPCMP(J,'MARK#ERS').NE.0)THEN MARKER=.TRUE. ELSEIF(INPCMP(J,'SOL#ID').NE.0)THEN MARKER=.FALSE. * Look for the drift-time plotting option. ELSEIF(INPCMP(J,'T#IME-GR#APH').NE.0)THEN IF(.NOT.GASOK(1))THEN CALL INPMSG(J, - 'Drift velocity data absent. ') OK=.FALSE. ELSE LTIMPL=.TRUE. ENDIF ELSEIF(INPCMP(J,'NOT#IME-GR#APH').NE.0)THEN LTIMPL=.FALSE. * Look for the drift-velocity plotting option. ELSEIF(INPCMP(J,'V#ELOCITY-GR#APH').NE.0)THEN IF(.NOT.GASOK(1))THEN CALL INPMSG(J, - 'Drift velocity data absent. ') OK=.FALSE. ELSE LVELPL=.TRUE. ENDIF ELSEIF(INPCMP(J,'NOV#ELOCITY-GR#APH').NE.0)THEN LVELPL=.FALSE. * Look for the diffusion plotting option. ELSEIF(INPCMP(J,'D#IFFUSION-GR#APH').NE.0)THEN IF(.NOT.GASOK(3))THEN CALL INPMSG(J, - 'The diffusion data are absent.') OK=.FALSE. ELSE LDIFPL=.TRUE. ENDIF ELSEIF(INPCMP(J,'NOD#IFFUSION-GR#APH').NE.0)THEN LDIFPL=.FALSE. * Look for the avalanche plotting option. ELSEIF(INPCMP(J,'A#VALANCHE-GR#APH').NE.0)THEN IF(.NOT.GASOK(4))THEN CALL INPMSG(J, - 'The avalanche data are absent.') OK=.FALSE. ELSE LAVAPL=.TRUE. ENDIF ELSEIF(INPCMP(J,'NOA#VALANCHE-GR#APH').NE.0)THEN LAVAPL=.FALSE. * Look for the function graph plotting option. ELSEIF(INPCMP(J,'F#UNCTION-GR#APH').NE.0)THEN IF(FLAG(J+1).AND. - (NCF.LT.1.OR.FUNCT(1:NCF).EQ.' '))THEN CALL INPMSG(J, - 'Function not specified. ') OK=.FALSE. ELSE CALL INPSTR(J+1,J+1,FUNCT,NCF) LFUNPL=.TRUE. INEXT=J+2 ENDIF ELSEIF(INPCMP(J,'NOF#UNCTION-GR#APH').NE.0)THEN LFUNPL=.FALSE. FUNCT=' ' NCF=1 * Skip this processing if the keyword is not recognised. ELSE INEXT=J GOTO 20 ENDIF 40 CONTINUE INEXT=NWORD+1 * Warn if no track has been defined. ELSE CALL INPMSG(I,'The track has not been set. ') OK=.FALSE. ENDIF * Check whether the drift-lines have to start from the zeros. ELSEIF(INPCMP(I,'Z#EROS').NE.0)THEN START='ZERO' * Search for particle type, ELSEIF(INPCMP(I,'EL#ECTRON').NE.0)THEN Q=-1 ITYPE=1 ELSEIF(INPCMP(I,'I#ON').NE.0)THEN IF(GASOK(2))THEN Q=+1 ITYPE=2 ELSE CALL INPMSG(I,'Ion mobility data are missing.') OK=.FALSE. ENDIF * Look for the keyword CONTOUR, ELSEIF(INPCMP(I,'CONT#OURS-#INTERVAL')+ - INPCMP(I,'ISO#CHRONES-#INTERVAL').NE.0)THEN IF(I+1.GT.NWORD)THEN CALL INPMSG(I,'Should have a delta t as arg. ') OK=.FALSE. ELSE CALL INPCHK(I+1,2,IFAIL) CALL INPRDR(I+1,TSTEPR,TSTEP) IF(TSTEPR.LE.0.0)THEN CALL INPMSG(I,'See the next message. ') CALL INPMSG(I+1,'Interval must be larger than 0') OK=.FALSE. ENDIF IF(IFAIL.EQ.0.AND.TSTEPR.GT.0)THEN LEQTPL=.TRUE. TSTEP=TSTEPR ENDIF INEXT=I+2 ENDIF ELSEIF(INPCMP(I,'NOCONT#OURS')+ - INPCMP(I,'NOISO#CHRONES').NE.0)THEN LEQTPL=.FALSE. * Reverse isochrones. ELSEIF(INPCMP(I,'REV#ERSE-#ISOCHRONES').NE.0)THEN ISOREV=1 ELSEIF(INPCMP(I,'NOREV#ERSE-#ISOCHRONES').NE.0)THEN ISOREV=-1 * Look for the drift-line plotting option. ELSEIF(INPCMP(I,'L#INE-PL#OT').NE.0)THEN LLINPL=.TRUE. ELSEIF(INPCMP(I,'NOL#INE-PL#OT').NE.0)THEN LLINPL=.FALSE. * Look for the drift-line printing option. ELSEIF(INPCMP(I,'L#INE-PR#INT').NE.0)THEN LLINPR=.TRUE. ELSEIF(INPCMP(I,'NOL#INE-PR#INT').NE.0)THEN LLINPR=.FALSE. * Look for the charge of the particles to be drifted. ELSEIF(INPCMP(I,'POS#ITIVE').NE.0)THEN Q=+1.0 ELSEIF(INPCMP(I,'NEG#ATIVE').NE.0)THEN Q=-1.0 * Look for the Monte-Carlo options. ELSEIF(INPCMP(I,'M#ONTE-C#ARLO-#DRIFT-#LINES')+ - INPCMP(I,'MC-#DRIFT-#LINES').NE.0)THEN LDRMC=.TRUE. ELSEIF(INPCMP(I,'NOM#ONTE-C#ARLO-#DRIFT-#LINES')+ - INPCMP(I,'NOMC-#DRIFT-#LINES')+ - INPCMP(I,'RUN#GE-K#UTTA-#DRIFT-#LINES')+ - INPCMP(I,'RKF-#DRIFT-#LINES').NE.0)THEN LDRMC=.FALSE. * Valid option out of context. ELSEIF(FLAG(I))THEN CALL INPMSG(I,'Valid option out of context. ') OK=.FALSE. * Option not known. ELSE CALL INPMSG(I,'The option is not known. ') OK=.FALSE. ENDIF 20 CONTINUE CALL INPERR *** Check for errors. IF(JFAIL.EQ.2.AND..NOT.OK)THEN PRINT *,' ###### DRFDRF ERROR : Instruction is not'// - ' carried out because of the above errors.' RETURN ELSEIF(JFAIL.EQ.3.AND..NOT.OK)THEN PRINT *,' ###### DRFDRF ERROR : Program terminated'// - ' because of the above errors.' CALL QUIT ENDIF *** Check at least some output has been requested. IF(.NOT.(LEQTPL.OR.LLINPL.OR.LLINPR.OR.(START.EQ.'TRACK'.AND. - (LTIMPL.OR.LVELPL.OR.LDIFPL.OR.LAVAPL.OR.LFUNPL))))THEN PRINT *,' !!!!!! DRFDRF WARNING : DRIFT statement not', - ' executed because all output has been suppressed.' RETURN ENDIF * Carry out the drifting operation. IF(START.EQ.'WIRE')THEN IF(ISOREV.EQ.1)THEN LEQRWI=.TRUE. ELSEIF(ISOREV.EQ.-1)THEN LEQRWI=.FALSE. ENDIF IF(ITYPE.EQ.1)THEN CALL DRFWIR(-Q,ITYPE,TSTEP,LEQTPL,LEQRWI, - ANGMIN,ANGMAX,LLINPL,LLINPR,NLINEW) ELSE CALL DRFWIR(+Q,ITYPE,TSTEP,LEQTPL,LEQRWI, - ANGMIN,ANGMAX,LLINPL,LLINPR,NLINEW) ENDIF ELSEIF(START.EQ.'SOLID')THEN IF(ISOREV.EQ.1)THEN LEQRSO=.TRUE. ELSEIF(ISOREV.EQ.-1)THEN LEQRSO=.FALSE. ENDIF IF(ITYPE.EQ.1)THEN CALL DRFSOL(-Q,ITYPE,TSTEP,LEQTPL,LEQRSO, - LLINPL,LLINPR,NLINEV) ELSE CALL DRFSOL(+Q,ITYPE,TSTEP,LEQTPL,LEQRSO, - LLINPL,LLINPR,NLINEV) ENDIF ELSEIF(START.EQ.'EDGE')THEN IF(ISOREV.EQ.1)THEN LEQRED=.TRUE. ELSEIF(ISOREV.EQ.-1)THEN LEQRED=.FALSE. ENDIF CALL DRFEDG(Q,ITYPE,TSTEP,LEQTPL,LEQRED, - LLINPL,LLINPR,SIDE,NLINEE) ELSEIF(START.EQ.'TRACK')THEN IF(ISOREV.EQ.1)THEN LEQRTR=.TRUE. ELSEIF(ISOREV.EQ.-1)THEN LEQRTR=.FALSE. ENDIF CALL DRFTRA(Q,ITYPE,TSTEP,LDRMC,LEQTPL,LEQRTR, - LLINPL,LLINPR,LTIMPL,LVELPL,LDIFPL,LAVAPL,LFUNPL, - FUNCT,NCF,MARKER) ELSEIF(START.EQ.'ZERO')THEN IF(ISOREV.EQ.1)THEN LEQRZE=.TRUE. ELSEIF(ISOREV.EQ.-1)THEN LEQRZE=.FALSE. ENDIF CALL DRFZRO(Q,ITYPE,LLINPL,LLINPR,LEQTPL,LEQRZE) ELSE PRINT *,' !!!!!! DRFDRF WARNING : Plot type has not been'// - ' specified; no drift plot.' ENDIF END +DECK,DRFEDG. SUBROUTINE DRFEDG(Q,ITYPE,TSTEP,LEQTPL,LEQREV, - LLINPL,LLINPR,SIDE,NLINEE) *----------------------------------------------------------------------- * DRFEDG - Subroutine calculating and plotting drift lines given an * electric field. It also plots some isochronous lines. * This routine lets the drift lines start at DXMIN and DXMAX * VARIABLES : * (Last changed on 16/ 3/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PARAMETERS. +SEQ,CELLDATA. +SEQ,SOLIDS. +SEQ,GASDATA. +SEQ,CONSTANTS. +SEQ,PRINTPLOT. +SEQ,DRIFTLINE. DOUBLE PRECISION TRANSF INTEGER NLINEE,ITYPE,J,K,L,NC REAL Q,TSTEP,XSTART,YSTART,VXMIN,VYMIN,VXMAX,VYMAX CHARACTER*80 AUX LOGICAL LEQTPL,LLINPL,LLINPR,SIDE(4),LEQREV *** Define some formats. 1080 FORMAT('1 Table of edge drift lines :',/, - ' ===========================',//, - ' The equal time contours are separated by ',E10.3, - ' micro secs'/' The particles are ',A9,//, - ' x-start y-start steps drift time ', - ' remarks',/, - ' [cm] [cm] [microsec]'//) 1085 FORMAT('1 Table of edge drift lines :',/, - ' ===========================',//, - ' The equal time contours are separated by ',E10.3, - ' micro secs'/' The particles are ',A9,//, - ' r-start phi-start steps drift time ', - ' remarks',/, - ' [cm] [degrees] [microsec]'//) *** Print a heading, if requested. IF(LIDENT)PRINT *,' /// ROUTINE DRFEDG ///' *** Check that at least one side is left for edge drift lines. IF(.NOT.(SIDE(1).OR.SIDE(2).OR.SIDE(3).OR.SIDE(4)))THEN PRINT *,' !!!!!! DRFEDG WARNING : You ask for an'// - ' EDGE drift line plot but exclude all'// - ' edges ; no drift lines' RETURN ENDIF *** Print a heading for the table, depending on the coordinate system. IF(LLINPR)THEN IF(POLAR)THEN IF(ITYPE.EQ.1)WRITE(LUNOUT,1085) TSTEP,'electrons' IF(ITYPE.EQ.2)WRITE(LUNOUT,1085) TSTEP,'ions ' ELSE IF(ITYPE.EQ.1)WRITE(LUNOUT,1080) TSTEP,'electrons' IF(ITYPE.EQ.2)WRITE(LUNOUT,1080) TSTEP,'ions ' ENDIF ENDIF *** Prepare a plot (layout, frame number etc). IF(LEQTPL.OR.LLINPL)THEN IF(ITYPE.EQ.1.AND.Q.GT.0)THEN CALL GRCELL(VXMIN,VYMIN,VXMAX,VYMAX, - 'Positron drift lines from edges') ELSEIF(ITYPE.EQ.1)THEN CALL GRCELL(VXMIN,VYMIN,VXMAX,VYMAX, - 'Electron drift lines from edges') ELSEIF(Q.GT.0)THEN CALL GRCELL(VXMIN,VYMIN,VXMAX,VYMAX, - 'Drift lines of positive ions from edges') ELSE CALL GRCELL(VXMIN,VYMIN,VXMAX,VYMAX, - 'Drift lines of negative ions from edges') ENDIF IF(GASID.NE.' ')CALL GRCOMM(2,'Gas: '//GASID) IF(ITYPE.EQ.1)CALL GRCOMM(3,'Drifting: electrons') IF(ITYPE.EQ.2)CALL GRCOMM(3,'Drifting: ions') IF(LEQTPL)THEN CALL OUTFMT(TSTEP,2,AUX,NC,'LEFT') CALL GRCOMM(4,'Isochrone interval: '//AUX(1:NC)// - ' [microsec]') CALL DRFEQR ENDIF CALL GRALOG('Drift line and equal time plot ') ENDIF *** Start drift lines from the edges listed in the command. IF(ITYPE.EQ.2)THEN CALL GRATTS('ION-DRIFT-LINE','POLYLINE') ELSE CALL GRATTS('E-DRIFT-LINE','POLYLINE') ENDIF DO 20 K=0,NLINEE DO 30 L=0,NLINEE IF(K.NE.0.AND.K.NE.NLINEE.AND.L.NE.0.AND.L.NE.NLINEE)GOTO 30 IF(L.NE.0.AND.L.NE.NLINEE.AND.((K.EQ.0.AND..NOT.SIDE(1)).OR. - (K.EQ.NLINEE.AND..NOT.SIDE(2))))GOTO 30 IF(K.NE.0.AND.K.NE.NLINEE.AND.((L.EQ.0.AND..NOT.SIDE(3)).OR. - (L.EQ.NLINEE.AND..NOT.SIDE(4))))GOTO 30 IF((K.EQ.0.AND.L.EQ.0.AND..NOT.(SIDE(1).OR.SIDE(3))).OR. - (K.EQ.0.AND.L.EQ.NLINEE.AND..NOT.(SIDE(1).OR.SIDE(4))).OR. - (K.EQ.NLINEE.AND.L.EQ.0.AND..NOT.(SIDE(2).OR.SIDE(3))).OR. - (K.EQ.NLINEE.AND.L.EQ.NLINEE.AND. - .NOT.(SIDE(2).OR.SIDE(4))))GOTO 30 IF(POLAR)THEN XSTART=LOG(EXP(DXMIN)+REAL(K)*(EXP(DXMAX)-EXP(DXMIN))/ - REAL(NLINEE)) ELSE XSTART=DXMIN+REAL(K)*(DXMAX-DXMIN)/REAL(NLINEE) ENDIF YSTART=DYMIN+REAL(L)*(DYMAX-DYMIN)/REAL(NLINEE) *** Calculate the drift line starting at (XSTART,YSTART) CALL DLCALC(XSTART,YSTART,0.0,Q,ITYPE) *** Print information on this drift line if requested. IF(LLINPR)THEN IF(POLAR)CALL CFMRTP(XSTART,YSTART,XSTART,YSTART,1) CALL DLCSTF(ISTAT,AUX,NC) WRITE(LUNOUT,'(1X,F10.2,F10.2,I10,2X,E15.8,2X,A)') - XSTART,YSTART,NU,TU(NU),AUX(1:NC) ENDIF *** Plot the drift line obtained, if this is requested. IF(LLINPL)CALL PLAGPL(NU,XU,YU,ZU) *** Invert TU in order to obtain the time distance from the sense wire. IF(LEQREV)THEN DO 80 J=1,NU TU(J)=TU(NU)-TU(J) 80 CONTINUE *** Reverse XU,YU and TU so that they can be treated as plot vectors. DO 90 J=1,INT(NU/2.0) TRANSF=TU(J) TU(J)=TU(NU-J+1) TU(NU-J+1)=TRANSF TRANSF=XU(J) XU(J)=XU(NU-J+1) XU(NU-J+1)=TRANSF TRANSF=YU(J) YU(J)=YU(NU-J+1) YU(NU-J+1)=TRANSF 90 CONTINUE *** Don't accept lines not leading to a wire. IF((ISTAT.GE.-15.AND.ISTAT.LE.-11).OR. - (ISTAT.GE.1.AND.ISTAT.LE.NWIRE).OR. - (ISTAT.GE.2*MXWIRE+1.AND.ISTAT.LE.2*MXWIRE+NSOLID)) - CALL DRFEQT(TSTEP,ISTAT) ELSE CALL DRFEQT(TSTEP,-20) ENDIF 30 CONTINUE 20 CONTINUE *** Register the amount of CPU time used for calculating drift lines. CALL TIMLOG('Making an edge drift-line plot: ') *** Plot the equal time contours. IF(LEQTPL)CALL DRFEQP *** End this page. IF(LEQTPL.OR.LLINPL)CALL GRNEXT *** And print any error messages that might have been generated. IF(LEQTPL)CALL DRFEQE END +DECK,DRFMIN. SUBROUTINE DRFMIN *----------------------------------------------------------------------- * DRFMIN - Minimises a function along a track segment. * (Last changed on 25/ 9/97.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,GASDATA. +SEQ,PRINTPLOT. +SEQ,DRIFTLINE. +SEQ,BFIELD. CHARACTER*(MXCHAR) FUNMIN,FUNSEL,FUNTRA CHARACTER*(MXNAME) FILE CHARACTER*(MXINCH) STRING CHARACTER*10 VARLIS(MXVAR) CHARACTER*20 STATUS CHARACTER*29 REMARK CHARACTER*8 TIME,DATE,MEMBER DOUBLE PRECISION F0(3) REAL RES(2),VAR(MXVAR),XPOS,YPOS,ZPOS,EPST,EPSP,EPSTR,EPSPR, - TMIN,TMAX,TMINR,TMAXR,QMIN,EX,EY,EZ,BX,BY,BZ DOUBLE PRECISION TPARA,FTPARA,T1,FT1,T2,FT2,T3,FT3,XAUX1,YAUX1, - XAUX2,YAUX2,DRLENG INTEGER MODRES(2),MODVAR(MXVAR),INPCMP,INPTYP,I,NWORD,NCFMIN, - NCFSEL,NCFTRA,NCFILE,NCMEMB,NCREM,NSTEP,NSTEPR,NITMAX,NITR, - ITYPE,IFAIL,IFAIL1,IFAIL2,IENTRA,IENMIN,IENSEL,IU,ILOC, - NCSTAT,NREXP,NVAR,ISET1,ISET2,ISET3,I1,I2,I3,IAUX,IOS,NRES, - INEXT LOGICAL USE(MXVAR),LPRINT,LDIFF,LTOWN,LATTA,LLENG,LVELOC, - LFIELD,LMINWR,FLAG(MXWORD+3),EXMEMB,OK EXTERNAL INPCMP,INPTYP *** Initial values. FUNSEL='TRUE' NCFSEL=4 FUNMIN='TIME' NCFMIN=4 FUNTRA='?' NCFTRA=1 LPRINT=.TRUE. EPST=1.0E-4 EPSP=1.0E-4 TMIN=0.0 TMAX=0.0 NSTEP=20 NITMAX=20 QMIN=-1.0 ITYPE=1 OK=.TRUE. *** Dataset initial information. FILE=' ' NCFILE=1 MEMBER='< none >' NCMEMB=8 REMARK='none' NCREM=4 LMINWR=.FALSE. *** Decode the command line. CALL INPNUM(NWORD) * The function to be minimised. IF(NWORD.GT.1)CALL INPSTR(2,2,FUNMIN,NCFMIN) * Flag keywords. DO 20 I=1,MXWORD+3 IF(I.EQ.1.OR.I.GT.NWORD)THEN FLAG(I)=.TRUE. GOTO 20 ENDIF FLAG(I)=.FALSE. IF(INPCMP(I,'SEL#ECTION-#FUNCTION')+INPCMP(I,'ON')+ - INPCMP(I,'PR#INT')+INPCMP(I,'NOPR#INT')+ - INPCMP(I,'F#UNCTION-PREC#ISION')+ - INPCMP(I,'POS#ITIONAL-RES#OLUTION')+ - INPCMP(I,'RANGE')+INPCMP(I,'N')+ - INPCMP(I,'ITER#ATE-#LIMIT')+ - INPCMP(I,'E#LECTRON')+INPCMP(I,'I#ON')+ - INPCMP(I,'POS#ITIVE')+INPCMP(I,'NEG#ATIVE')+ - INPCMP(I,'D#ATASET')+INPCMP(I,'REM#ARK').NE.0)FLAG(I)=.TRUE. 20 CONTINUE * Scan the input. INEXT=3 DO 10 I=3,NWORD IF(I.LT.INEXT)GOTO 10 * Drift line selection criteria. IF(INPCMP(I,'SEL#ECTION-#FUNCTION').NE.0)THEN IF(FLAG(I+1))THEN CALL INPMSG(I,'No selection function given. ') OK=.FALSE. ELSE CALL INPSTR(I+1,I+1,FUNSEL,NCFSEL) ENDIF INEXT=I+2 * Printing of intermediate results. ELSEIF(INPCMP(I,'PR#INT').NE.0)THEN LPRINT=.TRUE. ELSEIF(INPCMP(I,'NOPR#INT').NE.0)THEN LPRINT=.FALSE. * Target accuracy. ELSEIF(INPCMP(I,'F#UNCTION-PREC#ISION').NE.0)THEN IF(FLAG(I+1))THEN CALL INPMSG(I,'No target precision given. ') OK=.FALSE. ELSEIF(INPTYP(I+1).LE.0)THEN CALL INPMSG(I+1,'Wrong data type. ') OK=.FALSE. ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,EPSTR,EPST) IF(IFAIL1.EQ.0.AND.EPSTR.LE.0.0.OR.EPSTR.GT.1.0)THEN CALL INPMSG(I+1,'Target precision out of range.') OK=.FALSE. ELSEIF(IFAIL1.EQ.0)THEN EPST=EPSTR ENDIF ENDIF INEXT=I+2 * Positional accuracy. ELSEIF(INPCMP(I,'POS#ITIONAL-RES#OLUTION').NE.0)THEN IF(FLAG(I+1))THEN CALL INPMSG(I,'No resolution found. ') OK=.FALSE. ELSEIF(INPTYP(I+1).LE.0)THEN CALL INPMSG(I+1,'Wrong data type. ') OK=.FALSE. ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,EPSPR,EPSP) IF(IFAIL1.EQ.0.AND.EPSPR.LE.0.0.OR.EPSPR.GT.1.0)THEN CALL INPMSG(I+1,'Target precision out of range.') OK=.FALSE. ELSEIF(IFAIL1.EQ.0)THEN EPSP=EPSPR ENDIF ENDIF INEXT=I+2 * Track selection. ELSEIF(INPCMP(I,'ON').NE.0)THEN IF(FLAG(I+1))THEN CALL INPMSG(I,'No track parameters given. ') OK=.FALSE. ELSE CALL INPSTR(I+1,I+1,FUNTRA,NCFTRA) ENDIF INEXT=I+2 * Track range. ELSEIF(INPCMP(I,'RANGE').NE.0)THEN IF(FLAG(I+1).OR.FLAG(I+2))THEN CALL INPMSG(I,'No parameter range given. ') OK=.FALSE. ELSEIF(INPTYP(I+1).EQ.0)THEN CALL INPMSG(I+1,'Wrong data type. ') OK=.FALSE. ELSEIF(INPTYP(I+2).EQ.0)THEN CALL INPMSG(I+2,'Wrong data type. ') OK=.FALSE. ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPCHK(I+2,2,IFAIL2) CALL INPRDR(I+1,TMINR,0.0) CALL INPRDR(I+2,TMAXR,0.0) IF(IFAIL1.EQ.0.AND.IFAIL2.EQ.0)THEN TMIN=TMINR TMAX=TMAXR ENDIF ENDIF INEXT=I+3 * Number of steps. ELSEIF(INPCMP(I,'N').NE.0)THEN IF(FLAG(I+1))THEN CALL INPMSG(I,'No number of steps found. ') OK=.FALSE. ELSEIF(INPTYP(I+1).NE.1)THEN CALL INPMSG(I+1,'Wrong data type. ') OK=.FALSE. ELSE CALL INPCHK(I+1,1,IFAIL1) CALL INPRDI(I+1,NSTEPR,20) IF(IFAIL1.EQ.0.AND.NSTEPR.LE.0.OR.NSTEPR.GT.MXLIST)THEN CALL INPMSG(I+1,'Number of steps out of range. ') OK=.FALSE. ELSEIF(IFAIL1.EQ.0)THEN NSTEP=NSTEPR ENDIF ENDIF INEXT=I+2 * Number of iterations. ELSEIF(INPCMP(I,'ITER#ATE-#LIMIT').NE.0)THEN IF(FLAG(I+1))THEN CALL INPMSG(I,'No iteration limit found. ') OK=.FALSE. ELSEIF(INPTYP(I+1).NE.1)THEN CALL INPMSG(I+1,'Wrong data type. ') OK=.FALSE. ELSE CALL INPCHK(I+1,1,IFAIL1) CALL INPRDI(I+1,NITR,20) IF(IFAIL1.EQ.0.AND.NITR.LE.0)THEN CALL INPMSG(I+1,'Iteration limit out of range. ') OK=.FALSE. ELSEIF(IFAIL1.EQ.0)THEN NITMAX=NITR ENDIF ENDIF INEXT=I+2 * Particle type. ELSEIF(INPCMP(I,'E#LECTRON').NE.0)THEN ITYPE=1 ELSEIF(INPCMP(I,'I#ON').NE.0)THEN IF(GASOK(2))THEN ITYPE=2 ELSE CALL INPMSG(I,'Ion mobility data missing. ') OK=.FALSE. ENDIF * Particle charge. ELSEIF(INPCMP(I,'POS#ITIVE').NE.0)THEN QMIN=+1.0 ELSEIF(INPCMP(I,'NEG#ATIVE').NE.0)THEN QMIN=-1.0 * Look for a DATASET (and perhaps a member) receiving the data. ELSEIF(INPCMP(I,'D#ATASET').NE.0)THEN IF(FLAG(I+1))THEN CALL INPMSG(I,'the dataset name is missing. ') OK=.FALSE. ELSE CALL INPSTR(I+1,I+1,STRING,NCFILE) FILE=STRING IF(.NOT.FLAG(I+2))THEN CALL INPSTR(I+2,I+2,STRING,NCMEMB) MEMBER=STRING INEXT=I+3 ELSE INEXT=I+2 ENDIF LMINWR=.TRUE. ENDIF * Look for a REMARK replacing the default remark in the header, ELSEIF(INPCMP(I,'REM#ARK').NE.0)THEN IF(FLAG(I+1))THEN CALL INPMSG(I,'No remark has been found. ') OK=.FALSE. ELSE CALL INPSTR(I+1,I+1,STRING,NCREM) REMARK=STRING(1:NCREM) INEXT=I+2 ENDIF * Anything else is not valid. ELSE CALL INPMSG(I,'Not a valid keyword. ') OK=.FALSE. ENDIF 10 CONTINUE *** Dump error messages. CALL INPERR *** Debug output. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DRFMIN DEBUG : '', - ''Function to be minimised: '',A/ - 26X,''Selection function: '',A/ - 26X,''Curve function: '',A/ - 26X,''Curve parameter range: '',2E15.8/ - 26X,''Number of curve points: '',I10/ - 26X,''Attempted function accuracy: '',E15.8/ - 26X,''Positional resolution: '',E15.8/ - 26X,''Iteration limit: '',I10/ - 26X,''Particle type and charge: '',I10,3X,F4.1)') - FUNMIN(1:NCFMIN),FUNSEL(1:NCFSEL),FUNTRA(1:NCFTRA), - TMIN,TMAX,NSTEP,EPST,EPSP,NITMAX,ITYPE,QMIN IF(LMINWR.AND.LDEBUG)THEN WRITE(LUNOUT,'('' ++++++ DRFMIN DEBUG : '', - ''Output data set: '',A/ - 26X,''Data set member: '',A/ - 26X,''Remark string: '',A)') - FILE(1:NCFILE),MEMBER(1:NCMEMB),REMARK(1:NCREM) ELSEIF(LDEBUG)THEN WRITE(LUNOUT,'('' ++++++ DRFMIN DEBUG : '', - ''No dataset output has been requested.'')') ENDIF * Check whether the member already exists. IF(LMINWR)THEN CALL DSNREM(FILE(1:NCFILE),MEMBER(1:NCMEMB),'MINIMUM', - EXMEMB) IF(JEXMEM.EQ.2.AND.EXMEMB)THEN PRINT *,' ------ DRFMIN MESSAGE : A copy of the'// - ' member exists; new member will be appended.' ELSEIF(JEXMEM.EQ.3.AND.EXMEMB)THEN PRINT *,' !!!!!! DRFMIN WARNING : A copy of the'// - ' member exists already; member will not be'// - ' written.' LMINWR=.FALSE. OK=.FALSE. ENDIF ENDIF *** Quit now if OK is no longer true and if JFAIL is set. IF(JFAIL.EQ.2.AND..NOT.OK)THEN PRINT *,' ###### DRFMIN ERROR : Instruction is not'// - ' carried out because of the above errors.' RETURN ELSEIF(JFAIL.EQ.3.AND..NOT.OK)THEN PRINT *,' ###### DRFMIN ERROR : Program terminated'// - ' because of the above errors.' CALL QUIT ENDIF *** Check that the important things have been specified. IF(FUNTRA.EQ.'?')THEN PRINT *,' !!!!!! DRFMIN WARNING : The curve over which'// - ' the minimisation is to be done, is missing.' RETURN ENDIF *** Translate the various functions, first the track function. VARLIS(1)='T' NVAR=1 CALL ALGPRE(FUNTRA,NCFTRA,VARLIS,NVAR,NRES,USE,IENTRA,IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! DRFMIN WARNING : Translation of the'// - ' curve-function failed; nothing done.' CALL ALGCLR(IENTRA) RETURN ELSEIF(.NOT.USE(1))THEN PRINT *,' !!!!!! DRFMIN WARNING : The curve-function'// - ' does not depend on T; nothing done.' CALL ALGCLR(IENTRA) RETURN ELSEIF(NRES.NE.2)THEN PRINT *,' !!!!!! DRFMIN WARNING : The curve-function'// - ' does not return 2 results; nothing done.' CALL ALGCLR(IENTRA) RETURN ENDIF *** Next the selection function. VARLIS(1)='TIME' VARLIS(2)='LENGTH' VARLIS(3)='DIFFUSION' VARLIS(4)='AVALANCHE' VARLIS(5)='LOSS' VARLIS(6)='E' VARLIS(7)='V' VARLIS(8)='B' VARLIS(9)='VELOCITY' VARLIS(10)='STATUS' NVAR=10 CALL ALGPRE(FUNSEL,NCFSEL,VARLIS,NVAR,NRES,USE,IENSEL,IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! DRFMIN WARNING : Translation of the'// - ' selection-function failed; nothing done.' CALL ALGCLR(IENTRA) CALL ALGCLR(IENSEL) RETURN ELSEIF(USE(3).AND..NOT.GASOK(3))THEN PRINT *,' !!!!!! DRFMIN WARNING : The selection function'// - ' uses diffusion data which is absent; nothing done.' CALL ALGCLR(IENTRA) CALL ALGCLR(IENSEL) RETURN ELSEIF(USE(4).AND..NOT.GASOK(4))THEN PRINT *,' !!!!!! DRFMIN WARNING : The selection function'// - ' uses Townsend data which is absent; nothing done.' CALL ALGCLR(IENTRA) CALL ALGCLR(IENSEL) RETURN ELSEIF(USE(5).AND..NOT.GASOK(6))THEN PRINT *,' !!!!!! DRFMIN WARNING : The selection function'// - ' uses attachment data which is absent; nothing done.' CALL ALGCLR(IENTRA) CALL ALGCLR(IENSEL) RETURN ELSEIF(USE(8).AND..NOT.MAGOK)THEN PRINT *,' !!!!!! DRFMIN WARNING : The selection function'// - ' uses the B field which is absent; nothing done.' CALL ALGCLR(IENTRA) CALL ALGCLR(IENSEL) RETURN ELSEIF(NRES.NE.1)THEN PRINT *,' !!!!!! DRFMIN WARNING : The selection function'// - ' does not return 1 result; nothing done.' CALL ALGCLR(IENTRA) CALL ALGCLR(IENSEL) RETURN ENDIF * Set flags for items to be computed. LLENG=USE(2) LDIFF=USE(3) LTOWN=USE(4) LATTA=USE(5) LFIELD=USE(6).OR.USE(7).OR.USE(8) LVELOC=USE(9) *** Next the function to be minimised. VARLIS(1)='TIME' VARLIS(2)='LENGTH' VARLIS(3)='DIFFUSION' VARLIS(4)='AVALANCHE' VARLIS(5)='LOSS' VARLIS(6)='E' VARLIS(7)='V' VARLIS(8)='B' VARLIS(9)='VELOCITY' NVAR=9 CALL ALGPRE(FUNMIN,NCFMIN,VARLIS,NVAR,NRES,USE,IENMIN,IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! DRFMIN WARNING : Translation of the'// - ' function to be minimised failed; nothing done.' GOTO 3000 ELSEIF(USE(3).AND..NOT.GASOK(3))THEN PRINT *,' !!!!!! DRFMIN WARNING : The function to be'// - ' minimised uses absent diffusion data; nothing done.' GOTO 3000 ELSEIF(USE(4).AND..NOT.GASOK(4))THEN PRINT *,' !!!!!! DRFMIN WARNING : The function to be'// - ' minimised uses absent Townsend data; nothing done.' GOTO 3000 ELSEIF(USE(5).AND..NOT.GASOK(6))THEN PRINT *,' !!!!!! DRFMIN WARNING : The function to be'// - ' minimised uses absent attachment data; nothing done.' GOTO 3000 ELSEIF(USE(8).AND..NOT.MAGOK)THEN PRINT *,' !!!!!! DRFMIN WARNING : The function to be'// - ' minimised uses absent B field data; nothing done.' GOTO 3000 ELSEIF(NRES.NE.1)THEN PRINT *,' !!!!!! DRFMIN WARNING : The function to be'// - ' minimised does not return 1 result; nothing done.' GOTO 3000 ENDIF * Update the flags. IF(USE(2))LLENG=.TRUE. IF(USE(3))LDIFF=.TRUE. IF(USE(4))LTOWN=.TRUE. IF(USE(5))LATTA=.TRUE. IF(USE(6).OR.USE(7).OR.USE(8))LFIELD=.TRUE. IF(USE(9))LVELOC=.TRUE. * Debugging information. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DRFMIN DEBUG : '', - ''Evaluation flags: Diffusion='',L1,'' Townsend='',L1, - '' Length='',L1/26X,''Loss='',L1,'' Field='',L1, - '' Velocity='',L1,''.'')') - LDIFF,LTOWN,LLENG,LATTA,LFIELD,LVELOC *** Prepare dataset output. IF(LMINWR)THEN * Open the file. CALL DSNOPN(FILE,NCFILE,12,'WRITE-LIBRARY',IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! DRFMIN WARNING : Opening '// - FILE(1:NCFILE)//'; minimisation data not written.' RETURN ENDIF * Record that the file has been opened. CALL DSNLOG(FILE,'Minimum ','Sequential','Write ') IF(LDEBUG)PRINT *,' ++++++ DRFMIN DEBUG : Dataset '// - FILE(1:NCFILE)//' opened on unit 12 for seq write.' * Write a heading record to the file. CALL DATTIM(DATE,TIME) WRITE(12,'(''% Created '',A8,'' At '',A8,1X,A8, - '' MINIMUM '',1X,''"'',A29,''"'')',IOSTAT=IOS,ERR=2010) - DATE,TIME,MEMBER,REMARK WRITE(12,'('' GENERAL INFORMATION:''// - '' Function to be minimised: '',A/ - '' Selection function: '',A/ - '' Curve function: '',A/ - '' Curve parameter range: '',2E15.8/ - '' Number of curve points: '',I10/ - '' Attempted function accuracy: '',E15.8/ - '' Positional resolution: '',E15.8/ - '' Iteration limit: '',I10/ - '' Particle type and charge: '',I10,3X,F4.1/)') - FUNMIN(1:NCFMIN),FUNSEL(1:NCFSEL),FUNTRA(1:NCFTRA), - TMIN,TMAX,NSTEP,EPST,EPSP,NITMAX,ITYPE,QMIN ENDIF *** Preset some parameters needed for minimisation. ISET1=0 ISET2=0 ISET3=0 I1=0 I2=0 I3=0 T1=0 T2=0 T3=0 FT1=0 FT2=0 FT3=0 *** Start the minimisation procedure itself. DO 100 I=0,NSTEP * First calculate a position. VAR(1)=TMIN+REAL(I)*(TMAX-TMIN)/REAL(NSTEP) MODVAR(1)=2 NVAR=1 NREXP=2 CALL ALGEXE(IENTRA,VAR,MODVAR,NVAR,RES,MODRES,NREXP,IFAIL) * Then the drift-line from there. XPOS=RES(1) YPOS=RES(2) ZPOS=0 IF(POLAR)THEN CALL CFMPTR(XPOS,YPOS,XPOS,YPOS,1,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! DRFMIN WARNING : Illegal polar'// - ' curve coordinate seen at T=',VAR(1), - '; no further minimisation.' IF(LMINWR)WRITE(12,'(/'' # Minimisation abandoned:'', - '' illegal polar coordinate seen.''/)') GOTO 3000 ENDIF ENDIF CALL DLCALC(XPOS,YPOS,ZPOS,QMIN,ITYPE) * And the derived information. VAR(1)=TU(NU) VAR(2)=0.0 VAR(3)=0.0 VAR(4)=0.0 VAR(5)=0.0 VAR(6)=0.0 VAR(7)=0.0 VAR(8)=0.0 VAR(9)=0.0 VAR(10)=0 IF(LLENG)THEN DRLENG=0.0 DO 110 IU=2,NU IF(POLAR)THEN CALL CF2RTC(XU(IU-1),YU(IU-1),XAUX1,YAUX1,1) CALL CF2RTC(XU(IU),YU(IU),XAUX2,YAUX2,1) DRLENG=DRLENG+ - SQRT((XAUX2-XAUX1)**2+(YAUX2-YAUX1)**2+ - (ZU(IU)-ZU(IU-1))**2) ELSE DRLENG=DRLENG+ - SQRT((XU(IU)-XU(IU-1))**2+(YU(IU)-YU(IU-1))**2+ - (ZU(IU)-ZU(IU-1))**2) ENDIF 110 CONTINUE VAR(2)=DRLENG ENDIF IF(LDIFF)CALL DLCDIF(VAR(3)) IF(LTOWN)CALL DLCTWN(VAR(4)) IF(LATTA)CALL DLCATT(VAR(5)) IF(LFIELD)THEN CALL EFIELD(XPOS,YPOS,ZPOS,EX,EY,EZ,VAR(6),VAR(7),1,ILOC) IF(MAGOK)CALL BFIELD(XPOS,YPOS,ZPOS,BX,BY,BZ,VAR(8)) ENDIF IF(LVELOC)THEN CALL DLCVEL(DBLE(XPOS),DBLE(YPOS),DBLE(ZPOS), - F0,-1.0,1,ILOC) VAR(9)=REAL(SQRT(F0(1)**2+F0(2)**2+F0(3)**2)) ENDIF IF(ISTAT.EQ.-1)THEN STATUS='Left_Area' NCSTAT=9 ELSEIF(ISTAT.EQ.-2)THEN STATUS='Too_Many_Steps' NCSTAT=14 ELSEIF(ISTAT.EQ.-3)THEN STATUS='Abandoned' NCSTAT=9 ELSEIF(ISTAT.EQ.-4)THEN STATUS='Hit_Plane' NCSTAT=9 ELSEIF(ISTAT.EQ.-5)THEN STATUS='Left_Drift_Medium' NCSTAT=17 ELSEIF(ISTAT.EQ.-6)THEN STATUS='Left_Mesh' NCSTAT=9 ELSEIF(ISTAT.GT.0.AND.ISTAT.LE.MXWIRE)THEN STATUS='Hit_'//WIRTYP(ISTAT)//'_Wire' NCSTAT=10 ELSEIF(ISTAT.GT.MXWIRE.AND.ISTAT.LE.2*MXWIRE)THEN STATUS='Hit_'//WIRTYP(ISTAT-MXWIRE)//'_Replica' NCSTAT=13 ELSE STATUS='Unknown' NCSTAT=7 ENDIF IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DRFMIN DEBUG : From ('', - 3E15.8,'') Status = '',A,'' ('',I4,'') Time ='',E15.8, - ''.'')') XPOS,YPOS,ZPOS,STATUS(1:NCSTAT),ISTAT,TU(NU) CALL STRBUF('STORE',IAUX,STATUS(1:NCSTAT),NCSTAT,IFAIL1) IF(IFAIL1.NE.0)PRINT *,' !!!!!! DRFMIN WARNING : Unable to'// - ' store the status code string; trouble in case you use it.' VAR(10)=IAUX MODVAR(1)=2 MODVAR(2)=2 MODVAR(3)=2 MODVAR(4)=2 MODVAR(5)=2 MODVAR(6)=2 MODVAR(7)=2 MODVAR(8)=2 MODVAR(9)=2 MODVAR(10)=1 * Evaluate the selection function, skip the rest if FALSE. NREXP=1 NVAR=10 CALL ALGEXE(IENSEL,VAR,MODVAR,NVAR,RES,MODRES,NREXP,IFAIL) IF(ABS(RES(1)).LT.1.0E-3)THEN IF(LDEBUG)WRITE(LUNOUT,'(26X,''Drift line rejected by'', - '' the selection function.'')') GOTO 100 ENDIF * Evaluate the function to be minimised. NREXP=1 NVAR=9 CALL ALGEXE(IENMIN,VAR,MODVAR,NVAR,RES,MODRES,NREXP,IFAIL) IF(LDEBUG)WRITE(LUNOUT,'(26X,''Function value: '',E15.8)') RES(1) * Get rid of the status string. CALL STRBUF('DELETE',IAUX,STATUS,NCSTAT,IFAIL1) * Keep track of the 3 smallest numbers. IF(RES(1).LT.FT1.OR.ISET1.EQ.0)THEN FT3=FT2 T3=T2 I3=I2 IF(ISET2.EQ.1)ISET3=1 FT2=FT1 T2=T1 I2=I1 IF(ISET1.EQ.1)ISET2=1 FT1=RES(1) T1=TMIN+REAL(I)*(TMAX-TMIN)/REAL(NSTEP) I1=I ISET1=1 ELSEIF(RES(1).LT.FT2.OR.ISET2.EQ.0)THEN FT3=FT2 T3=T2 I3=I2 IF(ISET2.EQ.1)ISET3=1 FT2=RES(1) T2=TMIN+REAL(I)*(TMAX-TMIN)/REAL(NSTEP) I2=I ISET2=1 ELSEIF(RES(1).LT.FT3.OR.ISET3.EQ.0)THEN FT3=RES(1) T3=TMIN+REAL(I)*(TMAX-TMIN)/REAL(NSTEP) I3=I ISET3=1 ENDIF 100 CONTINUE *** Now make sure that we have 3 contiguous points. IF(ISET3.EQ.0)THEN PRINT *,' !!!!!! DRFMIN WARNING : Failed to find a set of'// - ' 3 initial points; no minimisation.' IF(LMINWR)WRITE(12,'(/'' # Minimisation not performed:'', - '' number of starting points < 3.''/)') GOTO 3000 ELSEIF(MAX(I1,I2,I3).NE.MIN(I1,I2,I3)+2)THEN PRINT *,' !!!!!! DRFMIN WARNING : The initial set of 3'// - ' minimal points is not consecutive; no minimisation.' IF(LMINWR)WRITE(12,'(/'' # Minimisation not performed:'', - '' starting points are not consecutive.''/)') GOTO 3000 ENDIF *** And make a few parabolic steps. DO 120 I=1,NITMAX * Estimate parabolic minimum. TPARA=( (FT1-FT2)*T3**2+(FT3-FT1)*T2**2+(FT2-FT3)*T1**2)/ - (2*((FT1-FT2)*T3 +(FT3-FT1)*T2 +(FT2-FT3)*T1)) FTPARA=-(4*((FT1*T2**2-FT2*T1**2)*T3-(FT1*T2-FT2*T1)*T3**2- - T2**2*FT3*T1+T2*FT3*T1**2)*((FT1-FT2)*T3-FT1*T2+ - T2*FT3+FT2*T1-FT3*T1)+((FT1-FT2)*T3**2-FT1*T2**2+T2**2*FT3+ - FT2*T1**2-FT3*T1**2)**2)/(4*((FT1-FT2)*T3-FT1*T2+ - T2*FT3+FT2*T1-FT3*T1)*(T3-T2)*(T3-T1)*(T2-T1)) * Debugging output. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DRFMIN DEBUG : Iteration '', - I3//26X,''Point 1: T='',E15.8,'' F='',E15.8/ - 26X,''Point 2: T='',E15.8,'' F='',E15.8/ - 26X,''Point 3: T='',E15.8,'' F='',E15.8// - 26X,''Parabola: T='',E15.8,'' F='',E15.8)') - I,T1,FT1,T2,FT2,T3,FT3,TPARA,FTPARA * Check that the parabolic estimate is within range. IF((TMIN-TPARA)*(TPARA-TMAX).LT.0)THEN PRINT *,' !!!!!! DRFMIN WARNING : Estimated parabolic'// - ' minimum is located outside curve range.' IF(LMINWR)WRITE(12,'(/'' ! Minimisation abandoned:'', - '' parabolic minimum outside of T-range.''/)') GOTO 3000 ENDIF * Check that the new estimate doesn't coincide with an old point. IF(ABS(TPARA-T1).LT.EPSP*(EPSP+ABS(TPARA)).OR. - ABS(TPARA-T2).LT.EPSP*(EPSP+ABS(TPARA)).OR. - ABS(TPARA-T3).LT.EPSP*(EPSP+ABS(TPARA)))THEN IF(LPRINT)WRITE(LUNOUT,'(/'' Parabolic minimum'', - '' coincides with a previous point.''/)') IF(LMINWR)WRITE(12,'(/'' Minimisation halted: parabolic'', - '' minimum coincides with a previous point.''/)') GOTO 3000 ENDIF * Evaluate things over there. VAR(1)=TPARA MODVAR(1)=2 NVAR=1 NREXP=2 CALL ALGEXE(IENTRA,VAR,MODVAR,NVAR,RES,MODRES,NREXP,IFAIL) * Then the drift-line from there. XPOS=RES(1) YPOS=RES(2) ZPOS=0 IF(POLAR)THEN CALL CFMPTR(XPOS,YPOS,XPOS,YPOS,1,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! DRFMIN WARNING : Illegal polar'// - ' curve coordinate seen at T=',VAR(1), - '; no further minimisation.' IF(LMINWR)WRITE(12,'(/'' # Minimisation abandoned:'', - '' illegal polar coordinate seen.''/)') GOTO 3000 ENDIF ENDIF CALL DLCALC(XPOS,YPOS,ZPOS,QMIN,ITYPE) XPOS=RES(1) YPOS=RES(2) * And the derived information. VAR(1)=TU(NU) VAR(2)=0.0 VAR(3)=0.0 VAR(4)=0.0 VAR(5)=0.0 VAR(6)=0.0 VAR(7)=0.0 VAR(8)=0.0 VAR(9)=0.0 VAR(10)=0 IF(LLENG)THEN DRLENG=0.0 DO 130 IU=2,NU IF(POLAR)THEN CALL CF2RTC(XU(IU-1),YU(IU-1),XAUX1,YAUX1,1) CALL CF2RTC(XU(IU),YU(IU),XAUX2,YAUX2,1) DRLENG=DRLENG+ - SQRT((XAUX2-XAUX1)**2+(YAUX2-YAUX1)**2+ - (ZU(IU)-ZU(IU-1))**2) ELSE DRLENG=DRLENG+ - SQRT((XU(IU)-XU(IU-1))**2+(YU(IU)-YU(IU-1))**2+ - (ZU(IU)-ZU(IU-1))**2) ENDIF 130 CONTINUE VAR(2)=DRLENG ENDIF IF(LDIFF)CALL DLCDIF(VAR(3)) IF(LTOWN)CALL DLCTWN(VAR(4)) IF(LATTA)CALL DLCATT(VAR(5)) IF(LFIELD)THEN CALL EFIELD(XPOS,YPOS,ZPOS,EX,EY,EZ,VAR(6),VAR(7),1,ILOC) IF(MAGOK)CALL BFIELD(XPOS,YPOS,ZPOS,BX,BY,BZ,VAR(8)) ENDIF IF(LVELOC)THEN CALL DLCVEL(DBLE(XPOS),DBLE(YPOS),DBLE(ZPOS), - F0,-1.0,1,ILOC) VAR(9)=REAL(SQRT(F0(1)**2+F0(2)**2+F0(3)**2)) ENDIF IF(ISTAT.EQ.-1)THEN STATUS='Left_Area' NCSTAT=9 ELSEIF(ISTAT.EQ.-2)THEN STATUS='Too_Many_Steps' NCSTAT=14 ELSEIF(ISTAT.EQ.-3)THEN STATUS='Abandoned' NCSTAT=9 ELSEIF(ISTAT.EQ.-4)THEN STATUS='Hit_Plane' NCSTAT=9 ELSEIF(ISTAT.EQ.-5)THEN STATUS='Left_Drift_Medium' NCSTAT=17 ELSEIF(ISTAT.EQ.-6)THEN STATUS='Left_Mesh' NCSTAT=9 ELSEIF(ISTAT.GT.0.AND.ISTAT.LE.MXWIRE)THEN STATUS='Hit_'//WIRTYP(ISTAT)//'_Wire' NCSTAT=10 ELSEIF(ISTAT.GT.MXWIRE.AND.ISTAT.LE.2*MXWIRE)THEN STATUS='Hit_'//WIRTYP(ISTAT-MXWIRE)//'_Replica' NCSTAT=13 ELSE STATUS='Unknown' NCSTAT=7 ENDIF CALL STRBUF('STORE',IAUX,STATUS(1:NCSTAT),NCSTAT,IFAIL1) IF(IFAIL1.NE.0)PRINT *,' !!!!!! DRFMIN WARNING : Unable to'// - ' store the status code string; trouble in case you use it.' VAR(10)=IAUX MODVAR(1)=2 MODVAR(2)=2 MODVAR(3)=2 MODVAR(4)=2 MODVAR(5)=2 MODVAR(6)=2 MODVAR(7)=2 MODVAR(8)=2 MODVAR(9)=2 MODVAR(10)=1 * Debugging output. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DRFMIN DEBUG : From ('', - 3E15.8,'') Status = '',A,'' ('',I4,'') Time ='',E15.8, - ''.'')') XPOS,YPOS,ZPOS,STATUS(1:NCSTAT),ISTAT,TU(NU) * Evaluate the selection function, skip the rest if FALSE. NREXP=1 NVAR=10 CALL ALGEXE(IENSEL,VAR,MODVAR,NVAR,RES,MODRES,NREXP,IFAIL) IF(ABS(RES(1)).LT.1.0E-3)THEN PRINT *,' !!!!!! DRFMIN WARNING : Estimated parabolic'// - ' minimum does not satisfy selection criterion.' WRITE(12,'(/'' ! Minimisation halted: parabolic'', - '' minimum does not satisfy selection criterion.''/)') CALL STRBUF('DELETE',IAUX,STATUS,NCSTAT,IFAIL1) GOTO 3000 ENDIF * Evaluate the function to be minimised. NREXP=1 NVAR=9 CALL ALGEXE(IENMIN,VAR,MODVAR,NVAR,RES,MODRES,NREXP,IFAIL) IF(LDEBUG)WRITE(LUNOUT,'(26X,''Function value: '',E15.8)') RES(1) FTPARA=RES(1) * Get rid of the status string. CALL STRBUF('DELETE',IAUX,STATUS,NCSTAT,IFAIL1) * Dataset output. IF(LMINWR)WRITE(12,'('' Iteration '',I3,'' T='',E15.8, - '': ('',E15.8,'','',E15.8,'','',E15.8,'') Function = '', - E15.8,''.'')') I,TPARA,XPOS,YPOS,ZPOS,FTPARA * Normal printout. IF(LPRINT)WRITE(LUNOUT,'('' Iteration '',I3,'' T='',E15.8, - '': ('',E15.8,'','',E15.8,'','',E15.8,'') Function = '', - E15.8,''.'')') I,TPARA,XPOS,YPOS,ZPOS,FTPARA * Check convergence. IF(ABS(FTPARA-FT1).LT.EPST*(ABS(FTPARA)+ABS(FT1)+EPST))THEN IF(LMINWR)WRITE(12,'(/'' Minimisation converged.''/)') IF(LPRINT)WRITE(LUNOUT,'(/'' Minimisation converged.''/)') GOTO 3000 ENDIF * Store the value in the table. IF(FTPARA.LT.FT1)THEN FT3=FT2 T3=T2 FT2=FT1 T2=T1 FT1=FTPARA T1=TPARA ELSEIF(FTPARA.LT.FT2)THEN FT3=FT2 T3=T2 FT2=FTPARA T2=TPARA ELSEIF(FTPARA.LT.FT3)THEN FT3=FTPARA T3=TPARA ELSE IF(LMINWR)WRITE(12,'('' # Minimisation abandoned:'', - '' Estimated minimum is far from minimum found.'')') PRINT *,' !!!!!! DRFMIN WARNING : The estimated minimum'// - ' is too far from the minimum found sofar.' ENDIF 120 CONTINUE *** No convergence. PRINT *,' !!!!!! DRFMIN WARNING : No convergence after maximum'// - ' number of steps.' PRINT *,' Current minimum F=',FT1 PRINT *,' Found for T=',T1 IF(LMINWR)WRITE(12,'('' # Minimisation halted: maximum'', - '' number of iterations reached.''/'' Current minimum '', - '' at T='',E15.8,'', function= '',E15.8)') T1,FT1 *** Clean up. 3000 CONTINUE * Close the dataset if open. IF(LMINWR)CLOSE(12,ERR=2030,IOSTAT=IOS) * Display number of algebra errors. CALL ALGERR * Kill algebra entry points. CALL ALGCLR(IENTRA) CALL ALGCLR(IENMIN) CALL ALGCLR(IENSEL) RETURN * Errors while writing the dataset. 2010 CONTINUE PRINT *,' ###### DRFMIN ERROR : Error error while writing'// - ' to ',FILE(1:NCFILE),' via unit 12.' CALL INPIOS(IOS) CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) RETURN * Errors while closing the dataset. 2030 CONTINUE PRINT *,' ###### DRFMIN ERROR : Dataset '//FILE(1:NCFILE)// - ' unit 12 cannot be closed ; results not predictable' CALL INPIOS(IOS) END +DECK,DRFTIM. SUBROUTINE DRFTIM *----------------------------------------------------------------------- * DRFTIM - Computes the arrival time distribution of some selected * electrons from random tracks. * VARIABLES : * (Last changed on 1/ 2/99.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,GASDATA. +SEQ,DRIFTLINE. +SEQ,PARAMETERS. +SEQ,PRINTPLOT. +SEQ,CONSTANTS. INTEGER MXELEC PARAMETER(MXELEC=10) *** Declarations, start setting the max number of histogram channels. CHARACTER*(MXCHAR) FCNWGT CHARACTER*80 TITLE CHARACTER*15 STR1,STR2,STR3 CHARACTER*10 VARLIS(MXVAR) REAL ARRTIM(1,MXPART),VAR(MXVAR),ANGMIN,ANGMAX,ANGMIR,ANGMAR, - XARMIN,XARMAX,YARMIN,YARMAX,XARMIR,XARMAR,YARMIR,YARMAR, - TFORC1,TFORC2,RES(1),XRNDM,ARNDM,RMAX,WEIGHT,XCL,YCL,ZCL, - ECL,BCL,SCL,TCL,RNDM,RNDNOR INTEGER IRFTEL(MXELEC),IRFTGL,MELEC(MXELEC),MODVAR(MXVAR), - JSEL,JALL,IPAIR,NPAIR,NPART,NGLOB,NC1,NC2,NC3,NC,MR,NRES, - IRNDM,NRNDM,NRNDMR,NCHA,NCHAR,KELEC,NCWGT,I,J,IFAIL1,IFAIL2, - MODRES(1),IENWGT,IW,ISWCNT,INEXT,NWORD,NVAR,NREXP,IPRT, - INPTYP,INPCMP LOGICAL FLAG(MXWORD+3),LGLBPL,LELEPL,USE(MXVAR),LATTA, - LGLBPR,LELEPR,WFORCE,LKEEP,LDRMC,DONE,OK EXTERNAL RNDM,RNDNOR,DIVDIF,INPCMP,INPTYP +SELF,IF=SAVE. SAVE NRNDM,NCHA,KELEC,MELEC,LGLBPL,LELEPL,LDRMC,LATTA, - LGLBPR,LELEPR,ANGMIN,ANGMAX,VARLIS +SELF. *** Initialise those variables that are kept across calls. DATA NRNDM /1000/, NCHA /100/ DATA KELEC /1/, MELEC /MXELEC*5/ DATA LGLBPL /.TRUE./, LELEPL /.TRUE./ DATA LGLBPR /.FALSE./, LELEPR /.FALSE./ DATA LKEEP /.FALSE./ DATA LATTA /.FALSE./, LDRMC /.FALSE./ DATA (VARLIS(I),I=1,2) /'X ','ANGLE '/ *** Check the presence of sufficient gas data. IF(.NOT.(GASOK(1).AND.GASOK(3).AND.(GASOK(5).OR.HEEDOK)))THEN PRINT *,' ###### DRFTIM ERROR : Insufficient gas data'// - ' to perform the calculations.' PRINT *,' Required are velocity,'// - ' diffusion and cluster data.' RETURN ENDIF *** Make sure the cell is not in polar coordinates. IF(POLAR)THEN PRINT *,' ###### DRFTIM ERROR : The TIMING function'// - ' can not be applied to polar geometries.' RETURN ENDIF *** Initialise various variables being reset at each call. XARMIN=DXMIN XARMAX=DXMAX YARMIN=DYMIN YARMAX=DYMAX ANGMIN=0 ANGMAX=0 WFORCE=.FALSE. TFORC1=-1.0 TFORC2=-1.0 JSEL=0 JALL=0 FCNWGT='1' NCWGT=1 *** Examine the input line, flag the known words. CALL INPNUM(NWORD) DO 10 I=2,NWORD IF(INPCMP(I,'X-R#ANGE')+INPCMP(I,'WEIGHT#ING-#FUNCTION')+ - INPCMP(I,'Y-R#ANGE')+INPCMP(I,'T#IME-WIN#DOW')+ - INPCMP(I,'BIN#S')+INPCMP(I,'ANG#LE-#RANGE')+ - INPCMP(I,'ATT#ACHMENT')+INPCMP(I,'NOATT#ACHMENT')+ - INPCMP(I,'EL#ECTRONS')+INPCMP(I,'ITER#ATIONS')+ - INPCMP(I,'ITER#ATE')+ - INPCMP(I,'M#ONTE-C#ARLO-DR#IFT')+ - INPCMP(I,'NOM#ONTE-C#ARLO-DR#IFT')+ - INPCMP(I,'PL#OT-O#VERALL')+INPCMP(I,'NOPL#OT-O#VERALL')+ - INPCMP(I,'PL#OT-SEL#ECTED-#ELECTRONS')+ - INPCMP(I,'NOPL#OT-SEL#ECTED-#ELECTRONS')+ - INPCMP(I,'PR#INT-O#VERALL')+INPCMP(I,'NOPR#INT-O#VERALL')+ - INPCMP(I,'PR#INT-SEL#ECTED-#ELECTRONS')+ - INPCMP(I,'NOPR#INT-SEL#ECTED-#ELECTRONS')+ - INPCMP(I,'KEEP-#HISTOGRAMS')+INPCMP(I,'NOKEEP-#HISTOGRAMS')+ - INPCMP(I,'SIN#GLE-CL#USTER')+ - INPCMP(I,'NOSIN#GLE-CL#USTER').NE.0)THEN FLAG(I)=.TRUE. ELSE FLAG(I)=.FALSE. ENDIF 10 CONTINUE FLAG(NWORD+1)=.TRUE. FLAG(NWORD+2)=.TRUE. FLAG(NWORD+3)=.TRUE. INEXT=2 ** Read in detail. OK=.TRUE. DO 20 I=2,NWORD IF(I.LT.INEXT)GOTO 20 * Read the angle range. IF(INPCMP(I,'ANG#LE-#RANGE').NE.0)THEN IF(FLAG(I+1))THEN CALL INPMSG(I,'Should have two arguments. ') OK=.FALSE. ELSEIF(FLAG(I+2))THEN CALL INPCHK(I+1,2,IFAIL1) IF(IFAIL1.NE.0)OK=.FALSE. CALL INPRDR(I+1,ANGMIR,180*ANGMIN/PI) IF(IFAIL1.EQ.0.AND. - (ANGMIR.LT.-90.OR.ANGMIR.GT.+90))THEN CALL INPMSG(I+1,'Not within the range [-90,90].') OK=.FALSE. ELSEIF(ANGMIR.GE.-90.AND.ANGMIR.LE.+90.AND. - IFAIL1.EQ.0)THEN ANGMIN=PI*ANGMIR/180 ANGMAX=PI*ANGMIR/180 ENDIF INEXT=I+3 ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPCHK(I+2,2,IFAIL2) CALL INPRDR(I+1,ANGMIR,180*ANGMIN/PI) IF(IFAIL1.NE.0.OR.IFAIL2.NE.0)OK=.FALSE. IF(IFAIL1.EQ.0.AND. - (ANGMIR.LT.-90.OR.ANGMIR.GT.+90))THEN CALL INPMSG(I+1,'Not within the range [-90,90].') OK=.FALSE. ENDIF CALL INPRDR(I+2,ANGMAR,180*ANGMAX/PI) IF(IFAIL2.EQ.0.AND. - (ANGMAR.LT.-90.OR.ANGMAR.GT.+90))THEN CALL INPMSG(I+2,'Not within the range [-90,90].') OK=.FALSE. ELSEIF(ANGMIR.GE.-90.AND.ANGMIR.LE.+90.AND. - ANGMAR.GE.-90.AND.ANGMAR.LE.+90.AND. - IFAIL1.EQ.0.AND.IFAIL2.EQ.0)THEN ANGMIN=PI*MIN(ANGMIR,ANGMAR)/180 ANGMAX=PI*MAX(ANGMIR,ANGMAR)/180 ENDIF INEXT=I+3 ENDIF * Explicit time scale. ELSEIF(INPCMP(I,'T#IME-WIN#DOW').NE.0)THEN IF(I+2.GT.NWORD.OR.FLAG(I+1).OR.FLAG(I+2))THEN CALL INPMSG(I,'This keyword has 2 arguments. ') OK=.FALSE. ELSEIF(INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2)THEN CALL INPMSG(I+1,'This should be a real argument') OK=.FALSE. ELSEIF(INPTYP(I+2).NE.1.AND.INPTYP(I+2).NE.2)THEN CALL INPMSG(I+2,'This should be a real argument') OK=.FALSE. ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPCHK(I+2,2,IFAIL2) CALL INPRDR(I+1,TFORC1,-1.0) CALL INPRDR(I+2,TFORC2,-1.0) IF(IFAIL1.NE.0.OR.IFAIL2.NE.0.OR. - TFORC1.LT.0.0.OR.TFORC2.LT.0.0.OR. - TFORC1.EQ.TFORC2)THEN CALL INPMSG(I+1,'Window incorrectly specified. ') CALL INPMSG(I+2,'(See preceding message.) ') OK=.FALSE. ELSE WFORCE=.TRUE. ENDIF ENDIF INEXT=I+3 * The BINS keyword. ELSEIF(INPCMP(I,'BIN#S').NE.0)THEN IF(I+1.GT.NWORD.OR.FLAG(I+1))THEN CALL INPMSG(I,'This keyword has one argument.') OK=.FALSE. ELSEIF(INPTYP(I+1).NE.1)THEN CALL INPMSG(I+1,'This is an integer argument. ') OK=.FALSE. ELSE CALL INPCHK(I+1,1,IFAIL1) CALL INPRDI(I+1,NCHAR,MXCHA) IF(NCHAR.LE.1.OR.NCHAR.GT.MXCHA)THEN CALL INPMSG(I+1,'Inacceptable number of bins. ') OK=.FALSE. ELSE NCHA=NCHAR ENDIF ENDIF INEXT=I+2 * Histogram keeping option. ELSEIF(INPCMP(I,'KEEP-#HISTOGRAMS').NE.0)THEN LKEEP=.TRUE. ELSEIF(INPCMP(I,'NOKEEP-#HISTOGRAMS').NE.0)THEN LKEEP=.FALSE. * Read the first and last particle to be considered. ELSEIF(INPCMP(I,'EL#ECTRONS').NE.0)THEN KELEC=0 DO 21 J=I+1,NWORD IF(FLAG(J))THEN GOTO 22 ELSEIF(KELEC.GE.MXELEC)THEN CALL INPMSG(J,'No room to store this electron') OK=.FALSE. GOTO 21 ELSE KELEC=KELEC+1 ENDIF IF(INPCMP(J,'L#AST').NE.0)THEN MELEC(KELEC)=0 INEXT=J+1 ELSEIF(INPCMP(J,'ONE-B#UT-#LAST').NE.0)THEN MELEC(KELEC)=-1 INEXT=J+1 ELSEIF(INPCMP(J,'TW#O-B#UT-#LAST').NE.0)THEN MELEC(KELEC)=-2 INEXT=J+1 ELSEIF(INPCMP(J,'TH#REE-B#UT-#LAST').NE.0)THEN MELEC(KELEC)=-3 INEXT=J+1 ELSEIF(INPTYP(J).NE.1)THEN CALL INPMSG(J,'This argument is an integer. ') OK=.FALSE. INEXT=J KELEC=KELEC-1 ELSE CALL INPCHK(J,1,IFAIL1) CALL INPRDI(J,MR,5) IF(MR.LT.1-MXPART.AND.IFAIL1.EQ.0)THEN CALL INPMSG(J,'Smaller than 1-MXPART. ') OK=.FALSE. KELEC=KELEC-1 ELSEIF(MR.GT.MXPART.AND.IFAIL1.EQ.0)THEN CALL INPMSG(J,'Larger than MXPART. ') OK=.FALSE. KELEC=KELEC-1 ELSEIF(IFAIL1.EQ.0)THEN MELEC(KELEC)=MR ENDIF INEXT=J+1 ENDIF 21 CONTINUE 22 CONTINUE IF(KELEC.LE.0)THEN CALL INPMSG(I,'Should have an argument. ') OK=.FALSE. KELEC=1 MELEC(1)=5 ENDIF * The ITERATIONS keyword. ELSEIF(INPCMP(I,'ITER#ATIONS')+INPCMP(I,'ITER#ATE').NE.0)THEN IF(I+1.GT.NWORD)THEN CALL INPMSG(I,'This keyword has one argument.') OK=.FALSE. ELSEIF(INPTYP(I+1).NE.1)THEN CALL INPMSG(I,'This is an integer argument. ') OK=.FALSE. ELSE CALL INPCHK(I+1,1,IFAIL1) CALL INPRDI(I+1,NRNDMR,NRNDM) IF(NRNDMR.LT.1)THEN CALL INPMSG(I+1,'At least 1 iteration needed. ') OK=.FALSE. ELSE NRNDM=NRNDMR ENDIF ENDIF INEXT=I+2 * Monte Carlo drifting. ELSEIF(INPCMP(I,'M#ONTE-C#ARLO-DR#IFT-#LINES')+ - INPCMP(I,'MC-DR#IFT-#LINES').NE.0)THEN LDRMC=.TRUE. ELSEIF(INPCMP(I,'NOM#ONTE-C#ARLO-DR#IFT-#LINES')+ - INPCMP(I,'NOMC-DR#IFT-#LINES')+ - INPCMP(I,'RUN#GE-K#UTTA-DR#IFT-#LINES').NE.0)THEN LDRMC=.FALSE. * Take attachment into account. ELSEIF(INPCMP(I,'ATT#ACHMENT').NE.0)THEN LATTA=.TRUE. ELSEIF(INPCMP(I,'NOATT#ACHMENT').NE.0)THEN LATTA=.FALSE. * Plot options. ELSEIF(INPCMP(I,'PL#OT-O#VERALL').NE.0)THEN LGLBPL=.TRUE. ELSEIF(INPCMP(I,'NOPL#OT-O#VERALL').NE.0)THEN LGLBPL=.FALSE. ELSEIF(INPCMP(I,'PL#OT-SEL#ECTED-#ELECTRON').NE.0)THEN LELEPL=.TRUE. ELSEIF(INPCMP(I,'NOPL#OT-SEL#ECTED-#ELECTRON').NE.0)THEN LELEPL=.FALSE. * Print options. ELSEIF(INPCMP(I,'PR#INT-O#VERALL').NE.0)THEN LGLBPR=.TRUE. ELSEIF(INPCMP(I,'NOPR#INT-O#VERALL').NE.0)THEN LGLBPR=.FALSE. ELSEIF(INPCMP(I,'PR#INT-SEL#ECTED-#ELECTRON').NE.0)THEN LELEPR=.TRUE. ELSEIF(INPCMP(I,'NOPR#INT-SEL#ECTED-#ELECTRON').NE.0)THEN LELEPR=.FALSE. * Find the x-coordinate range on which this routine will work. ELSEIF(INPCMP(I,'X-R#ANGE').NE.0)THEN IF(FLAG(I+1).OR.FLAG(I+2))THEN CALL INPMSG(I,'Should have two arguments. ') OK=.FALSE. ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPCHK(I+2,2,IFAIL2) CALL INPRDR(I+1,XARMIR,DXMIN) CALL INPRDR(I+2,XARMAR,DXMAX) IF(XARMIR.EQ.XARMAR)THEN CALL INPMSG(I+1,'Zero range not permitted. ') CALL INPMSG(I+2,'See preceding message. ') OK=.FALSE. ELSEIF(MIN(XARMIR,XARMAR).LT.DXMIN.OR. - MAX(XARMIR,XARMAR).GT.DXMAX)THEN CALL INPMSG(I+1,'x-Range not inside the area. ') CALL INPMSG(I+2,'See preceding message. ') OK=.FALSE. ELSE XARMIN=MAX(DXMIN,MIN(XARMIR,XARMAR)) XARMAX=MIN(DXMAX,MAX(XARMIR,XARMAR)) ENDIF INEXT=I+3 ENDIF * Find the y-coordinate range on which this routine will work. ELSEIF(INPCMP(I,'Y-R#ANGE').NE.0)THEN IF(FLAG(I+1).OR.FLAG(I+2))THEN CALL INPMSG(I,'Should have two arguments. ') OK=.FALSE. ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPCHK(I+2,2,IFAIL2) CALL INPRDR(I+1,YARMIR,DYMIN) CALL INPRDR(I+2,YARMAR,DYMAX) IF(YARMIR.EQ.YARMAR)THEN CALL INPMSG(I+1,'Zero range not permitted. ') CALL INPMSG(I+2,'See preceding message. ') OK=.FALSE. ELSEIF(MIN(YARMIR,YARMAR).LT.DYMIN.OR. - MAX(YARMIR,YARMAR).GT.DYMAX)THEN CALL INPMSG(I+1,'y-Range not inside the area. ') CALL INPMSG(I+2,'See preceding message. ') OK=.FALSE. ELSE YARMIN=MAX(DYMIN,MIN(YARMIR,YARMAR)) YARMAX=MIN(DYMAX,MAX(YARMIR,YARMAR)) ENDIF INEXT=I+3 ENDIF * Weighting function. ELSEIF(INPCMP(I,'WEIGHT#ING-#FUNCTION').NE.0)THEN IF(FLAG(I+1))THEN CALL INPMSG(I,'Should have one argument. ') OK=.FALSE. ELSE CALL INPSTR(I+1,I+1,FCNWGT,NCWGT) ENDIF * The option is not known to the program. ELSE CALL INPMSG(I,'The option is not known. ') OK=.FALSE. ENDIF 20 CONTINUE * Display error messages. CALL INPERR ** Print some debugging output, to check correct input handling. IF(LDEBUG)THEN WRITE(LUNOUT,'('' ++++++ DRFTIM DEBUG :'', - '' x-range=('',E12.5,'','',E12.5,''),''/25X, - '' y-range=('',E12.5,'','',E12.5,''),''/25X, - '' angles =('',E12.5,'','',E12.5,''),''/25X, - '' weight = '',A/25X, - '' MC drift = '',L1,'', attachment '',L1/25X, - '' iterations='',I5,'', bins='',I3)') - XARMIN,XARMAX,YARMIN,YARMAX,ANGMIN,ANGMAX, - FCNWGT(1:NCWGT),LDRMC,LATTA,NRNDM,NCHA WRITE(LUNOUT,'(26X,''Selected electrons: '',100(I3:))') - (MELEC(I),I=1,KELEC) ENDIF *** Quit now if OK is no longer true and if JFAIL is set. IF(JFAIL.EQ.2.AND..NOT.OK)THEN PRINT *,' ###### DRFTIM ERROR : Instruction is not'// - ' carried out because of the above errors.' RETURN ELSEIF(JFAIL.EQ.3.AND..NOT.OK)THEN PRINT *,' ###### DRFTIM ERROR : Program terminated'// - ' because of the above errors.' CALL QUIT ENDIF *** Translate the weighting function. CALL ALGPRE(FCNWGT,NCWGT,VARLIS,2,NRES,USE,IENWGT,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! DRFTIM WARNING : Unable to translate'// - ' the weighting function ; no timing histograms.' RETURN ELSEIF(NRES.NE.1)THEN PRINT *,' !!!!!! DRFTIM WARNING : Timing histogram does'// - ' not return 1 result ; no timing histograms.' RETURN ENDIF *** Initialise progress printing. CALL PROINT('TIMING',2,6) *** Loop over the selected, attracting wires inside the AREA. CALL PROFLD(1,'Wires',REAL(NSW)) ISWCNT=0 DO 100 IW=1,NWIRE * Check sense wire status. IF(INDSW(IW).NE.0)ISWCNT=ISWCNT+1 CALL PROSTA(1,REAL(ISWCNT)) IF(INDSW(IW).EQ.0.OR.X(IW).LT.DXMIN.OR.X(IW).GT.DXMAX.OR. - Y(IW).LT.DYMIN.OR.Y(IW).GT.DYMAX.OR.E(IW).LT.0.0)GOTO 100 IF(LDEBUG)PRINT *,' ++++++ DRFTIM DEBUG : Wire ',IW,' selected' * Inform what is going on. CALL PROFLD(2,'Histogram allocation',-1.0) CALL PROSTA(2,0.0) *** Open a plot frame of DRIFT-PLOT is on. IF(LDRPLT)THEN CALL GRAXIS(DXMIN,DYMIN,DXMAX,DYMAX, - 'DRIFT LINES FOR THE TIMING PLOT') CALL CELLAY(DXMIN,DYMIN,DXMAX,DYMAX) IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) IF(GASID.NE.' ')CALL GRCOMM(2,'Gas: '//GASID) ENDIF * Allocate histogram storage and reset the various counters. IF(WFORCE)THEN CALL HISADM('ALLOCATE',IRFTGL,NCHA, - TFORC1,TFORC2,.FALSE.,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' ###### DRFTIM ERROR : Unable to obtain'// - ' histogram space (all, t) ; end of calculations.' RETURN ENDIF DO 112 I=1,KELEC CALL HISADM('ALLOCATE',IRFTEL(I),NCHA, - TFORC1,TFORC2,.FALSE.,IFAIL2) IF(IFAIL2.NE.0)THEN PRINT *,' ###### DRFTIM ERROR : Unable to obtain'// - ' histogram space (sel, t) ; end of calculations.' RETURN ENDIF 112 CONTINUE ELSE CALL HISADM('ALLOCATE',IRFTGL,NCHA, - 0.0,1.0,.TRUE.,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' ###### DRFTIM ERROR : Unable to obtain'// - ' histogram space (all, t) ; end of calculations.' RETURN ENDIF DO 113 I=1,KELEC CALL HISADM('ALLOCATE',IRFTEL(I),NCHA, - 0.0,1.0,.TRUE.,IFAIL2) IF(IFAIL2.NE.0)THEN PRINT *,' ###### DRFTIM ERROR : Unable to obtain'// - ' histogram space (sel, t) ; end of calculations.' RETURN ENDIF 113 CONTINUE ENDIF *** Initialise counter of all electrons. NGLOB=0 * Carry out NRNDM global random cycles, resetting the counters. CALL PROFLD(2,'Tracks',REAL(NRNDM)) CALL PROSTA(2,0.0) IF(NRNDM.LE.10)THEN IPRT=1 ELSE IPRT=10**(INT(LOG10(REAL(2*NRNDM)))-1) ENDIF *** Start of MC loop. DO 140 IRNDM=1,NRNDM IF(IRNDM.EQ.IPRT*(IRNDM/IPRT))CALL PROSTA(2,REAL(IRNDM)) *** Draw a track location. XRNDM=XARMIN+RNDM(+IRNDM)*(XARMAX-XARMIN) ARNDM=ANGMIN+RNDM(-IRNDM)*(ANGMAX-ANGMIN) RMAX=ABS(DXMAX-DXMIN)+ABS(DYMAX-DYMIN) XT0=XRNDM-RMAX*SIN(ARNDM) YT0=Y(IW)-RMAX*COS(ARNDM) ZT0=0 XT1=XRNDM+RMAX*SIN(ARNDM) YT1=Y(IW)+RMAX*COS(ARNDM) ZT1=0 TRFLAG(1)=.TRUE. * Compute weight for this track. VAR(1)=XRNDM VAR(2)=180*ARNDM/PI MODVAR(1)=2 MODVAR(2)=2 NVAR=2 NREXP=1 CALL ALGEXE(IENWGT,VAR,MODVAR,NVAR,RES,MODRES,NREXP,IFAIL1) IF(IFAIL1.NE.0.OR.MODRES(1).NE.2)THEN WRITE(LUNOUT,'('' ++++++ DRFTIM DEBUG : Weight not'', - '' used, mode='',I1,'' IFAIL='',I2)') - MODRES(1),IFAIL1 WEIGHT=1 ELSE WEIGHT=RES(1) ENDIF * Clip the track to make sure it fits in the AREA. CALL CLIP(XT0,YT0,XT1,YT1,DXMIN,MAX(DYMIN,YARMIN), - DXMAX,MIN(DYMAX,YARMAX),IFAIL1) IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DRFTIM DEBUG : Track: '', - ''('',E15.8,'','',E15.8,'') to ('',E15.8,'','',E15.8, - '').'')') XT0,YT0,XT1,YT1 * Be sure that at least part of the track is located inside the area. IF(IFAIL1.NE.0)THEN IF(LDEBUG)PRINT *,' ++++++ DRFTIM DEBUG : Track not'// - ' in area or zero length; no further computations.' GOTO 140 ENDIF *** Start clustering on this track. CALL TRACLI * Reset number of electrons accumulated. NPART=0 *** Get a new cluster. 150 CONTINUE CALL TRACLS(XCL,YCL,ZCL,ECL,NPAIR,DONE,IFAIL1) * Check whether there was a mistake. IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! DRFTIM WARNING : Clustering error;'// - ' no histograms.' CALL HISADM('DELETE',IRFTGL,0,0.0,0.0,.TRUE.,IFAIL1) DO 155 I=1,KELEC CALL HISADM('DELETE',IRFTEL(I),0,0.0,0.0,.TRUE.,IFAIL1) 155 CONTINUE IF(LDRPLT)THEN CALL TRAPLT CALL GRALOG('Aborted drift lines for TIMING plot:') CALL GRNEXT ENDIF RETURN * Check whether this was beyond the last cluster. ELSEIF(DONE)THEN GOTO 170 ENDIF *** Monte Carlo variant. IF(LDRMC)THEN * Loop over the pairs in the cluster. DO 200 IPAIR=1,NPAIR * Compute the drift line. CALL DLCMC(XCL,YCL,ZCL,-1.0,1) * Make sure it ends on the wire. IF(ISTAT.NE.IW.OR.NU.LT.2)GOTO 200 * See whether it was lost by attachment. IF(GASOK(6).AND.LATTA)THEN CALL DLCATT(BCL) IF(BCL.LT.RNDM(I))GOTO 200 ENDIF * Add the time to the table. IF(NPART.GE.MXPART)THEN PRINT *,' !!!!!! DRFTIM WARNING : Too many'// - ' electrons on the track; increase MXPART.' GOTO 140 ENDIF NPART=NPART+1 ARRTIM(1,NPART)=REAL(TU(NU)) * And to the overall timing histogram. CALL HISENT(IRFTGL,ARRTIM(1,NPART),WEIGHT) * Keep track of number of entries. NGLOB=NGLOB+1 * Plot the drift line if required. IF(NU.GT.2.AND.LDRPLT)THEN IF(POLAR)CALL CF2RTC(XU,YU,XU,YU,NU) CALL GRATTS('E-DRIFT-LINE','POLYLINE') CALL GPL2(NU,XU,YU) ENDIF 200 CONTINUE *** Analytic variant. ELSE CALL DLCALC(XCL,YCL,ZCL,-1.0,1) * Make sure it ends on the wire. IF(ISTAT.NE.IW.OR.NU.LT.2)GOTO 150 * Adjust number of pairs for attachment. IF(GASOK(6).AND.LATTA)THEN CALL DLCATT(BCL) NPAIR=BCL*NPAIR ENDIF * Compute diffusion and store time. TCL=REAL(TU(NU)) CALL DLCDIF(SCL) * And generate the correponding number of arrival times. DO 160 IPAIR=1,NPAIR IF(NPART.GE.MXPART)THEN PRINT *,' !!!!!! DRFTIM WARNING : Too many'// - ' electrons on the track; increase MXPART.' GOTO 140 ENDIF NPART=NPART+1 ARRTIM(1,NPART)=RNDNOR(TCL,SCL) * And to the overall timing histogram. CALL HISENT(IRFTGL,ARRTIM(1,NPART),WEIGHT) * Keep track of number of entries. NGLOB=NGLOB+1 160 CONTINUE * Plot the drift line if required. IF(NU.GT.2.AND.LDRPLT)THEN IF(POLAR)CALL CF2RTC(XU,YU,XU,YU,NU) CALL GRATTS('E-DRIFT-LINE','POLYLINE') CALL GPL2(NU,XU,YU) ENDIF ENDIF * Next cluster. GOTO 150 *** All clusters done. 170 CONTINUE IF(LDRPLT)CALL TRAPLT *** Find the M'th particle to arrive and enter in a histogram. IF(NPART.GE.1)THEN CALL SORTRQ(ARRTIM,1,NPART,1) DO 180 I=1,KELEC IF(MELEC(I).GT.0.AND.MELEC(I).LE.NPART.AND.NPART.GT.0)THEN CALL HISENT(IRFTEL(I),ARRTIM(1,MELEC(I)),WEIGHT) ELSEIF(MELEC(I).LE.0.AND.MELEC(I)+NPART.GE.1)THEN CALL HISENT(IRFTEL(I),ARRTIM(1,NPART+MELEC(I)),WEIGHT) ENDIF 180 CONTINUE ENDIF *** Proceed with the next random cycle. 140 CONTINUE *** Check we did indeed collect something. IF(NGLOB.LE.0)THEN CALL HISADM('DELETE',IRFTGL,0,0.0,0.0,.TRUE.,IFAIL1) DO 210 I=1,KELEC CALL HISADM('DELETE',IRFTEL(I),0,0.0,0.0,.TRUE.,IFAIL1) 210 CONTINUE IF(LKEEP)PRINT *,' !!!!!! DRFTIM WARNING : Histograms'// - ' not kept - no entries.' GOTO 100 ENDIF *** Close the plot, if open. IF(LDRPLT)THEN CALL GRALOG('Drift lines for a timing plot:') CALL GRNEXT ENDIF *** Plot the curves. IF(LELEPL)THEN * Inform about progress. CALL PROFLD(2,'Plot selected e-',-1.0) CALL PROSTA(2,0.0) * Plot each of the electrons. DO 190 I=1,KELEC CALL OUTFMT(REAL(MELEC(I)),2,STR1,NC1,'LEFT') CALL OUTFMT(REAL(IW),2,STR2,NC2,'LEFT') IF(MELEC(I).GT.0)THEN TITLE='Arrival time of electron '//STR1(1:NC1)// - ' on wire '//STR2(1:NC2) NC=34+NC1+NC2 ELSEIF(MELEC(I).EQ.0)THEN TITLE='Arrival time last electron'// - ' on wire '//STR2(1:NC2) NC=35+NC2 ELSE TITLE='Arrival time last'//STR1(1:NC1)//' electron'// - ' on wire '//STR2(1:NC2) NC=35+NC1+NC2 ENDIF CALL HISPLT(IRFTEL(I),'Arrival time [microsec]', - TITLE(1:NC),.TRUE.) IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) IF(GASID.NE.' ')CALL GRCOMM(2,'Gas: '//GASID) CALL GRNEXT CALL GRALOG(TITLE(1:NC)) 190 CONTINUE ENDIF IF(LELEPR)THEN * Inform about progress. CALL PROFLD(2,'Print selected e-',-1.0) CALL PROSTA(2,0.0) * Print each of the electrons. DO 144 I=1,KELEC CALL OUTFMT(REAL(MELEC(I)),2,STR1,NC1,'LEFT') CALL OUTFMT(REAL(IW),2,STR2,NC2,'LEFT') IF(MELEC(I).GT.0)THEN TITLE='Arrival time of electron '//STR1(1:NC1)// - ' on wire '//STR2(1:NC2) NC=34+NC1+NC2 ELSEIF(MELEC(I).EQ.0)THEN TITLE='Arrival time last electron'// - ' on wire '//STR2(1:NC2) NC=35+NC2 ELSE TITLE='Arrival time last'//STR1(1:NC1)//' electron'// - ' on wire '//STR2(1:NC2) NC=35+NC1+NC2 ENDIF CALL HISPRT(IRFTEL(I),'Arrival time [microsec]',TITLE(1:NC)) 144 CONTINUE ENDIF * Global plot. IF(LGLBPL)THEN * Inform about progress. CALL PROFLD(2,'Plot all e-',-1.0) CALL PROSTA(2,0.0) * Global plot. CALL OUTFMT(REAL(IW),2,STR2,NC2,'LEFT') CALL HISPLT(IRFTGL,'Arrival time [microsec]', - 'Arrival time of all electrons on wire '// - STR2(1:NC2),.TRUE.) IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) IF(GASID.NE.' ')CALL GRCOMM(2,'Gas: '//GASID) CALL GRALOG('Overall arrival time distribution. ') CALL GRNEXT ENDIF IF(LGLBPR)THEN * Inform about progress. CALL PROFLD(2,'Print all e-',-1.0) CALL PROSTA(2,0.0) * Global printout. CALL OUTFMT(REAL(IW),2,STR2,NC2,'LEFT') CALL HISPRT(IRFTGL,'Arrival time [microsec]', - 'Arrival time of all electrons on wire '// - STR2(1:NC2)) ENDIF *** Get rid of the histograms, unless KEEP has been specified. IF(LKEEP)THEN * Inform about progress. CALL PROFLD(2,'Saving histograms',-1.0) CALL PROSTA(2,0.0) * Find names for the histograms and save them. JALL=JALL+1 CALL OUTFMT(REAL(JALL),2,STR1,NC1,'LEFT') CALL HISSAV(IRFTGL,'ALL_'//STR1(1:NC1),IFAIL1) CALL OUTFMT(REAL(IW),2,STR2,NC2,'LEFT') IF(IFAIL1.EQ.0)THEN PRINT *,' ------ DRFTIM MESSAGE : Arrival time'// - ' histogram of all electrons for wire '// - STR2(1:NC2)//' is kept as ALL_'// - STR1(1:NC1)//'.' ELSE PRINT *,' !!!!!! DRFTIM WARNING : Arrival time'// - ' histogram of all electrons for wire '// - STR2(1:NC2)//' has not been saved.' CALL HISADM('DELETE',IRFTGL,0,0.0,0.0,.TRUE.,IFAIL1) ENDIF DO 401 I=1,KELEC JSEL=JSEL+1 CALL OUTFMT(REAL(JSEL),2,STR1,NC1,'LEFT') CALL HISSAV(IRFTEL(I),'SEL_'//STR1(1:NC1),IFAIL1) CALL OUTFMT(REAL(MELEC(I)),2,STR2,NC2,'LEFT') CALL OUTFMT(REAL(IW),2,STR3,NC3,'LEFT') IF(IFAIL1.EQ.0)THEN PRINT *,' ------ DRFTIM MESSAGE : Arrival time'// - ' histogram of electron '//STR2(1:NC2)// - ' for wire '//STR3(1:NC3)//' is kept as SEL_'// - STR1(1:NC1)//'.' ELSE PRINT *,' !!!!!! DRFTIM WARNING : Arrival time'// - ' histogram of electron '//STR2(1:NC2)// - ' for wire '//STR3(1:NC3)//' has not been saved.' CALL HISADM('DELETE',IRFTEL(I),0,0.0,0.0,.TRUE.,IFAIL1) ENDIF 401 CONTINUE ELSE CALL HISADM('DELETE',IRFTGL,0,0.0,0.0,.TRUE.,IFAIL1) DO 403 I=1,KELEC CALL HISADM('DELETE',IRFTEL(I),0,0.0,0.0,.TRUE.,IFAIL1) 403 CONTINUE ENDIF *** Proceed with the next wire. 100 CONTINUE *** End of progress printing. CALL PROEND *** Register the amount of CPU time used by this routine. CALL TIMLOG('Calculating arrival times: ') END +DECK,DRFTRA. SUBROUTINE DRFTRA(Q,ITYPE,TSTEP,LDRMC,LEQTPL,LEQREV, - LLINPL,LLINPR, - LTIMPL,LVELPL,LDIFPL,LAVAPL,LFUNPL,FUNCT,NCF,MARKER) *----------------------------------------------------------------------- * DRFTRA - Subroutine calculating and plotting drift lines given an * electric field, it optionally plots some isochronous lines * and graphs of the drift-time, velocity, diffusion and the * Townsend coefficient. Calculation starts from the track. * VARIABLES : ISTVEC : Vector of status codes. * TIMVEC : Vector of drift times. * VELVEC : Vector of the average drift velocity. * DIFVEC : Vector of the integrated diffusion. * AVAVEC : Vector of multiplication factor. * DRLENG : The length of the current drift line. * logicals : inherited from DRFDRF, see there. * (Last changed on 16/ 3/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PARAMETERS. +SEQ,CELLDATA. +SEQ,SOLIDS. +SEQ,GASDATA. +SEQ,CONSTANTS. +SEQ,PRINTPLOT. +SEQ,DRIFTLINE. DOUBLE PRECISION TRANSF,DRLENG,XAUX1,XAUX2,YAUX1,YAUX2 CHARACTER*133 STRING CHARACTER*80 FUNCT,STASTR CHARACTER*30 AUXSTR CHARACTER*10 VARLIS(MXVAR) LOGICAL LEQTPL,LLINPL,LLINPR,LTIMPL,LVELPL,LDIFPL,LAVAPL,LFUNPL, - MARKER,USE(MXVAR),DONE,LDRMC,LEQREV REAL TIMVEC(MXLIST),VELVEC(MXLIST),VAR(MXVAR), - DIFVEC(MXLIST),FUNVEC(MXLIST),AVAVEC(MXLIST),ATTVEC(MXLIST), - POSVEC(MXLIST), - RES(1),XSTART,YSTART,ZSTART,ESTART,XT0P,YT0P,XT1P,YT1P, - TSTEP,Q,XR0,YR0,XR1,YR1,VXMIN,VYMIN,VXMAX,VYMAX, - XT0AUX,YT0AUX,ZT0AUX,XT1AUX,YT1AUX,ZT1AUX INTEGER ISTVEC(MXLIST),MODVAR(MXVAR),MODRES(1),I,J,IPAIR,NPAIR, - NCSTAT,NRES,IENTRY,NCF,ITYPE,IFAIL,IU,NCAUX +SELF,IF=SAVE. SAVE VARLIS +SELF. *** Initialise the VARLIS list of function variables. DATA (VARLIS(I),I=1,11)/ - 'LENGTH ','TIME ','DIFFUSION ','AVALANCHE ', - 'LOSS ','X_END ','Y_END ','Z_END ', - 'X_START ','Y_START ','Z_START '/ *** Identify the routine if requested. IF(LIDENT)PRINT *,' /// ROUTINE DRFTRA ///' *** Perform preliminary checks, make sure the track has been set. IF(.NOT.TRFLAG(1))THEN PRINT *,' !!!!!! DRFTRA WARNING : The track has not been'// - ' set ; the plot is not made.' RETURN ENDIF * The track should be in the drift area. IF(POLAR)THEN IFAIL=0 CALL CFMCTR(XT0,YT0,XR0,YR0,1) CALL CFMCTR(XT1,YT1,XR1,YR1,1) IF(XR0.LT.DXMIN.OR.XR0.GT.DXMAX.OR. - XR1.LT.DXMIN.OR.XR1.GT.DXMAX.OR. - YR0.LT.DYMIN.OR.YR0.GT.DYMAX.OR. - YR1.LT.DYMIN.OR.YR1.GT.DYMAX)IFAIL=1 ELSE XT0AUX=XT0 YT0AUX=YT0 ZT0AUX=ZT0 XT1AUX=XT1 YT1AUX=YT1 ZT1AUX=ZT1 CALL CLIP3(XT0AUX,YT0AUX,ZT0AUX,XT1AUX,YT1AUX,ZT1AUX, - DXMIN,DYMIN,DZMIN,DXMAX,DYMAX,DZMAX,IFAIL) ENDIF IF(IFAIL.NE.0.AND.POLAR)THEN PRINT *,' !!!!!! DRFTRA WARNING : The track lies at', - ' least partialy outside the drift area ;', - ' no drift lines.' RETURN ELSEIF(IFAIL.NE.0)THEN PRINT *,' !!!!!! DRFTRA WARNING : The track is not', - ' lying at least partially in the drift', - ' area or has length 0 ; no drift lines.' RETURN ENDIF *** Initialise the output vectores. DO 10 I=1,MXLIST ISTVEC(I)=0 TIMVEC(I)=0.0 VELVEC(I)=0.0 DIFVEC(I)=0.0 AVAVEC(I)=0.0 ATTVEC(I)=0.0 FUNVEC(I)=0.0 POSVEC(I)=0.0 10 CONTINUE *** Translate the function if requested. IF(LFUNPL)THEN IF(POLAR)THEN VARLIS(6)='R_END' VARLIS(7)='PHI_END' VARLIS(9)='R_START' VARLIS(10)='PHI_START' ELSE VARLIS(6)='X_END' VARLIS(7)='Y_END' VARLIS(9)='X_START' VARLIS(10)='Y_START' ENDIF IF(INDEX(FUNCT(1:NCF),'@').NE.0)THEN NRES=1 CALL ALGEDT(VARLIS,11,IENTRY,USE,NRES) ELSE CALL ALGPRE(FUNCT,NCF,VARLIS,11,NRES,USE,IENTRY,IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! DRFTRA WARNING : The function '// - FUNCT(1:NCF)//' can not be used because'// - ' of the syntax errors (see above).' CALL ALGCLR(IENTRY) RETURN ELSEIF(((USE(1).OR.USE(2)).AND..NOT.GASOK(1)).OR. - (USE(3).AND..NOT.GASOK(3)).OR. - (USE(4).AND..NOT.GASOK(4)).OR. - (USE(5).AND..NOT.GASOK(6)))THEN PRINT *,' !!!!!! DRFTRA WARNING : The amount of'// - ' gas data is insufficient to calculate'// - ' the function '//FUNCT(1:NCF) CALL ALGCLR(IENTRY) RETURN ENDIF ENDIF IF(NRES.NE.1)THEN PRINT *,' !!!!!! DRFTRA WARNING : The function '// - FUNCT(1:NCF)//' does not return a single'// - ' result ; rejected.' CALL ALGCLR(IENTRY) RETURN ENDIF ENDIF *** Initialise clustering. CALL TRACLI *** Prepare for output: print a heading if printing is requested. IF(LLINPR)THEN XT0P=XT0 YT0P=YT0 XT1P=XT1 YT1P=YT1 IF(POLAR)CALL CFMCTP(XT0P,YT0P,XT0P,YT0P,1) IF(POLAR)CALL CFMCTP(XT1P,YT1P,XT1P,YT1P,1) WRITE(LUNOUT,'(''1 Track drift line plot :'',/, - '' ======================='',//)') IF(ITYPE.EQ.1)THEN WRITE(LUNOUT,'('' Drifting'', - '' electrons with charge '',F4.1)') Q ELSE WRITE(LUNOUT,'('' Drifting'', - '' ions with charge '',F4.1)') Q ENDIF WRITE(LUNOUT,'('' The particle begins at ('',F10.3,'','', - F10.3,'','',F10.3,'')''/ - '' and goes towards ('',F10.3,'','',F10.3,'','', - F10.3,'')''//)') XT0P,YT0P,ZT0,XT1P,YT1P,ZT1 IF(.NOT.POLAR)THEN WRITE(LUNOUT,'('' x-start y-start'', - '' z-start Drift time Mean speed'', - '' Diffusion Avalanche'', - '' Status information'')') WRITE(LUNOUT,'('' [cm] [cm]'', - '' [cm] [musec] [cm/musec]'', - '' [musec] [numeric]'',//)') ELSE WRITE(LUNOUT,'('' r-start phi-start'', - '' z-start Drift time Mean speed'', - '' Diffusion Avalanche'', - '' Status information'')') WRITE(LUNOUT,'('' [cm] [degrees]'', - '' [cm] [musec] [cm/musec]'', - '' [musec] [numeric]'',//)') ENDIF ENDIF * Open a plot frame for the drift-lines if plotting is requested. IF(LEQTPL.OR.LLINPL)THEN IF(ITYPE.EQ.1.AND.Q.LT.0)THEN CALL GRCELL(VXMIN,VYMIN,VXMAX,VYMAX, - 'Electron drift lines from a track') ELSEIF(ITYPE.EQ.1)THEN CALL GRCELL(VXMIN,VYMIN,VXMAX,VYMAX, - 'Positron drift lines from a track') ELSEIF(Q.LT.0)THEN CALL GRCELL(VXMIN,VYMIN,VXMAX,VYMAX, - 'Drift lines of negative ions from a track') ELSE CALL GRCELL(VXMIN,VYMIN,VXMAX,VYMAX, - 'Drift lines of positive ions from a track') ENDIF IF(GASID.NE.' ')CALL GRCOMM(2,'Gas: '//GASID) IF(PARTID.NE.'Unknown')CALL GRCOMM(3,'Particle: '//PARTID) IF(LEQTPL)THEN CALL OUTFMT(TSTEP,2,AUXSTR,NCAUX,'LEFT') CALL GRCOMM(4,'Isochrone interval: '//AUXSTR(1:NCAUX)// - ' [microsec]') CALL DRFEQR ENDIF CALL GRALOG('Track drift line plot. ') ENDIF *** Start drift lines from the track. I=0 20 CONTINUE * Generate a cluster. CALL TRACLS(XSTART,YSTART,ZSTART,ESTART,NPAIR,DONE,IFAIL) IF(DONE)GOTO 40 * Loop over the electrons. DO 50 IPAIR=1,NPAIR * Convert position to internal in polar cells. IF(POLAR)CALL CFMCTR(XSTART,YSTART,XSTART,YSTART,1) * Calculate the drift line starting at (XSTART,YSTART) IF(LDRMC)THEN CALL DLCMC(XSTART,YSTART,ZSTART,Q,ITYPE) ELSE CALL DLCALC(XSTART,YSTART,ZSTART,Q,ITYPE) ENDIF * Skip if the line has no steps. IF(NU.LE.0.OR.NU.GT.MXLIST)THEN PRINT *,' !!!!!! DLCTRA WARNING : Drift line has no'// - ' steps or more than MXLIST steps; skipped.' GOTO 20 ENDIF * Increment track counter. IF(I.GE.MXLIST)THEN PRINT *,' !!!!!! DLCTRA WARNING : Maximum number of'// - ' electrons reached ; rest is skipped.' GOTO 40 ELSE I=I+1 ENDIF * Convert position to cartesian in polar cells. IF(POLAR)CALL CFMRTC(XSTART,YSTART,XSTART,YSTART,1) * To be able to store the coordinate. POSVEC(I)=SQRT((XSTART-XT0)**2+(YSTART-YT0)**2+(ZSTART-ZT0)**2) * And convert position to polar in polar cells for printing. IF(POLAR)CALL CFMCTP(XSTART,YSTART,XSTART,YSTART,1) ** Calculate and store the derived information for the graphs. ISTVEC(I)=ISTAT TIMVEC(I)=TU(NU) IF(LVELPL.OR.(LFUNPL.AND.USE(1)))THEN DRLENG=0.0 DO 30 IU=2,NU IF(POLAR)THEN CALL CF2RTC(XU(IU-1),YU(IU-1),XAUX1,YAUX1,1) CALL CF2RTC(XU(IU),YU(IU),XAUX2,YAUX2,1) DRLENG=DRLENG+SQRT((XAUX2-XAUX1)**2+ - (YAUX2-YAUX1)**2+(ZU(IU)-ZU(IU-1))**2) ELSE DRLENG=DRLENG+SQRT((XU(IU)-XU(IU-1))**2+ - (YU(IU)-YU(IU-1))**2+(ZU(IU)-ZU(IU-1))**2) ENDIF 30 CONTINUE IF(TU(NU).GT.0.0)THEN VELVEC(I)=REAL(DRLENG/TU(NU)) ELSE VELVEC(I)=0.0 ENDIF ENDIF IF(GASOK(3).AND.(LDIFPL.OR.(LFUNPL.AND.USE(3)))) - CALL DLCDIF(DIFVEC(I)) IF(GASOK(4).AND.(LAVAPL.OR.(LFUNPL.AND.USE(4)))) - CALL DLCTWN(AVAVEC(I)) IF(GASOK(6).AND.LFUNPL.AND.USE(5))CALL DLCATT(ATTVEC(I)) IF(LFUNPL)THEN VAR(1)=DRLENG VAR(2)=REAL(TU(NU)) VAR(3)=DIFVEC(I) VAR(4)=AVAVEC(I) VAR(5)=ATTVEC(I) IF(POLAR)THEN CALL CF2RTP(XU(1),YU(1),XAUX1,YAUX1,1) VAR(9)=REAL(XAUX1) VAR(10)=REAL(YAUX1) CALL CF2RTP(XU(NU),YU(NU),XAUX1,YAUX1,1) VAR(6)=REAL(XAUX1) VAR(7)=REAL(YAUX1) ELSE VAR(9)=REAL(XU(1)) VAR(10)=REAL(YU(1)) VAR(6)=REAL(XU(NU)) VAR(7)=REAL(YU(NU)) ENDIF VAR(11)=REAL(ZU(1)) VAR(8)=REAL(ZU(NU)) MODVAR(1)=2 MODVAR(2)=2 MODVAR(3)=2 MODVAR(4)=2 MODVAR(5)=2 MODVAR(6)=2 MODVAR(7)=2 MODVAR(8)=2 MODVAR(9)=2 MODVAR(10)=2 MODVAR(11)=2 CALL ALGEXE(IENTRY,VAR,MODVAR,11,RES,MODRES,1,IFAIL) IF(MODRES(1).NE.2)THEN PRINT *,' !!!!!! DLCTRA WARNING : Function does not'// - ' return a number; set to 0.' FUNVEC(I)=0 ELSE FUNVEC(I)=RES(1) ENDIF ENDIF * Print information on this drift line if requested. IF(LLINPR)THEN CALL DLCSTF(ISTAT,STASTR,NCSTAT) WRITE(STRING,'(2X,7(E10.3,2X),A)') - XSTART,YSTART,ZSTART, - TIMVEC(I),VELVEC(I),DIFVEC(I),AVAVEC(I), - STASTR(1:MIN(45,NCSTAT)) IF(.NOT.LVELPL)STRING(49:60)=' unavailable' IF(.NOT.GASOK(3).OR..NOT.LDIFPL) - STRING(61:72)=' unavailable' IF(.NOT.GASOK(4).OR..NOT.LAVAPL) - STRING(73:84)=' unavailable' WRITE(LUNOUT,'(A133)') STRING ENDIF * Plot the drift line obtained - if this is requested. IF(LLINPL)CALL DLCPLT *** Invert TU in order to obtain the time-distance from the sense wire. IF(LEQREV.AND.LEQTPL)THEN DO 80 J=1,NU TU(J)=TU(NU)-TU(J) 80 CONTINUE * Reverse XU, YU and TU so that they can be treated as plot vectors. DO 90 J=1,INT(NU/2.0) TRANSF=TU(J) TU(J)=TU(NU-J+1) TU(NU-J+1)=TRANSF TRANSF=XU(J) XU(J)=XU(NU-J+1) XU(NU-J+1)=TRANSF TRANSF=YU(J) YU(J)=YU(NU-J+1) YU(NU-J+1)=TRANSF TRANSF=ZU(J) ZU(J)=ZU(NU-J+1) ZU(NU-J+1)=TRANSF 90 CONTINUE * Add to the equal time contour table, select appropriate drift-lines. IF((ISTAT.GE.-15.AND.ISTAT.LE.-11).OR. - (ISTAT.GE.1.AND.ISTAT.LE.NWIRE).OR. - (ISTAT.GE.2*MXWIRE+1.AND.ISTAT.LE.2*MXWIRE+NSOLID)) - CALL DRFEQT(TSTEP,ISTAT) ELSEIF(LEQTPL)THEN CALL DRFEQT(TSTEP,-20) ENDIF * Next electron in the cluster. 50 CONTINUE * Next cluster. GOTO 20 * Last cluster processed. 40 CONTINUE * Plot the track. IF(LEQTPL.OR.LLINPL)CALL TRAPLT *** Register the amount of CPU time used for calculating drift lines. CALL TIMLOG('Making a track drift-line plot: ') *** Algebra stuff. IF(LFUNPL)THEN CALL ALGERR CALL ALGCLR(IENTRY) ENDIF *** Plot the equal time contours, if requested. IF(LEQTPL)CALL DRFEQP * Clear the screen if at least a plot has been made. IF(LEQTPL.OR.LLINPL)CALL GRNEXT * Print any error messages accumulated by DRFEQT. IF(LEQTPL)CALL DRFEQE *** Plot the various graphs as requested, first the drift time plot. IF(LTIMPL)CALL DRFTR2(TIMVEC,POSVEC,ISTVEC,I,MARKER, - 'Drift time [microsec]','Drift time') IF(LTIMPL) - CALL GRALOG('Graph of the drift-time ') * Next the average drift velocity plot. IF(LVELPL)CALL DRFTR2(VELVEC,POSVEC,ISTVEC,I,MARKER, - 'Mean drift speed [cm/microsec]', - 'Average drift speed') IF(LVELPL) - CALL GRALOG('Graph of the average drift-velocity ') * diffusion plot ... IF(LDIFPL)CALL DRFTR2(DIFVEC,POSVEC,ISTVEC,I,MARKER, - 'Integrated diffusion [microsec]', - 'Integrated diffusion') IF(LDIFPL) - CALL GRALOG('Graph of the integrated diffusion ') * the multiplication plot ... IF(LAVAPL)CALL DRFTR2(AVAVEC,POSVEC,ISTVEC,I,MARKER, - 'Multiplication Factor [numeric]', - 'Multiplication factor') IF(LAVAPL) - CALL GRALOG('Graph of the multiplication factor ') * and the function plot. IF(LFUNPL)THEN STRING=' ' STRING(1:40)='Graph of '//FUNCT(1:MIN(31,NCF)) STRING(81-MIN(40,NCF):80)=FUNCT(1:MIN(40,NCF)) CALL DRFTR2(FUNVEC,POSVEC,ISTVEC,I,MARKER, - STRING(41:80),STRING(1:40)) STRING=' ' STRING(1:40)='Graph of '//FUNCT(1:MIN(31,NCF)) CALL GRALOG(STRING(1:40)) ENDIF ** Register the amount of CPU time used for plotting these curves. CALL TIMLOG('Plotting various drift related graphs: ') END +DECK,DRFTR2. SUBROUTINE DRFTR2(PLTVEC,POSVEC,ISTVEC,NVEC,MARKER,TEXT,TITLE) *----------------------------------------------------------------------- * DRFTR2 - Auxiliary routine to DRFTRA, it plots the various graphs * such as the mean velocity. * VARIABLES : PLTVEC : The vector to be plotted. * ISTVEC : Vector of status codes. * other args : Texts to be plotted along the axes. * (Last changed on 7/11/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,GASDATA. +SEQ,PARAMETERS. REAL PLTVEC(MXLIST),XPL(MXLIST),YPL(MXLIST),POSVEC(MXLIST), - PMIN,PMAX,PDEL,XEMIN,XEMAX,XDEL,AUX,XTXT,YTXT INTEGER ISTVEC(MXLIST),IND(MXLIST),IAUX,I,J,NVEC,NPL,NC,NCAUX CHARACTER*(*) TEXT,TITLE CHARACTER*20 AUXSTR LOGICAL MARKER,PSET CHARACTER*40 COMSTR *** Make sure NVEC is > 0. IF(NVEC.LE.1)THEN PRINT *,' !!!!!! DRFTR2 WARNING : Insufficient number'// - ' of points in the plot vector; no graph.' RETURN ENDIF *** Sort the coordinate vector and make the plot vectors follow. CALL SORTZV(POSVEC,IND,NVEC,1,0,0) DO 100 I=1,NVEC * Rearrange positions. AUX=POSVEC(I) POSVEC(I)=POSVEC(IND(I)) POSVEC(IND(I))=AUX * Rearrange plot vector. AUX=PLTVEC(I) PLTVEC(I)=PLTVEC(IND(I)) PLTVEC(IND(I))=AUX * Rearrange status codes. IAUX=ISTVEC(I) ISTVEC(I)=ISTVEC(IND(I)) ISTVEC(IND(I))=IAUX * Update sort vector. DO 110 J=I,NVEC IF(IND(J).EQ.I)IND(J)=IND(I) 110 CONTINUE 100 CONTINUE *** Determine the range of the plotted vector, excluding abnormal ends. PSET=.FALSE. DO 10 I=1,NVEC IF(ISTVEC(I).EQ.-2.OR.ISTVEC(I).EQ.-3)GOTO 10 IF(PSET)THEN PMIN=MIN(PMIN,PLTVEC(I)) PMAX=MAX(PMAX,PLTVEC(I)) ELSE PMIN=PLTVEC(I) PMAX=PLTVEC(I) PSET=.TRUE. ENDIF 10 CONTINUE * Ensure that a range has been found. IF(.NOT.PSET)THEN PRINT *,' !!!!!! DRFTR2 WARNING : No complete drift lines'// - ' have been seen ; no useful plots can be made.' RETURN ENDIF * Slightly increase the range to get a reasonable plot. PDEL=ABS(PMAX-PMIN) IF(PMIN.LT.0)THEN PMIN=PMIN-0.1*PDEL ELSE PMIN=MAX(0.0,PMIN-0.1*PDEL) ENDIF PMAX=PMAX+0.1*PDEL XDEL=ABS(POSVEC(NVEC)-POSVEC(1)) XEMIN=POSVEC(1)-0.1*XDEL XEMAX=POSVEC(NVEC)+0.1*XDEL *** Open a frame following the coordinate along the track. CALL GRCART(XEMIN,PMIN,XEMAX,PMAX, - 'Distance from track start [cm]',TEXT,TITLE) * Add some comments to the plot. IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) IF(GASID.NE.' ')CALL GRCOMM(2,'Gas: '//GASID) *** Plot the curve, start by initialising the plot vector. NPL=1 XPL(NPL)=POSVEC(1) YPL(NPL)=PLTVEC(1) * Loop over the points. DO 40 I=2,NVEC ** Change of status or end of line. IF(I.EQ.NVEC.OR.ISTVEC(I).NE.ISTVEC(I-1))THEN * End of line, but no change of status: add. IF(ISTVEC(I).EQ.ISTVEC(I-1))THEN IF(NPL.GE.MXLIST)THEN PRINT *,' ###### DRFTR2 ERROR : Plot buffer'// - ' overflow ; plot closed.' CALL GRNEXT RETURN ENDIF NPL=NPL+1 XPL(NPL)=POSVEC(I) YPL(NPL)=PLTVEC(I) ENDIF * Unless abandoned or out of steps: draw the graph. IF(ISTVEC(I-1).NE.-2.AND.ISTVEC(I-1).NE.-3)THEN IF(NPL.EQ.1.OR.(MARKER.AND.NPL.GE.1))THEN CALL GRATTS('FUNCTION-1','POLYMARKER') CALL GPM(NPL,XPL,YPL) ELSEIF(NPL.GT.1)THEN CALL GRATTS('FUNCTION-1','POLYLINE') CALL GPL(NPL,XPL,YPL) ENDIF ENDIF * A string explaining where the particles ended. IF(ISTVEC(I-1).EQ.-6)THEN COMSTR='Left mesh' NC=9 ELSEIF(ISTVEC(I-1).EQ.-5)THEN COMSTR='Left drift medium' NC=17 ELSEIF(ISTVEC(I-1).EQ.-4)THEN COMSTR='Plane' NC=5 ELSEIF(ISTVEC(I-1).EQ.-3)THEN COMSTR='Abnormal' NC=8 ELSEIF(ISTVEC(I-1).EQ.-2)THEN COMSTR='Too many steps' NC=14 ELSEIF(ISTVEC(I-1).EQ.-1)THEN COMSTR='Left the area' NC=13 ELSEIF(ISTVEC(I-1).GT.0.AND. - ISTVEC(I-1).LE.MXWIRE)THEN CALL OUTFMT(REAL(ISTVEC(I-1)),2,AUXSTR,NCAUX,'LEFT') COMSTR='Wire '//AUXSTR(1:NCAUX) NC=5+NCAUX ELSEIF(ISTVEC(I-1).GT.MXWIRE.AND. - ISTVEC(I-1).LE.2*MXWIRE)THEN CALL OUTFMT(REAL(ISTVEC(I-1)-MXWIRE),2, - AUXSTR,NCAUX,'LEFT') COMSTR='Replica '//AUXSTR(1:NCAUX) NC=8+NCAUX ELSEIF(ISTVEC(I-1).GT.2*MXWIRE.AND. - ISTVEC(I-1).LE.2*MXWIRE+MXSOLI)THEN CALL OUTFMT(REAL(ISTVEC(I-1)-2*MXWIRE),2, - AUXSTR,NCAUX,'LEFT') COMSTR='Solid '//AUXSTR(1:NCAUX) NC=6+NCAUX ELSE COMSTR='Unknown' NC=7 ENDIF XTXT=(XPL(1)+XPL(NPL))/2 YTXT=PMIN+0.02*(PMAX-PMIN) CALL GRATTS('COMMENT','TEXT') CALL GSTXAL(2,5) CALL GRTEXT(XTXT,YTXT,COMSTR(1:NC)) CALL GSTXAL(0,0) * Change of status: plot a vertical bar indicating the separation, IF(ISTVEC(I).NE.ISTVEC(I-1))THEN XPL(1)=(POSVEC(I)+POSVEC(I-1))/2 XPL(2)=(POSVEC(I)+POSVEC(I-1))/2 YPL(1)=PMIN YPL(2)=PMAX CALL GRATTS('COMMENT','POLYLINE') CALL GPL(2,XPL,YPL) ENDIF * Start a new list or reset the list. IF(ISTVEC(I).NE.ISTVEC(I-1))THEN NPL=1 XPL(NPL)=POSVEC(I) YPL(NPL)=PLTVEC(I) ELSE NPL=0 ENDIF ** No change in status: add to buffer. ELSE IF(NPL.GE.MXLIST)THEN PRINT *,' ###### DRFTR2 ERROR : Plot buffer'// - ' overflow ; plot closed.' CALL GRNEXT RETURN ENDIF NPL=NPL+1 XPL(NPL)=POSVEC(I) YPL(NPL)=PLTVEC(I) ENDIF 40 CONTINUE *** Plot any data not yet plotted, if not abandoned or out of steps. IF(ISTVEC(NVEC).NE.-2.AND.ISTVEC(NVEC).NE.-3)THEN IF(NPL.EQ.1.OR.(MARKER.AND.NPL.GE.1))THEN CALL GRATTS('FUNCTION-1','POLYMARKER') CALL GPM(NPL,XPL,YPL) ELSEIF(NPL.GT.1)THEN CALL GRATTS('FUNCTION-1','POLYLINE') CALL GPL(NPL,XPL,YPL) ENDIF ENDIF * A string explaining where the particles ended. IF(NPL.GE.1)THEN IF(ISTVEC(NVEC).EQ.-6)THEN COMSTR='Left mesh' NC=9 ELSEIF(ISTVEC(NVEC).EQ.-5)THEN COMSTR='Left drift medium' NC=17 ELSEIF(ISTVEC(NVEC).EQ.-4)THEN COMSTR='Plane' NC=5 ELSEIF(ISTVEC(NVEC).EQ.-3)THEN COMSTR='Abnormal' NC=8 ELSEIF(ISTVEC(NVEC).EQ.-2)THEN COMSTR='Too many steps' NC=14 ELSEIF(ISTVEC(NVEC).EQ.-1)THEN COMSTR='Left the area' NC=13 ELSEIF(ISTVEC(NVEC).GT.0.AND. - ISTVEC(NVEC).LE.MXWIRE)THEN CALL OUTFMT(REAL(ISTVEC(NVEC)),2,AUXSTR,NCAUX,'LEFT') COMSTR='Wire '//AUXSTR(1:NCAUX) NC=5+NCAUX ELSEIF(ISTVEC(NVEC).GT.MXWIRE.AND. - ISTVEC(NVEC).LE.2*MXWIRE)THEN CALL OUTFMT(REAL(ISTVEC(NVEC)-MXWIRE),2, - AUXSTR,NCAUX,'LEFT') COMSTR='Replica '//AUXSTR(1:NCAUX) NC=8+NCAUX ELSEIF(ISTVEC(NVEC).GT.2*MXWIRE.AND. - ISTVEC(NVEC).LE.2*MXWIRE+MXSOLI)THEN CALL OUTFMT(REAL(ISTVEC(NVEC)-2*MXWIRE),2, - AUXSTR,NCAUX,'LEFT') COMSTR='Solid '//AUXSTR(1:NCAUX) NC=6+NCAUX ELSE COMSTR='Unknown' NC=7 ENDIF XTXT=(XPL(1)+XPL(NPL))/2 YTXT=PMIN+0.02*(PMAX-PMIN) CALL GRATTS('COMMENT','TEXT') CALL GSTXAL(2,5) CALL GRTEXT(XTXT,YTXT,COMSTR(1:NC)) CALL GSTXAL(0,0) ENDIF *** Close this frame etc. CALL GRNEXT END +DECK,DRFSIN. SUBROUTINE DRFSIN *----------------------------------------------------------------------- * DRFSIN - Prints and plots information on a single drift-line. * (Last changed on 6/ 2/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,DRIFTLINE. +SEQ,GASDATA. +SEQ,CELLDATA. +SEQ,PRINTPLOT. DOUBLE PRECISION F0(3) REAL XPL(MXLIST),YPL(MXLIST),YPR(MXLIST),VAR(MXVAR),RES(3), - GASDFL,GASTWN,GASATT,VOLT,XSTART,YSTART,ZSTART,QPART,PATH INTEGER MODVAR(MXVAR),MODRES(3),I,IFAIL1,IFAIL2,IFAIL3,IENTRY, - NRES,ILOC,NCSTAT,IFAIL,NCFPL1,NCFPL2,NCFPR,INPTYP, - INPCMP,IFROM,INEXT,IPART,NWORD LOGICAL KPLOT,KPRINT,USE(MXVAR) CHARACTER*(MXCHAR) FPL1,FPL2,FPR CHARACTER*80 STASTR CHARACTER*20 PARTID CHARACTER*10 VARLIS(MXVAR) EXTERNAL GASDFL,GASTWN,GASATT,INPTYP,INPCMP DATA (VARLIS(I),I=1,21) / - 'X ','Y ','PATH ','EX ', - 'EY ','E ','BX ','BY ', - 'BZ ','B ','VDX ','VDY ', - 'VDZ ','VD ','TIME ','DIFFUSION ', - 'TOWNSEND ','STATUS ','ATTACHMENT','EZ ', - 'Z '/ *** Defaults. IFROM=0 FPL1='0' NCFPL1=1 FPL2='0' NCFPL2=1 KPLOT=.FALSE. FPR='0' NCFPR=1 KPRINT=.FALSE. QPART=-1.0 IPART=1 *** Decode the argument list. CALL INPNUM(NWORD) INEXT=2 DO 10 I=2,NWORD IF(I.LT.INEXT)GOTO 10 * FROM component. IF(INPCMP(I,'FR#OM').NE.0)THEN CALL INPCHK(I+1,2,IFAIL1) CALL INPCHK(I+2,2,IFAIL2) IF(IFAIL1.NE.0.OR.IFAIL2.NE.0.OR.NWORD.LT.I+2)THEN CALL INPMSG(I,'Invalid or incomplete args. ') ELSE CALL INPRDR(I+1,XSTART,0.0) CALL INPRDR(I+2,YSTART,0.0) IF(POLAR)THEN CALL CFMPTR(XSTART,YSTART,XSTART,YSTART,1,IFAIL3) IF(IFAIL3.NE.0)THEN CALL INPMSG(I, - 'Not a valid polar coordinate. ') IFROM=0 ELSE IFROM=1 ENDIF ELSE IFROM=1 ENDIF IF(IFROM.EQ.1.AND. - (XSTART.LT.DXMIN.OR.XSTART.GT.DXMAX.OR. - YSTART.LT.DYMIN.OR.YSTART.GT.DYMAX))THEN CALL INPMSG(I,'Starting point outside AREA. ') IFROM=0 ENDIF ENDIF IF(INPTYP(I+3).EQ.1.OR.INPTYP(I+3).EQ.2)THEN CALL INPCHK(I+3,2,IFAIL3) CALL INPRDR(I+3,ZSTART,0.0) INEXT=I+4 IF(ZSTART.LT.DZMIN.OR.ZSTART.GT.DZMAX)THEN CALL INPMSG(I,'Starting point outside AREA') IFROM=0 ENDIF ELSE IFAIL3=0 ZSTART=0.0 INEXT=I+3 ENDIF * Functions to be plotted. ELSEIF(INPCMP(I,'PL#OT').NE.0)THEN IF(INPCMP(I+2,'VS').EQ.0.OR.I+3.GT.NWORD)THEN CALL INPMSG(I,'Invalid or incomplete args. ') ELSE CALL INPSTR(I+1,I+1,FPL2,NCFPL2) CALL INPSTR(I+3,I+3,FPL1,NCFPL1) KPLOT=.TRUE. INEXT=I+4 ENDIF ELSEIF(INPCMP(I,'NOPL#OT').NE.0)THEN KPLOT=.FALSE. * Function to be printed. ELSEIF(INPCMP(I,'PR#INT').NE.0)THEN IF(I+1.GT.NWORD)THEN CALL INPMSG(I,'Invalid or incomplete args. ') ELSE CALL INPSTR(I+1,I+1,FPR,NCFPR) KPRINT=.TRUE. INEXT=I+2 ENDIF ELSEIF(INPCMP(I,'NOPR#INT').NE.0)THEN KPRINT=.FALSE. * Particle type. ELSEIF(INPCMP(I,'E#LECTRON').NE.0)THEN IPART=1 ELSEIF(INPCMP(I,'I#ON').NE.0)THEN IF(GASOK(2))THEN IPART=2 ELSE CALL INPMSG(I,'Ion mobility data missing. ') ENDIF * Particle charge. ELSEIF(INPCMP(I,'POS#ITIVE').NE.0)THEN QPART=+1.0 ELSEIF(INPCMP(I,'NEG#ATIVE').NE.0)THEN QPART=-1.0 * Anything else is not valid. ELSE CALL INPMSG(I,'Not recognised as a keyword. ') ENDIF 10 CONTINUE *** Dump error messages. CALL INPERR *** Check completeness of the arguments. IF(IFROM.EQ.0.OR..NOT.(KPRINT.OR.KPLOT))THEN PRINT *,' !!!!!! DRFSIN WARNING : FROM component missing'// - ' or no output requested; not executed.' RETURN ENDIF *** Translate the functions, assign appropriate variable names. IF(POLAR)THEN VARLIS(1)='R ' VARLIS(2)='PHI ' VARLIS(4)='ER ' VARLIS(5)='EPHI ' VARLIS(11)='VDR ' VARLIS(12)='VDPHI ' ELSE VARLIS(1)='X ' VARLIS(2)='Y ' VARLIS(4)='EX ' VARLIS(5)='EY ' VARLIS(11)='VDX ' VARLIS(12)='VDY ' ENDIF * Handle the case of user editor steps. IF(INDEX(FPL1(1:NCFPL1)//FPL2(1:NCFPL2)// - FPR(1:NCFPR),'@').NE.0)THEN NRES=3 CALL ALGEDT(VARLIS,21,IENTRY,USE,NRES) FPL1=' ' NCFPL1=1 FPL2='Edited function' NCFPL2=1 FPR='Edited function' NCFPR=15 * Ordinary formula translation. ELSE CALL ALGPRE(FPL1(1:NCFPL1)//','//FPL2(1:NCFPL2)//','// - FPR(1:NCFPR),NCFPL1+NCFPL2+NCFPR+2,VARLIS,21, - NRES,USE,IENTRY,IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! DRFSIN WARNING : Graph and printed'// - ' table not produced because of syntax errors.' CALL ALGCLR(IENTRY) RETURN ELSEIF((USE(11).OR.USE(12).OR.USE(13).OR.USE(14)).AND. - .NOT.((IPART.EQ.1.AND.GASOK(1)).OR. - (IPART.EQ.2.AND.GASOK(2))))THEN PRINT *,' !!!!!! DRFSIN WARNING : Drift velocity'// - ' data used in formula, but data is absent.' CALL ALGCLR(IENTRY) RETURN ELSEIF(USE(16).AND..NOT.(GASOK(3).OR.GASOK(8)))THEN PRINT *,' !!!!!! DRFSIN WARNING : Diffusion'// - ' data used in formula, but data is absent.' CALL ALGCLR(IENTRY) RETURN ELSEIF(USE(17).AND..NOT.GASOK(4))THEN PRINT *,' !!!!!! DRFSIN WARNING : Townsend'// - ' data used in formula, but data is absent.' CALL ALGCLR(IENTRY) RETURN ELSEIF(USE(19).AND..NOT.GASOK(6))THEN PRINT *,' !!!!!! DRFSIN WARNING : Attachment'// - ' data used in formula, but data is absent.' CALL ALGCLR(IENTRY) RETURN ENDIF ENDIF * Check that there really are 3 results. IF(NRES.NE.3)THEN PRINT *,' !!!!!! DRFSIN WARNING : Graph and printed table'// - ' not produced: incorrect number of formula elements.' CALL ALGCLR(IENTRY) RETURN ENDIF *** Compute the drift line. CALL DLCALC(XSTART,YSTART,ZSTART,QPART,IPART) *** Zero the output variables. DO 30 I=1,21 MODVAR(I)=2 VAR(I)=0.0 30 CONTINUE *** Initialise the integrated path length. PATH=0.0 *** Loop over the resulting drift-line, filling plot and print vectors. DO 20 I=1,NU * Position, time and status. VAR(1)=XU(I) VAR(2)=YU(I) VAR(21)=ZU(I) VAR(15)=TU(I) VAR(18)=ISTAT * Field. IF(USE(4).OR.USE(5).OR.USE(6).OR.USE(20).OR. - USE(16).OR.USE(17).OR.USE(19)) - CALL EFIELD(VAR(1),VAR(2),VAR(21), - VAR(4),VAR(5),VAR(20),VAR(6),VOLT,0,ILOC) IF(USE(7).OR.USE(8).OR.USE(9).OR.USE(10).OR. - USE(16).OR.USE(17).OR.USE(19)) - CALL BFIELD(VAR(1),VAR(2),VAR(21), - VAR(7),VAR(8),VAR(9),VAR(10)) * Drift velocity. IF(USE(11).OR.USE(12).OR.USE(13).OR.USE(14))THEN CALL DLCVEL(XU(I),YU(I),ZU(I),F0,QPART,IPART,ILOC) VAR(11)=REAL(F0(1)) VAR(12)=REAL(F0(2)) VAR(13)=REAL(F0(3)) ENDIF * Diffusion, Townsend and attachment coefficients. IF(POLAR)THEN IF(USE(16))VAR(16)= - GASDFL(VAR(4)/EXP(VAR(1)),VAR(5)/EXP(VAR(1)),VAR(20), - VAR(7),VAR(8),VAR(9)) IF(USE(17))VAR(17)= - GASTWN(VAR(4)/EXP(VAR(1)),VAR(5)/EXP(VAR(1)),VAR(20), - VAR(7),VAR(8),VAR(9)) IF(USE(19))VAR(19)= - GASATT(VAR(4)/EXP(VAR(1)),VAR(5)/EXP(VAR(1)),VAR(20), - VAR(7),VAR(8),VAR(9)) ELSE IF(USE(16))VAR(16)=GASDFL(VAR(4),VAR(5),VAR(20), - VAR(7),VAR(8),VAR(9)) IF(USE(17))VAR(17)=GASTWN(VAR(4),VAR(5),VAR(20), - VAR(7),VAR(8),VAR(9)) IF(USE(19))VAR(19)=GASATT(VAR(4),VAR(5),VAR(20), - VAR(7),VAR(8),VAR(9)) ENDIF * Transform vectors and covectors to polar coordinates if needed. IF(POLAR)THEN CALL CFMRTP(VAR(1),VAR(2),VAR(1),VAR(2),1) VAR(4)=VAR(4)/VAR(1) VAR(5)=VAR(5)/VAR(1) VAR(6)=VAR(6)/VAR(1) VAR(11)=VAR(11)*VAR(1) VAR(12)=VAR(12)*VAR(1) ENDIF * Store magnitude of drift velocity. IF(USE(14))VAR(14)=SQRT(VAR(11)**2+VAR(12)**2+VAR(13)**2) * Conversion of the location. IF(POLAR)CALL CF2RTC(XU(I),YU(I),XU(I),YU(I),1) * Path. IF(I.GT.1)PATH=PATH+SQRT((XU(I)-XU(I-1))**2+(YU(I)-YU(I-1))**2+ - (ZU(I)-ZU(I-1))**2) VAR(3)=PATH * Function evaluation. CALL ALGEXE(IENTRY,VAR,MODVAR,21,RES,MODRES,3,IFAIL) XPL(I)=RES(1) YPL(I)=RES(2) YPR(I)=RES(3) * Next point of the drift line. 20 CONTINUE *** Prepare output strings. CALL DLCSTF(ISTAT,STASTR,NCSTAT) IF(QPART.GT.0)THEN PARTID='Positive' ELSE PARTID='Negative' ENDIF IF(IPART.EQ.1)THEN PARTID(9:)=' electron' ELSE PARTID(9:)=' ion' ENDIF *** Remove the algebra entry point. CALL ALGCLR(IENTRY) *** Print the results if requested. IF(KPRINT)THEN IF(POLAR)THEN CALL CFMRTP(XSTART,YSTART,XSTART,YSTART,1) CALL CF2CTP(XU,YU,XU,YU,NU) WRITE(LUNOUT,'(/'' SINGLE DRIFT-LINE PRINT-OUT:''// - '' Starting point: ('',E10.3,2('','',E10.3), - '')''/'' Drifting: '',A/ - '' Status code: '',A/ - '' Function: '',A// - '' r [cm] phi [degree]'', - '' z [cm] time [microsec]'', - '' Function'')') XSTART,YSTART,ZSTART, - PARTID,STASTR(1:NCSTAT),FPR(1:NCFPR) ELSE WRITE(LUNOUT,'(/'' SINGLE DRIFT-LINE PRINT-OUT:''// - '' Starting point: ('',E10.3,2('','',E10.3), - '')''/'' Drifting: '',A/ - '' Status code: '',A/ - '' Function: '',A// - '' x [cm] y [cm]]'', - '' z [cm] time [microsec]'', - '' Function'')') XSTART,YSTART,ZSTART, - PARTID,STASTR(1:NCSTAT),FPR(1:NCFPR) ENDIF DO 40 I=1,NU WRITE(LUNOUT,'(5(2X,E15.8))') REAL(XU(I)),REAL(YU(I)), - REAL(ZU(I)),REAL(TU(I)),YPR(I) 40 CONTINUE ENDIF *** Plot the results if requested. IF(KPLOT)THEN CALL GRGRPH(XPL,YPL,NU,FPL1(1:NCFPL1),FPL2(1:NCFPL2), - 'SINGLE DRIFT-LINE GRAPH') IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) IF(GASID.NE.' ')CALL GRCOMM(2,'Gas: '//GASID) CALL GRCOMM(3,'Drifting: '//PARTID) CALL GRCOMM(4,'Status: '//STASTR(1:NCSTAT)) CALL GRNEXT CALL GRALOG('Single drift line plot. ') ENDIF END +DECK,DRFSOL. SUBROUTINE DRFSOL(Q,ITYPE,TSTEP,LEQTPL,LEQREV, - LLINPL,LLINPR,NLINEV) *----------------------------------------------------------------------- * DRFSOL - Subroutine making a plot of the drift lines and the equal * time contours starting from solid that are specified in * the INDSOL selection. * VARIABLES : * (Last changed on 16/ 3/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PARAMETERS. +SEQ,CELLDATA. +SEQ,SOLIDS. +SEQ,GASDATA. +SEQ,CONSTANTS. +SEQ,PRINTPLOT. +SEQ,DRIFTLINE. CHARACTER*80 AUXSTR,STASTR INTEGER ISOL,ITYPE,NLINEV,NCSTAT,NCAUX,NPL,NPANEL,IPANEL, - IVOL,ICOL,IFAIL,I,J,IPL REAL Q,TSTEP,VXMIN,VYMIN,VXMAX,VYMAX,XSTART,YSTART,ZSTART DOUBLE PRECISION XPL(MXEDGE),YPL(MXEDGE),ZPL(MXEDGE),APL,BPL,CPL, - TOTAL,DTOTAL,TRANSF LOGICAL LEQTPL,LLINPL,LLINPR,LEQREV *** Define some formats. 1080 FORMAT('1 Table of drift lines from solids:',/, - ' =================================',//, - ' The equal time contours are separated by ',E10.3, - ' microsecs'/ - ' Drifting ',A,', charge=',I2// - ' Line Solid Steps Drift time Remarks'/ - ' [microsec] '//) *** Identify the routine, if requested. IF(LIDENT)PRINT *,' /// ROUTINE DRFSOL ///' *** Print a heading for the table IF(LLINPR.AND.ITYPE.EQ.1)WRITE(LUNOUT,1080) TSTEP,'electrons', - NINT(Q) IF(LLINPR.AND.ITYPE.EQ.2)WRITE(LUNOUT,1080) TSTEP,'ions', - NINT(Q) *** Prepare a plot (layout, frame number etc) IF(LEQTPL.OR.LLINPL)THEN IF(ITYPE.EQ.1.AND.Q.GT.0)THEN CALL GRCELL(VXMIN,VYMIN,VXMAX,VYMAX, - 'Positron drift lines from solids') ELSEIF(ITYPE.EQ.1)THEN CALL GRCELL(VXMIN,VYMIN,VXMAX,VYMAX, - 'Electron drift lines from solids') ELSEIF(Q.GT.0)THEN CALL GRCELL(VXMIN,VYMIN,VXMAX,VYMAX, - 'Drift lines of positive ions from solids') ELSE CALL GRCELL(VXMIN,VYMIN,VXMAX,VYMAX, - 'Drift lines of negative ions from solids') ENDIF IF(GASID.NE.' ')CALL GRCOMM(2,'Gas: '//GASID) IF(LEQTPL)THEN CALL OUTFMT(TSTEP,2,AUXSTR,NCAUX,'LEFT') CALL GRCOMM(4,'Isochrone interval: '//AUXSTR(1:NCAUX)// - ' [microsec]') CALL DRFEQR ENDIF CALL GRALOG('Drift lines from solids') ENDIF *** Set the appropriate representations. IF(ITYPE.EQ.2)THEN CALL GRATTS('ION-DRIFT-LINE','POLYLINE') ELSE CALL GRATTS('E-DRIFT-LINE','POLYLINE') ENDIF *** Loop over all solids in the plot frame attracting electrons. DO 10 ISOL=1,NSOLID * Ensure the solid is selected. IF(INDSOL(ISOL).EQ.0)GOTO 10 * Reset the buffer of the panels. CALL PLABU1('RESET',ISOL,NPL,XPL,YPL,ZPL, - 0.0D0,0.0D0,0.0D0,ICOL,IVOL,IFAIL) * Compute the intersect with the viewing plane, cylinders ... IF(ISOLTP(ISOL).EQ.1)THEN CALL PLACYC(ISOL,FPROJ(3,1),FPROJ(3,2),FPROJ(3,3), - FPROJA,FPROJB,FPROJC,ICOL) * cylindrical holes. ELSEIF(ISOLTP(ISOL).EQ.2)THEN CALL PLACHC(ISOL,FPROJ(3,1),FPROJ(3,2),FPROJ(3,3), - FPROJA,FPROJB,FPROJC,ICOL) * boxes ... ELSEIF(ISOLTP(ISOL).EQ.3)THEN CALL PLABXC(ISOL,FPROJ(3,1),FPROJ(3,2),FPROJ(3,3), - FPROJA,FPROJB,FPROJC,ICOL) * spheres ... ELSEIF(ISOLTP(ISOL).EQ.4)THEN CALL PLASPC(ISOL,FPROJ(3,1),FPROJ(3,2),FPROJ(3,3), - FPROJA,FPROJB,FPROJC,ICOL) * other things not known. ELSE PRINT *,' !!!!!! DRFSOL WARNING : Met a solid of unknown'// - ' type ',ISOLTP(IVOL),'; skipped.' GOTO 10 ENDIF *** Loop over the various panels, first count them. CALL PLABU1('QUERY',NPANEL,NPL,XPL,YPL,ZPL,APL,BPL,CPL, - ICOL,IVOL,IFAIL) * Make sure that the buffer is OK. IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! DRFSOL WARNING : Unable to count the'// - ' panels for the solid.' GOTO 10 * Be sure that there is some intersect. ELSEIF(NPANEL.LE.0)THEN GOTO 10 ENDIF * Pick up one panel at the time. DO 20 IPANEL=1,NPANEL * Read plane. CALL PLABU1('READ',IPANEL,NPL,XPL,YPL,ZPL,APL,BPL,CPL, - ICOL,IVOL,IFAIL) * Make sure that the panel was well read is OK. IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! DRFSOL WARNING : Unable to read a panel'// - ' ; no drift lines for this panel.' GOTO 20 ENDIF * Compute total length. TOTAL=0 DO 30 IPL=1,NPL TOTAL=TOTAL+SQRT((XPL(1+MOD(IPL,NPL))-XPL(IPL))**2+ - (YPL(1+MOD(IPL,NPL))-YPL(IPL))**2+ - (ZPL(1+MOD(IPL,NPL))-ZPL(IPL))**2) 30 CONTINUE DTOTAL=TOTAL/NLINEV * Distribute the drift lines. TOTAL=0 IPL=1 DO 40 I=0,NLINEV-1 50 CONTINUE IF(I*DTOTAL.GE.TOTAL.AND. - I*DTOTAL.LE.TOTAL+SQRT((XPL(1+MOD(IPL,NPL))-XPL(IPL))**2+ - (YPL(1+MOD(IPL,NPL))-YPL(IPL))**2+ - (ZPL(1+MOD(IPL,NPL))-ZPL(IPL))**2))THEN XSTART=XPL(IPL)+ - (I*DTOTAL-TOTAL)*(XPL(1+MOD(IPL,NPL))-XPL(IPL))/ - SQRT((XPL(1+MOD(IPL,NPL))-XPL(IPL))**2+ - (YPL(1+MOD(IPL,NPL))-YPL(IPL))**2+ - (ZPL(1+MOD(IPL,NPL))-ZPL(IPL))**2) YSTART=YPL(IPL)+ - (I*DTOTAL-TOTAL)*(YPL(1+MOD(IPL,NPL))-YPL(IPL))/ - SQRT((XPL(1+MOD(IPL,NPL))-XPL(IPL))**2+ - (YPL(1+MOD(IPL,NPL))-YPL(IPL))**2+ - (ZPL(1+MOD(IPL,NPL))-ZPL(IPL))**2) ZSTART=ZPL(IPL)+ - (I*DTOTAL-TOTAL)*(ZPL(1+MOD(IPL,NPL))-ZPL(IPL))/ - SQRT((XPL(1+MOD(IPL,NPL))-XPL(IPL))**2+ - (YPL(1+MOD(IPL,NPL))-YPL(IPL))**2+ - (ZPL(1+MOD(IPL,NPL))-ZPL(IPL))**2) ELSE TOTAL=TOTAL+SQRT((XPL(1+MOD(IPL,NPL))-XPL(IPL))**2+ - (YPL(1+MOD(IPL,NPL))-YPL(IPL))**2+ - (ZPL(1+MOD(IPL,NPL))-ZPL(IPL))**2) IPL=IPL+1 IF(IPL.GT.NPL+1)THEN PRINT *,' !!!!!! DRFSOL WARNING : Unable to locate'// - ' side of panel from which to start a drift line.' GOTO 20 ENDIF GOTO 50 ENDIF *** Compute the drift line. CALL DLCALC(XSTART,YSTART,ZSTART,Q,ITYPE) *** Print data on this drift line if requested. IF(LLINPR)THEN CALL DLCSTF(ISTAT,STASTR,NCSTAT) WRITE(LUNOUT,'(2X,I5,2X,I5,2X,I5,2X,E15.8,2X,A)') - I,ISOL,NU,TU(NU),STASTR(1:NCSTAT) ENDIF *** Plot the drift line obtained. IF(LLINPL)CALL DLCPLT *** Invert TU in order to obtain the time distance from the sense wire. IF(LEQREV)THEN DO 80 J=1,NU TU(J)=TU(NU)-TU(J) 80 CONTINUE *** Reverse XU,YU and TU so that they can be treated as plot vectors. DO 90 J=1,INT(NU/2.0) TRANSF=TU(J) TU(J)=TU(NU-J+1) TU(NU-J+1)=TRANSF TRANSF=XU(J) XU(J)=XU(NU-J+1) XU(NU-J+1)=TRANSF TRANSF=YU(J) YU(J)=YU(NU-J+1) YU(NU-J+1)=TRANSF 90 CONTINUE *** Don't accept lines not leading to a wire. IF((ISTAT.GE.-15.AND.ISTAT.LE.-11).OR. - (ISTAT.GE.1.AND.ISTAT.LE.NWIRE).OR. - (ISTAT.GE.2*MXWIRE+1.AND.ISTAT.LE.2*MXWIRE+NSOLID)) - CALL DRFEQT(TSTEP,ISTAT) ELSE CALL DRFEQT(TSTEP,2*MXWIRE+ISOL) ENDIF * Next drift line. 40 CONTINUE * Next panel. 20 CONTINUE * Mext solid. 10 CONTINUE *** Register the amount of CPU time used for these steps. CALL TIMLOG('Making a wire drift-line plot: ') *** Plot the equal time contours. IF(LEQTPL)CALL DRFEQP *** End this page. IF(LEQTPL.OR.LLINPL)CALL GRNEXT *** And print any error messages accumulated by DRFEQ. IF(LEQTPL)CALL DRFEQE END +DECK,DRFWIR. SUBROUTINE DRFWIR(Q,ITYPE,TSTEP,LEQTPL,LEQREV,ANGMIN,ANGMAX, - LLINPL,LLINPR,NLINEW) *----------------------------------------------------------------------- * DRFWIR - Subroutine making a plot of the drift lines and the equal- * time contours in a given cell using a given gas. The actual * calculations are done in the routine DLCALC. * Lines are drawn from the wires that are specified by INDSW * VARIABLES : * (Last changed on 27/ 3/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PARAMETERS. +SEQ,CELLDATA. +SEQ,SOLIDS. +SEQ,GASDATA. +SEQ,CONSTANTS. +SEQ,PRINTPLOT. +SEQ,DRIFTLINE. CHARACTER*80 AUXSTR,STASTR INTEGER IANG,I,J,ITYPE,NLINEW,NCSTAT,NCAUX REAL RDIST,ANGLE,ANGMIN,ANGMAX,Q,TSTEP,VXMIN,VYMIN,VXMAX,VYMAX LOGICAL LEQTPL,LLINPL,LLINPR,LEQREV DOUBLE PRECISION TRANSF *** Define some formats. 1080 FORMAT('1 Table of wire drift lines :',/, - ' ===========================',//, - ' The equal time contours are separated by ',E10.3, - ' micro secs'/' Drifting ',A,', charge=',I2,//, - ' Angle wire steps drift time', - ' remarks',/, - ' [degrees] [microsec]'//) *** Identify the routine, if requested. IF(LIDENT)PRINT *,' /// ROUTINE DRFWIR ///' *** Check the the call is useful. IF(NSW.EQ.0)THEN PRINT *,' !!!!!! DRFWIR WARNING : No wires selected as', - ' starting wire for drift lines ; no plot is made.' RETURN ENDIF *** Print a heading for the table IF(LLINPR.AND.ITYPE.EQ.1)WRITE(LUNOUT,1080) TSTEP,'electrons', - NINT(Q) IF(LLINPR.AND.ITYPE.EQ.2)WRITE(LUNOUT,1080) TSTEP,'ions', - NINT(Q) *** Prepare a plot (layout, frame number etc) IF(LEQTPL.OR.LLINPL)THEN IF(ITYPE.EQ.1.AND.Q.GT.0)THEN CALL GRCELL(VXMIN,VYMIN,VXMAX,VYMAX, - 'Positron drift lines from a wire') ELSEIF(ITYPE.EQ.1)THEN CALL GRCELL(VXMIN,VYMIN,VXMAX,VYMAX, - 'Electron drift lines from a wire') ELSEIF(Q.GT.0)THEN CALL GRCELL(VXMIN,VYMIN,VXMAX,VYMAX, - 'Drift lines of positive ions from a wire') ELSE CALL GRCELL(VXMIN,VYMIN,VXMAX,VYMAX, - 'Drift lines of negative ions from a wire') ENDIF IF(GASID.NE.' ')CALL GRCOMM(2,'Gas: '//GASID) IF(LEQTPL)THEN CALL OUTFMT(TSTEP,2,AUXSTR,NCAUX,'LEFT') CALL GRCOMM(4,'Isochrone interval: '//AUXSTR(1:NCAUX)// - ' [microsec]') CALL DRFEQR ENDIF CALL GRALOG('Wire drift line plot. ') ENDIF *** Loop over all wires in the plot frame attracting electrons. IF(ITYPE.EQ.2)THEN CALL GRATTS('ION-DRIFT-LINE','POLYLINE') ELSE CALL GRATTS('E-DRIFT-LINE','POLYLINE') ENDIF DO 10 I=1,NWIRE IF(INDSW(I).EQ.0)GOTO 10 IF(LREPSK.AND.Q*E(I).LT.0)THEN IF(LLINPR)WRITE(LUNOUT,'(1X,''All angles'',I10,29X, - ''The wire repels the selected particles.'')') I GOTO 10 ENDIF IF(X(I).LE.DXMIN.OR.X(I).GE.DXMAX)GOTO 10 IF(Y(I).LE.DYMIN.OR.Y(I).GE.DYMAX)GOTO 10 *** Draw drift lines in all directions. DO 20 IANG=1,NLINEW IF(NLINEW.LE.1)THEN ANGLE=0.5*(ANGMIN+ANGMAX) ELSEIF(ABS(ANGMAX-ANGMIN-2*PI).LT.0.001)THEN ANGLE=ANGMIN+REAL(IANG-1)*(ANGMAX-ANGMIN)/REAL(NLINEW) ELSE ANGLE=ANGMIN+REAL(IANG-1)*(ANGMAX-ANGMIN)/REAL(NLINEW-1) ENDIF * Start a drift line at enough distance from the wire. IF(Q*E(I).LT.0)THEN RDIST=0.51*RTRAP*D(I) ELSE RDIST=0.51*D(I) ENDIF CALL DLCALC(X(I)+RDIST*COS(ANGLE),Y(I)+RDIST*SIN(ANGLE), - 0.0,Q,ITYPE) *** Print data on this drift line if requested. IF(LLINPR)THEN CALL DLCSTF(ISTAT,STASTR,NCSTAT) WRITE(LUNOUT,'(1X,F10.2,I10,I10,2X,E15.8,2X,A)') - 180*ANGLE/PI,I,NU,TU(NU),STASTR(1:NCSTAT) ENDIF *** Plot the drift line obtained. IF(LLINPL)CALL DLCPLT *** Invert TU in order to obtain the time distance from the sense wire. IF(LEQREV)THEN DO 80 J=1,NU TU(J)=TU(NU)-TU(J) 80 CONTINUE *** Reverse XU,YU and TU so that they can be treated as plot vectors. DO 90 J=1,INT(NU/2.0) TRANSF=TU(J) TU(J)=TU(NU-J+1) TU(NU-J+1)=TRANSF TRANSF=XU(J) XU(J)=XU(NU-J+1) XU(NU-J+1)=TRANSF TRANSF=YU(J) YU(J)=YU(NU-J+1) YU(NU-J+1)=TRANSF 90 CONTINUE *** Don't accept lines not leading to a wire. IF((ISTAT.GE.-15.AND.ISTAT.LE.-11).OR. - (ISTAT.GE.1.AND.ISTAT.LE.NWIRE).OR. - (ISTAT.GE.2*MXWIRE+1.AND.ISTAT.LE.2*MXWIRE+NSOLID)) - CALL DRFEQT(TSTEP,ISTAT) ELSE CALL DRFEQT(TSTEP,I) ENDIF 20 CONTINUE 10 CONTINUE *** Register the amount of CPU time used for these steps. CALL TIMLOG('Making a wire drift-line plot: ') *** Plot the equal time contours. IF(LEQTPL)CALL DRFEQP *** End this page. IF(LEQTPL.OR.LLINPL)CALL GRNEXT *** And print any error messages accumulated by DRFEQ. IF(LEQTPL)CALL DRFEQE END +DECK,DRFZRO. SUBROUTINE DRFZRO(QDUM,ITYPE,LLINPL,LLINPR,LEQTPL,LEQREV) *----------------------------------------------------------------------- * DRFZRO - Subroutine making a plot of the drift lines in a given cell * using a given gas starting at the E=0 points. The actual * calculations are done in the routine DLCALC. * VARIABLES : LLINPL : Plotting of drift-lines en/disabled. * LLINPR : Printing of drift-lines en/disabled. * (Last changed on 16/ 3/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PARAMETERS. +SEQ,CELLDATA. +SEQ,GASDATA. +SEQ,CONSTANTS. +SEQ,PRINTPLOT. +SEQ,DRIFTLINE. +SEQ,ZERODATA. +SEQ,BFIELD. LOGICAL LLINPR,LLINPL,LEQTPL,LEQREV REAL ZDIST,Q,ANGLE,QDUM,XZPRT,YZPRT INTEGER ITYPE,I,IQ,IANG *** Define some formats. 1010 FORMAT(2X,I5,4(1X,E12.5),2X,I5,' it hit wire ',I3) 1020 FORMAT(2X,I5,4(1X,E12.5),2X,I5,' more than ',I3,' steps') 1030 FORMAT(2X,I5,4(1X,E12.5),2X,I5,' left the drift area') 1040 FORMAT(2X,I5,4(1X,E12.5),2X,I5,' calculations abandoned') 1050 FORMAT(2X,I5,4(1X,E12.5),2X,I5,' it hit a plane') 1060 FORMAT(2X,I5,4(1X,E12.5),2X,I5,' it hit wire ',I3,',', - ' but not in the elementary cell') 1080 FORMAT('1 Table of drift lines from the E=0 points:',/, - ' =========================================',//, - ' Drifting ',A,', of both signs'// - ' Zero orientation location', - ' drift-time steps',/, - ' [degrees] [cm] [cm/degree]', - ' [microsec]',/) *** Identify the routine, if requested. IF(LIDENT)PRINT *,' /// ROUTINE DRFZRO ///' *** Check the the call is useful. IF(NZ.EQ.0.OR..NOT.ZROSET)THEN PRINT *,' !!!!!! DRFZRO WARNING : The zeros have not yet', - ' been located or there are none ; no plot is made.' RETURN ENDIF *** Print a heading for the table. IF(LLINPR.AND.ITYPE.EQ.1)WRITE(LUNOUT,1080) 'electrons' IF(LLINPR.AND.ITYPE.EQ.2)WRITE(LUNOUT,1080) 'ions' *** Prepare a plot (layout, frame number etc) IF(LLINPL)THEN CALL GRAXIS(DXMIN,DYMIN,DXMAX,DYMAX, - 'DRIFT LINES FROM THE E=0 POINTS ') CALL CELLAY(DXMIN,DYMIN,DXMAX,DYMAX) IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) IF(GASID.NE.' ')CALL GRCOMM(2,'Gas: '//GASID) IF(ITYPE.EQ.1)CALL GRCOMM(3,'Drifting: electrons') IF(ITYPE.EQ.2)CALL GRCOMM(3,'Drifting: ions') CALL GRALOG('Drift lines from the E=0 points. ') ENDIF *** Loop over all zeros in the plot frame attracting electrons. IF(ITYPE.EQ.2)THEN CALL GRATTS('ION-DRIFT-LINE','POLYLINE') ELSE CALL GRATTS('E-DRIFT-LINE','POLYLINE') ENDIF DO 10 I=1,NZ IF(XZ(I).LE.DXMIN.OR.XZ(I).GE.DXMAX.OR. - YZ(I).LE.DYMIN.OR.YZ(I).GE.DYMAX)GOTO 10 *** Loop over the charges. DO 20 IQ=-1,1,2 Q=REAL(IQ) *** Draw drift lines in both directions. ZDIST=1.0E-4*(1+MAX(ABS(XZ(I)),ABS(YZ(I)))) DO 30 IANG=0,1 IF(Q.LT.0)THEN ANGLE=PZ(I)+REAL(IANG)*PI ELSE ANGLE=PZ(I)+(REAL(IANG)-0.5)*PI ENDIF * Start a drift line at enough distance from the wire. CALL DLCALC(XZ(I)+ZDIST*COS(ANGLE), - YZ(I)+ZDIST*SIN(ANGLE),0.0,Q,ITYPE) *** Print data on this drift line if requested. IF(LLINPR)THEN XZPRT=XZ(I) YZPRT=YZ(I) IF(POLAR)CALL CFMRTP(XZPRT,YZPRT,XZPRT,YZPRT,1) IF(ISTAT.EQ.-1)WRITE(LUNOUT,1030) - I,180*ANGLE/PI,XZPRT,YZPRT,REAL(TU(NU)),NU IF(ISTAT.EQ.-2)WRITE(LUNOUT,1020) - I,180*ANGLE/PI,XZPRT,YZPRT,REAL(TU(NU)),NU,MXLIST IF(ISTAT.EQ.-3)WRITE(LUNOUT,1040) - I,180*ANGLE/PI,XZPRT,YZPRT,REAL(TU(NU)),NU IF(ISTAT.EQ.-4)WRITE(LUNOUT,1050) - I,180*ANGLE/PI,XZPRT,YZPRT,REAL(TU(NU)),NU IF(ISTAT.GT.0.AND.ISTAT.LE.MXWIRE) WRITE(LUNOUT,1010) - I,180*ANGLE/PI,XZPRT,YZPRT,REAL(TU(NU)),NU,ISTAT IF(ISTAT.GT.MXWIRE) WRITE(LUNOUT,1060) - I,180*ANGLE/PI,XZPRT,YZPRT,REAL(TU(NU)),NU,ISTAT-MXWIRE ENDIF *** Plot the drift line obtained. IF(POLAR)CALL CF2RTC(XU,YU,XU,YU,NU) IF(NU.GT.1.AND.LLINPL)CALL GPL2(NU,XU,YU) 30 CONTINUE 20 CONTINUE 10 CONTINUE *** Register the amount of CPU time used for these steps. CALL TIMLOG('Drift-lines from the E=0 points: ') *** End this page. IF(LLINPL)CALL GRNEXT END +DECK,DRFEQT. SUBROUTINE DRFEQT(TSTEP,ISTEQT) *----------------------------------------------------------------------- * DRFEQT - The main routine (DRFEQT) accumulates equal drift time data * DRFEQP which is plotted as a set of contours in the entry DRFEQP, * DRFEQR DRFEQR resets the (error) counters used in the rest and * DRFEQE finally DRFEQE prints the error messages. * VARIABLES : NSTORE : Number of drift lines currently stored * NFAIL : Registers the number of failures. * XPL,YPL,ZPL : Used for sorting + plotting. * IXYPL : Drift line which gave this point. * XYT : Stores all equal time contours. * BREAK : .TRUE. if the segment is interrupted by a * drift line and if it is too long. * FRSTBR : The BREAK flag for the first segment. * (Last changed on 19/ 6/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,DRIFTLINE. +SEQ,CELLDATA. +SEQ,SOLIDS. +SEQ,PRINTPLOT. +SEQ,PARAMETERS. +SEQ,GRAPHICS. REAL TSTEP,TSTREF INTEGER IXYT(MXLINE),NXYT(MXLINE),NFAIL(4),IXYPL(MXLINE+1),IOS, - NWORD,INPCMP,NCMEMB,NCREM,INEXT,NWRT,IWRT,IFAIL,IWIRE,IEQT, - IPL,IBEGIN,ISTORE,JSTORE,NCFILE,JEQ,J1,J2,I,NPL,ISTEP, - NSTORE,NSTEP,JSTART,IAUX,IMAX,ISTEQT,NCSTAT DOUBLE PRECISION DIVDF2,XYT(MXLINE,0:MXEQUT+1,3),XPL(MXLINE+1), - YPL(MXLINE+1),ZPL(MXLINE+1),APL(MXLINE+1),XCOG,YCOG, - XAUX,YAUX,ZAUX,AAUX,SXX,SXY,SYY,CT,ST,DISTOT,DISMAX, - EPSX,EPSY,EPSZ LOGICAL BREAK,FRSTBR,CROSSD,EXMEMB,CIRCLE,DONE(MXLINE) CHARACTER*(MXINCH) STRING CHARACTER*(MXNAME) FILE CHARACTER*80 STATUS CHARACTER*29 REMARK CHARACTER*8 TIME,DATE,MEMBER EXTERNAL CROSSD,DIVDF2,INPCMP +SELF,IF=SAVE. SAVE XYT,IXYT,NXYT,NSTORE,NFAIL,TSTREF +SELF. DATA NSTORE/0/,NFAIL/0,0,0,0/,TSTREF/-1.0/ *** Main routine, identify if requested. IF(LIDENT)PRINT *,' /// ROUTINE DRFEQT ///' * Check that the drift line has enough steps. IF(NU.LT.3)RETURN * Increment the number of stored lines if there is still space. IF(NSTORE.GE.MXLINE)THEN NFAIL(4)=NFAIL(4)+1 RETURN ENDIF NSTORE=NSTORE+1 * Store the step size. TSTREF=TSTEP * Find the number of points to be stored, limited by MXEQUT. NSTEP=MIN(INT(TU(NU)/TSTEP),MXEQUT) * Interpolate (time,position) at start, end and regular t intervals. CALL PLACO3(XU(1),YU(1),ZU(1), - XYT(NSTORE,0,1),XYT(NSTORE,0,2),XYT(NSTORE,0,3)) DO 10 ISTEP=1,NSTEP CALL PLACO3( - DIVDF2(XU,TU,NU,DBLE(ISTEP*TSTEP),1), - DIVDF2(YU,TU,NU,DBLE(ISTEP*TSTEP),1), - DIVDF2(ZU,TU,NU,DBLE(ISTEP*TSTEP),1), - XYT(NSTORE,ISTEP,1),XYT(NSTORE,ISTEP,2),XYT(NSTORE,ISTEP,3)) 10 CONTINUE CALL PLACO3(XU(NU),YU(NU),ZU(NU),XYT(NSTORE,NSTEP+1,1), - XYT(NSTORE,NSTEP+1,2),XYT(NSTORE,NSTEP+1,3)) IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DRFEQT DEBUG : Found '', - I4,'' points for drift line '',I4)') NSTEP,NSTORE * Store the number of points on this spline and the d.l. return code. NXYT(NSTORE)=NSTEP IXYT(NSTORE)=ISTEQT * Keep track of the largest (unconstrained by MXEQUT) # of contours. NFAIL(3)=MAX(NFAIL(3),INT(TU(NU)/TSTEP)) RETURN *** Now plot the data: entry DRFEQP. ENTRY DRFEQP IF(LIDENT)PRINT *,' /// ENTRY DRFEQP ///' IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DRFEQP DEBUG : Drawing '', - I4,'' contours, '',I4,'' drift lines.''/ - 26X,''Connection threshold: '',F10.3/ - 26X,''Aspect ratio threshold: '',F10.3/ - 26X,''Loop closing threshold: '',F10.3/ - 26X,''Sort contours: '',L10/ - 26X,''Check for crossings: '',L10/ - 26X,''Mark isochrone points: '',L10)') - NFAIL(3),NSTORE,EQTTHR,EQTASP,EQTCLS,LEQSRT,LEQCRS,LEQMRK ** Switch to plotting mode for equal time contours. CALL GRATTS('ISOCHRONES','POLYLINE') CALL GRATTS('ISOCHRONES','POLYMARKER') * Set tolerances. EPSX=1D-6*ABS(USERX1-USERX0) EPSY=1D-6*ABS(USERY1-USERY0) IF(EPSX.LT.1D-6)EPSX=1D-6 IF(EPSY.LT.1D-6)EPSY=1D-6 EPSZ=1D-6 CALL EPSSET('SET',EPSX,EPSY,EPSZ) ** Loop over the equal time contours. DO 1000 IEQT=1,NFAIL(3) * Loop over the wires and over the solids. DO 1010 IWIRE=-20,2*MXWIRE+NSOLID IF((IWIRE.GT.-20.AND.IWIRE.LT.-15).OR. - (IWIRE.GT.-11.AND.IWIRE.LT.1).OR. - (IWIRE.GT.NWIRE.AND.IWIRE.LE.2*MXWIRE))GOTO 1010 * Initial number of stored points. NPL=0 * Loop over the drift lines, picking up the points when OK. DO 1020 ISTORE=1,NSTORE * Reject any undesirable combinations. IF(IXYT(ISTORE).NE.IWIRE.OR.IEQT.GT.NXYT(ISTORE))GOTO 1020 * Copy the data of this contour and this wire into the plot vector. NPL=NPL+1 XPL(NPL)=XYT(ISTORE,IEQT,1) YPL(NPL)=XYT(ISTORE,IEQT,2) ZPL(NPL)=XYT(ISTORE,IEQT,3) IXYPL(NPL)=ISTORE 1020 CONTINUE ** Plot the contour, skip if there are no points. IF(NPL.EQ.0)GOTO 1010 * Skip sorting if not requested, if using markers, if only 1 point. IF((.NOT.LEQSRT).OR.LEQMRK.OR.NPL.EQ.1)THEN CIRCLE=.FALSE. GOTO 1340 ENDIF * Sort contours on angle, first compute centre of gravity. XCOG=0 YCOG=0 DO 1210 J1=1,NPL XCOG=XCOG+XPL(J1) YCOG=YCOG+YPL(J1) 1210 CONTINUE XCOG=XCOG/REAL(NPL) YCOG=YCOG/REAL(NPL) * Compute angles wrt to the centre of gravity and principal axes. SXX=0 SXY=0 SYY=0 DO 1220 J1=1,NPL SXX=SXX+(XPL(J1)-XCOG)**2 SXY=SXY+(XPL(J1)-XCOG)*(YPL(J1)-YCOG) SYY=SYY+(YPL(J1)-YCOG)**2 1220 CONTINUE CT=COS(0.5*ATAN2(2*SXY,SXX-SYY)) ST=SIN(0.5*ATAN2(2*SXY,SXX-SYY)) * Evaluate dispersions around the principal axes. SXX=0 SYY=0 DO 1230 J1=1,NPL SXX=SXX+ABS(+CT*(XPL(J1)-XCOG)+ST*(YPL(J1)-YCOG)) SYY=SYY+ABS(-ST*(XPL(J1)-XCOG)+CT*(YPL(J1)-YCOG)) 1230 CONTINUE * Decide whether this is more linear or more circular. IF( ABS(SXX).GT.EQTASP*ABS(SYY).OR. - ABS(SYY).GT.EQTASP*ABS(SXX))THEN CIRCLE=.FALSE. ELSE CIRCLE=.TRUE. ENDIF * Set a sorting coordinate accordingly. DO 1240 J1=1,NPL IF(CIRCLE)THEN APL(J1)=ATAN2(YPL(J1)-YCOG,XPL(J1)-XCOG) ELSE APL(J1)=CT*(XPL(J1)-XCOG)+ST*(YPL(J1)-YCOG) ENDIF 1240 CONTINUE * Sort the points (bubble sort). DO 1250 J1=1,NPL DO 1260 J2=J1+1,NPL IF(APL(J2).LT.APL(J1))THEN IAUX=IXYPL(J1) XAUX=XPL(J1) YAUX=YPL(J1) ZAUX=ZPL(J1) AAUX=APL(J1) IXYPL(J1)=IXYPL(J2) XPL(J1)=XPL(J2) YPL(J1)=YPL(J2) ZPL(J1)=ZPL(J2) APL(J1)=APL(J2) IXYPL(J2)=IAUX XPL(J2)=XAUX YPL(J2)=YAUX ZPL(J2)=ZAUX APL(J2)=AAUX ENDIF 1260 CONTINUE 1250 CONTINUE * For circles, pperhaps add the first point to the end of the list. IF(CIRCLE)THEN * Compute breakpoint, total distance and maximum distance. DISTOT=0 DISMAX=SQRT((XPL(1)-XPL(NPL))**2+(YPL(1)-YPL(NPL))**2) IMAX=1 DO 1270 J1=2,NPL DISTOT=DISTOT+SQRT((XPL(J1)-XPL(J1-1))**2+ - (YPL(J1)-YPL(J1-1))**2) IF(DISMAX.LT.SQRT((XPL(J1)-XPL(J1-1))**2+ - (YPL(J1)-YPL(J1-1))**2))THEN DISMAX=SQRT((XPL(J1)-XPL(J1-1))**2+ - (YPL(J1)-YPL(J1-1))**2) IMAX=J1 ENDIF 1270 CONTINUE * If a true loop, close it. IF(DISMAX.LT.EQTCLS*DISTOT)THEN NPL=NPL+1 XPL(NPL)=XPL(1) YPL(NPL)=YPL(1) ZPL(NPL)=ZPL(1) IXYPL(NPL)=IXYPL(1) * Otherwise shift the points to make a line. ELSEIF(IMAX.GT.1)THEN DO 1280 J1=1,NPL DONE(J1)=.FALSE. 1280 CONTINUE 1290 CONTINUE DO 1300 J1=1,NPL IF(.NOT.DONE(J1))THEN JSTART=J1 GOTO 1310 ENDIF 1300 CONTINUE GOTO 1330 1310 CONTINUE J2=JSTART J1=1+MOD(J2+IMAX-2,NPL) XAUX=XPL(J2) YAUX=YPL(J2) ZAUX=ZPL(J2) IAUX=IXYPL(J2) DO 1320 I=1,NPL XPL(J2)=XPL(J1) YPL(J2)=YPL(J1) ZPL(J2)=ZPL(J1) IXYPL(J2)=IXYPL(J1) DONE(J2)=.TRUE. IF(J1.EQ.JSTART)THEN XPL(J2)=XAUX YPL(J2)=YAUX ZPL(J2)=ZAUX IXYPL(J2)=IAUX DONE(J2)=.TRUE. GOTO 1290 ENDIF J2=J1 J1=1+MOD(J2+IMAX-2,NPL) 1320 CONTINUE 1330 CONTINUE CIRCLE=.FALSE. ELSE CIRCLE=.FALSE. ENDIF ENDIF ** Plot this contour. 1340 CONTINUE * Simply mark the contours if this was requested. IF(LEQMRK)THEN DO 1350 I=1,NPL XAUX=FPROJ(1,1)*XPL(I)+FPROJ(2,1)*YPL(I)+ - ZPL(I)*FPROJA/FPROJN YAUX=FPROJ(1,2)*XPL(I)+FPROJ(2,2)*YPL(I)+ - ZPL(I)*FPROJB/FPROJN ZAUX=FPROJ(1,3)*XPL(I)+FPROJ(2,3)*YPL(I)+ - ZPL(I)*FPROJC/FPROJN XPL(I)=XAUX YPL(I)=YAUX ZPL(I)=ZAUX 1350 CONTINUE CALL PLAGPM(NPL,XPL,YPL,ZPL) GOTO 1010 ENDIF ** Regular plotting. IBEGIN=1 FRSTBR=.FALSE. DO 1070 IPL=1,NPL-1 BREAK=.FALSE. * Reject contour segments which are long compared with AREA. IF( ABS(XPL(IPL+1)-XPL(IPL)).GT.(USERX1-USERX0)*EQTTHR.OR. - ABS(YPL(IPL+1)-YPL(IPL)).GT.(USERY1-USERY0)*EQTTHR) - BREAK=.TRUE. * Set the BREAK flag if it crosses some stored drift line segment. IF(LEQCRS.AND..NOT.BREAK)THEN DO 1080 JSTORE=1,NSTORE DO 1090 JEQ=0,MXEQUT IF(JEQ.GT.NXYT(JSTORE))GOTO 1090 IF((IXYPL(IPL).EQ.JSTORE.OR.IXYPL(IPL+1).EQ.JSTORE).AND. - (JEQ.EQ.IEQT.OR.JEQ+1.EQ.IEQT))GOTO 1090 BREAK=CROSSD( - XYT(JSTORE,JEQ ,1),XYT(JSTORE,JEQ ,2), - XYT(JSTORE,JEQ+1,1),XYT(JSTORE,JEQ+1,2), - XPL( IPL ),YPL( IPL ), - XPL( IPL+1 ),YPL( IPL+1 )) IF(BREAK)GOTO 1100 1090 CONTINUE 1080 CONTINUE 1100 CONTINUE ENDIF * If there has been a break, plot what we have already. IF(BREAK)THEN DO 1110 I=IBEGIN,IPL XAUX=FPROJ(1,1)*XPL(I)+FPROJ(2,1)*YPL(I)+ - ZPL(I)*FPROJA/FPROJN YAUX=FPROJ(1,2)*XPL(I)+FPROJ(2,2)*YPL(I)+ - ZPL(I)*FPROJB/FPROJN ZAUX=FPROJ(1,3)*XPL(I)+FPROJ(2,3)*YPL(I)+ - ZPL(I)*FPROJC/FPROJN XPL(I)=XAUX YPL(I)=YAUX ZPL(I)=ZAUX 1110 CONTINUE IF(IPL-IBEGIN.GE.1)THEN CALL PLAGPL(IPL-IBEGIN+1,XPL(IBEGIN),YPL(IBEGIN), - ZPL(IBEGIN)) ELSEIF(IBEGIN.NE.1.OR..NOT.CIRCLE)THEN CALL PLAGPM(1,XPL(IBEGIN),YPL(IBEGIN),ZPL(IBEGIN)) ELSEIF(IBEGIN.EQ.1)THEN FRSTBR=.TRUE. ENDIF IBEGIN=IPL+1 ENDIF 1070 CONTINUE * Plot the remainder; if there is a break, put a * if FRSTBR is on. DO 1120 I=IBEGIN,NPL XAUX=FPROJ(1,1)*XPL(I)+FPROJ(2,1)*YPL(I)+ZPL(I)*FPROJA/FPROJN YAUX=FPROJ(1,2)*XPL(I)+FPROJ(2,2)*YPL(I)+ZPL(I)*FPROJB/FPROJN ZAUX=FPROJ(1,3)*XPL(I)+FPROJ(2,3)*YPL(I)+ZPL(I)*FPROJC/FPROJN XPL(I)=XAUX YPL(I)=YAUX ZPL(I)=ZAUX 1120 CONTINUE IF(.NOT.BREAK.AND.NPL-IBEGIN.GT.0)THEN CALL PLAGPL(NPL-IBEGIN+1,XPL(IBEGIN),YPL(IBEGIN), - ZPL(IBEGIN)) ELSEIF((FRSTBR.OR..NOT.CIRCLE).AND.IBEGIN.EQ.NPL)THEN CALL PLAGPM(1,XPL(IBEGIN),YPL(IBEGIN),ZPL(IBEGIN)) ENDIF * Continue with the next combination of wire number and time. 1010 CONTINUE 1000 CONTINUE * Reset tolerances. CALL EPSSET('RESET',EPSX,EPSY,EPSZ) ** Log this plot. CALL TIMLOG('Plotting equal time contours: ') RETURN *** Write out the data: entry DRFEQW. ENTRY DRFEQW * Identify the entry. IF(LIDENT)PRINT *,' /// ENTRY DRFEQW ///' * Check contour data is present. IF(NSTORE.LE.0.OR.TSTREF.LE.0.0)THEN PRINT *,' !!!!!! DRFEQW WARNING : No equal time data in'// - ' store; no dataset written.' RETURN ENDIF * Warn if the error codes are non-zero. IF(NFAIL(1).GT.0.OR.NFAIL(2).GT.0.OR. - NFAIL(3).GT.0.OR.NFAIL(4).GT.0)THEN PRINT *,' ------ DRFEQW MESSAGE : Error messages have'// - ' been issued for the contours to be written out.' ENDIF * Initial dataset description. FILE=' ' NCFILE=1 MEMBER='< none >' NCMEMB=8 REMARK='none' NCREM=4 * Make sure there is at least one argument. CALL INPNUM(NWORD) IF(NWORD.EQ.1)THEN PRINT *,' !!!!!! DRFEQW WARNING : WRITE takes at least one', - ' argument (a dataset name); data will not be written.' RETURN * Check whether keywords have been used. ELSEIF(INPCMP(2,'D#ATASET')+INPCMP(2,'R#EMARK').NE.0)THEN INEXT=2 DO 1560 I=2,NWORD IF(I.LT.INEXT)GOTO 1560 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 1560 CONTINUE * Otherwise the string is interpreted as a file name (+ member name). ELSE CALL INPSTR(2,2,STRING,NCFILE) FILE=STRING IF(NWORD.GE.3)THEN CALL INPSTR(3,3,STRING,NCMEMB) MEMBER=STRING ENDIF IF(NWORD.GE.4)THEN CALL INPSTR(4,NWORD,STRING,NCREM) REMARK=STRING ENDIF ENDIF * Print error messages. CALL INPERR IF(NCFILE.GT.MXNAME)PRINT *,' !!!!!! DRFEQW WARNING : The file', - ' name is truncated to MXNAME (=',MXNAME,') characters.' IF(NCMEMB.GT.8)PRINT *,' !!!!!! DRFEQW WARNING : The member', - ' name is shortened to ',MEMBER,', first 8 characters.' IF(NCREM.GT.29)PRINT *,' !!!!!! DRFEQW 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),'ISOCHRON',EXMEMB) IF(JEXMEM.EQ.2.AND.EXMEMB)THEN PRINT *,' ------ DRFEQW MESSAGE : A copy of the member'// - ' exists; new member will be appended.' ELSEIF(JEXMEM.EQ.3.AND.EXMEMB)THEN PRINT *,' !!!!!! DRFEQW 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 *,' ++++++ DRFEQW 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 *,' !!!!!! DRFEQW WARNING : Opening '//FILE(1:NCFILE), - ' failed ; the isochrones will not be written.' RETURN ENDIF CALL DSNLOG(FILE,'Isochrones','Sequential','Write ') IF(LDEBUG)PRINT *,' ++++++ DRFEQW DEBUG : Dataset '// - FILE(1:NCFILE)//' opened on unit 12 for sequential write.' * Now write a heading record to the file. CALL DATTIM(DATE,TIME) WRITE(STRING,'(''% Created '',A8,'' At '',A8,1X,A8,'' ISOCHRON'', - 1X,''"'',A29,''"'')') DATE,TIME,MEMBER,REMARK WRITE(12,'(A80)',IOSTAT=IOS,ERR=2010) STRING WRITE(12,'(2X,''Note: The coordinates listed below'', - '' have been re-converted''/2X,''from the internal'', - '' representation in which they were stored.''/)', - IOSTAT=IOS,ERR=2010) * Loop over the wires and the drift lines. DO 1500 IEQT=1,NFAIL(3) DO 1510 IWIRE=-20,2*MXWIRE+NSOLID IF((IWIRE.GT.-20.AND.IWIRE.LT.-15).OR. - (IWIRE.GT.-11.AND.IWIRE.LT.1).OR. - (IWIRE.GT.NWIRE.AND.IWIRE.LE.2*MXWIRE))GOTO 1510 * Initial number of stored points. NWRT=0 * Loop over the drift lines, picking up the points when OK. DO 1520 ISTORE=1,NSTORE * Reject any undesirable combinations. IF(IXYT(ISTORE).NE.IWIRE.OR.IEQT.GT.NXYT(ISTORE))GOTO 1520 * Copy the data of this contour and this wire into the output vector. NWRT=NWRT+1 XPL(NWRT)=XYT(ISTORE,IEQT,1) YPL(NWRT)=XYT(ISTORE,IEQT,2) ZPL(NWRT)=XYT(ISTORE,IEQT,3) * Transform back to the original coordinate system. XAUX=FPROJ(1,1)*XPL(NWRT)+FPROJ(2,1)*YPL(NWRT)+ - ZPL(NWRT)*FPROJA/FPROJN YAUX=FPROJ(1,2)*XPL(NWRT)+FPROJ(2,2)*YPL(NWRT)+ - ZPL(NWRT)*FPROJB/FPROJN ZAUX=FPROJ(1,3)*XPL(NWRT)+FPROJ(2,3)*YPL(NWRT)+ - ZPL(NWRT)*FPROJC/FPROJN XPL(NWRT)=XAUX YPL(NWRT)=YAUX ZPL(NWRT)=ZAUX 1520 CONTINUE * Header for this combination. CALL DLCSTF(IWIRE,STATUS,NCSTAT) WRITE(12,'('' Drift line status: '',A/ - '' Drift time: '',E12.5,'' [microsec].''/ - '' Data points: '',I12/)',IOSTAT=IOS,ERR=2010) - STATUS(1:NCSTAT),TSTREF*IEQT,NWRT IF(NWRT.GT.0)THEN * Write out the list of points. IF(POLAR)THEN WRITE(12,'(11X,''r [cm]'',4X,''phi [degrees]'',11X, - ''z [cm]''/)',IOSTAT=IOS,ERR=2010) ELSE WRITE(12,'(11X,''x [cm]'',11X,''y [cm]'',11X, - ''z [cm]''/)',IOSTAT=IOS,ERR=2010) ENDIF WRITE(12,'((3(2X,E15.8)))',IOSTAT=IOS,ERR=2010) - (XPL(IWRT),YPL(IWRT),ZPL(IWRT),IWRT=1,NWRT) WRITE(12,'('' '')',IOSTAT=IOS,ERR=2010) ENDIF * Continue with the next combination of wire number and time. 1510 CONTINUE 1500 CONTINUE * Close the file. CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) * Log writing. CALL TIMLOG('Writing out equal time contours: ') RETURN *** Print error messages, entry DRFEQE. ENTRY DRFEQE IF(LIDENT)PRINT *,' /// ENTRY DRFEQE ///' IF(NFAIL(1).NE.0)PRINT *,' ###### DRFEQT ERROR : Preparing'// - ' an equal time interpolation failed ',NFAIL(1),' times.' IF(NFAIL(2).NE.0)PRINT *,' ###### DRFEQT ERROR : Obtaining'// - ' an equal time interpolation failed ',NFAIL(2),' times.' * Print some error message in case of memory overflow. IF(NFAIL(3).GT.0)THEN PRINT *,' !!!!!! DRFEQT WARNING : With the time interval'// - ' you specified, ',NFAIL(3),' contours are generated.' PRINT *,' Increase MXEQUT by this'// - ' value and recompile, to have them all plotted.' ENDIF IF(NFAIL(4).GT.0)THEN PRINT *,' !!!!!! DRFEQT WARNING : MXLINE is smaller than'// - ' the number of drift lines (',NFAIL(4),') to be' PRINT *,' stored for eqaul time'// - ' contour plotting, increase MXLINE by this value.' ENDIF RETURN *** Reset the drift lines: entry DRFEQR. ENTRY DRFEQR IF(LIDENT)PRINT *,' /// ENTRY DRFEQR ///' IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DRFEQR DEBUG : Reset of'', - '' isochrone buffer.'')') NSTORE=0 DO 1900 I=1,4 NFAIL(I)=0 1900 CONTINUE RETURN *** Handle the error conditions. 2010 CONTINUE PRINT *,' ###### DRFEQW ERROR : Error while writing'// - ' to ',FILE(1:NCFILE),' via unit 12 ; no contours written.' CALL INPIOS(IOS) CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) RETURN 2030 CONTINUE PRINT *,' ###### DRFEQW ERROR : Dataset '//FILE(1:NCFILE)// - ' unit 12 cannot be closed ; results not predictable' CALL INPIOS(IOS) END +DECK,DRFGRA. SUBROUTINE DRFGRA *----------------------------------------------------------------------- * DRFGRA - Subroutine that uses interactive graphics to do some * drift-line calculations. * (Last changed on 24/ 4/92.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,DRIFTLINE. +SEQ,CELLDATA. +SEQ,PARAMETERS. +SEQ,CONSTANTS. +SEQ,PRINTPLOT. CHARACTER*80 AUXSTR CHARACTER*200 CHSTR REAL XPL(2),YPL(2),XPOS,YPOS,Q,XSING,YSING,ANGLE INTEGER ITYPE LOGICAL STDSTR EXTERNAL STDSTR,INPCMP,INPTYP +SELF,IF=SAVE. SAVE NRETRY SAVE ICPET,ILPET1,ILPET2,IVPET,IPPET SAVE IWKLC,IWKCH,IWKVL,IWKPK,IWK SAVE IDEVLC,IDEVCH,IDEVVL,IDEVPK +SELF. *** Initial parameter values, number of retries. DATA NRETRY/2/ * Promp/echo types. DATA ICPET/1/, ILPET1/1/, ILPET2/4/, IVPET/1/, IPPET/1/ * Device. DATA IDEVLC/1/, IDEVCH/1/, IDEVVL/1/, IDEVPK/1/ *** Check we are in interactive mode. IF(.NOT.STDSTR('INPUT'))THEN PRINT *,' !!!!!! DRFGRA WARNING : This instruction can'// - ' only be carried out in interactive mode.' RETURN ENDIF *** Make sure the level of GKS is sufficient. CALL GQLVKS(IERR,ILEV) IF(ILEV.LT.4)THEN PRINT *,' !!!!!! DRFGRA WARNING : The program has been'// - ' linked with a GKS of too low a level.' RETURN ENDIF *** Find an in/out workstation, first check operating state. CALL GQOPS(IOPSTA) * No active workstations. IF(IOPSTA.LT.3)THEN PRINT *,' !!!!!! DRFGRA WARNING : No active workstations'// - ' ; not executed.' RETURN ENDIF * Determine number of active workstations. CALL GQACWK(0,IERR,NACT,IWK) IWKREQ=-1 DO 2 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 2 CONTINUE * Issue an string request to an input workstation. IF(IWKREQ.EQ.-1)THEN PRINT *,' !!!!!! DRFGRA WARNING : No active workstations'// - ' with in/out facilities ; not executed.' RETURN ENDIF * Set default parameters. IWKLC=IWKREQ IWKCH=IWKREQ IWKVL=IWKREQ IWKPK=IWKREQ IWK=IWKREQ * Debugging output. IF(LDEBUG)PRINT *,' ++++++ DRFGRA DEBUG : Default ws for'// - ' this command is ',IWKREQ *** Initial parameters. Q=-1.0 ITYPE=1 *** Decode the argument string, if present. CALL INPNUM(NWORD) INEXT=2 DO 10 I=2,NWORD IF(INEXT.GT.I)GOTO 10 * Prompt echo type for choice input. IF(INPCMP(I,'CH#OICE-PET').NE.0)THEN IF(NWORD.LT.I+1.OR.INPTYP(I+1).NE.1)THEN CALL INPMSG(I,'No prompt/echo type specified.') ELSE CALL INPCHK(I+1,1,IFAIL1) CALL INPRDI(I+1,ICPET,ICPET) INEXT=I+2 ENDIF * Prompt echo type for locator input. ELSEIF(INPCMP(I,'LOC#ATOR-PET').NE.0)THEN IF(NWORD.LT.I+1.OR.INPTYP(I+1).NE.1.OR. - INPTYP(I+2).NE.1)THEN CALL INPMSG(I,'Two prompt/echo types needed. ') ELSE CALL INPCHK(I+1,1,IFAIL1) CALL INPRDI(I+1,ILPET1,ILPET1) CALL INPCHK(I+2,1,IFAIL2) CALL INPRDI(I+2,ILPET2,ILPET2) INEXT=I+3 ENDIF * Prompt echo type for valuator input. ELSEIF(INPCMP(I,'VAL#UATOR-PET').NE.0)THEN IF(NWORD.LT.I+1.OR.INPTYP(I+1).NE.1)THEN CALL INPMSG(I,'No prompt/echo type specified.') ELSE CALL INPCHK(I+1,1,IFAIL1) CALL INPRDI(I+1,IVPET,IVPET) INEXT=I+2 ENDIF * Prompt echo type for pick input. ELSEIF(INPCMP(I,'PICK-PET').NE.0)THEN IF(NWORD.LT.I+1.OR.INPTYP(I+1).NE.1)THEN CALL INPMSG(I,'No prompt/echo type specified.') ELSE CALL INPCHK(I+1,1,IFAIL1) CALL INPRDI(I+1,IPPET,IPPET) INEXT=I+2 ENDIF * Workstation. ELSEIF(INPCMP(I,'W#ORK-ST#ATION').NE.0)THEN IF(NWORD.LT.I+1)THEN CALL INPMSG(I,'No workstation id specified. ') ELSE CALL INPSTR(I+1,I+1,AUXSTR,NCAUX) CALL GRQIWK(AUXSTR(1:NCAUX),IWK,IFAIL) IF(IFAIL.NE.0)THEN CALL INPMSG(I+1,'Not a valid workstation name. ') ELSE IWKCH=IWK IWKLC=IWK IWKVL=IWK IWKPK=IWK ENDIF INEXT=I+2 ENDIF * Choice device. ELSEIF(INPCMP(I,'CH#OICE-DEV#ICE').NE.0)THEN IF(NWORD.LT.I+1.OR.INPTYP(I+1).NE.1)THEN CALL INPMSG(I,'No device has been specified. ') ELSE CALL INPCHK(I+1,1,IFAIL1) CALL INPRDI(I+1,IDEVCH,1) INEXT=I+2 ENDIF * Locator device. ELSEIF(INPCMP(I,'LOC#ATOR-DEV#ICE').NE.0)THEN IF(NWORD.LT.I+1.OR.INPTYP(I+1).NE.1)THEN CALL INPMSG(I,'No device has been specified. ') ELSE CALL INPCHK(I+1,1,IFAIL1) CALL INPRDI(I+1,IDEVLC,1) INEXT=I+2 ENDIF * Pick device. ELSEIF(INPCMP(I,'PICK-DEV#ICE').NE.0)THEN IF(NWORD.LT.I+1.OR.INPTYP(I+1).NE.1)THEN CALL INPMSG(I,'No device has been specified. ') ELSE CALL INPCHK(I+1,1,IFAIL1) CALL INPRDI(I+1,IDEVPK,1) INEXT=I+2 ENDIF * Valuator device. ELSEIF(INPCMP(I,'VAL#UATOR-DEV#ICE').NE.0)THEN IF(NWORD.LT.I+1.OR.INPTYP(I+1).NE.1)THEN CALL INPMSG(I,'No device has been specified. ') ELSE CALL INPCHK(I+1,1,IFAIL1) CALL INPRDI(I+1,IDEVVL,1) INEXT=I+2 ENDIF * Number of retries. ELSEIF(INPCMP(I,'RETR#IES').NE.0)THEN IF(NWORD.LT.I+1.OR.INPTYP(I+1).NE.1)THEN CALL INPMSG(I,'Number of retries absent. ') ELSE CALL INPCHK(I+1,1,IFAIL1) CALL INPRDI(I+1,NRETRY,5) INEXT=I+2 ENDIF * Unknown argument. ELSE CALL INPMSG(I,'Not a known keyword. ') ENDIF 10 CONTINUE CALL INPERR * Debugging output. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DRFGRA DEBUG : Flags'', - '' currently in effect:''// - '' Choice : PET='',I2,'' , device='',I2,'', ws='',I2/ - '' Locator : PET='',I2,1X,I2,'', device='',I2,'', ws='',I2/ - '' Pick : PET='',I2,'' , device='',I2,'', ws='',I2/ - '' Valuator: PET='',I2,'' , device='',I2,'', ws='',I2// - '' Number of retries: '',I2/)') - ICPET,IDEVCH,IWKCH,ILPET1,ILPET2,IDEVLC,IWKLC, - IPPET,IDEVPK,IWKPK,IVPET,IDEVVL,IWKVL,NRETRY *** Check the workstation and obtain some information about it. CALL GQWKS(IWK,IERR,ISTATE) IF(IERR.NE.0.OR.ISTATE.NE.1)THEN PRINT *,' !!!!!! DRFGRA WARNING : The workstation over'// - ' which this command is run is not active.' RETURN ENDIF CALL GQWKC(IWK,IERR,ICONID,IWKTYP) IF(IERR.NE.0)THEN PRINT *,' !!!!!! DRFGRA WARNING : Unable to determine the'// - ' workstation type ; command not executed.' RETURN ENDIF CALL GQWKCA(IWKTYP,IERR,IWKCAT) IF(IERR.NE.0.OR.IWKCAT.NE.2)THEN PRINT *,' !!!!!! DRFGRA WARNING : The workstation over'// - ' which this command is run' PRINT *,' doesn''t have both'// - ' output and input facilities.' IF(LDEBUG)PRINT *,' ++++++ DRFGRA DEBUG : Category'// - ' of WS ',IWK,' is ',IWKCAT,' type is ',IWKTYP,'.' RETURN ENDIF CALL GQDSP(IWKTYP,ISTAT,IUNIT,RX,RY,LX,LY) IF(ISTAT.NE.0)THEN PRINT *,' !!!!!! DRFGRA WARNING : Unable to determine the'// - ' workstation window size ; command not executed.' RETURN ENDIF *** And use them to set the various display areas. IF(RX.LT.1.4*RY)RY=RX/1.4 * Locator. XLMIN=0.01*RX XLMAX=0.99*RY YLMIN=0.01*RY YLMAX=0.99*RY * Choice. XCMIN=0.91*RY XCMAX=0.99*RX YCMIN=0.10*RY YCMAX=0.90*RY * Valuator. XVMIN=1.05*RY XVMAX=0.99*RX YVMIN=0.05*RY YVMAX=0.15*RY * Pick. XPMIN=0.01*RX XPMAX=0.99*RY YPMIN=0.01*RY YPMAX=0.99*RY *** Plot the frame. CALL GRAXIS(DXMIN,DYMIN,DXMAX,DYMAX, - ' ') CALL CELLAY(DXMIN,DYMIN,DXMAX,DYMAX) XSING=0.5*(DXMIN+DXMAX) YSING=0.5*(DYMIN+DYMAX) *** Ask what the user wants via a menu. 100 CONTINUE ICHOIC=2 CALL GRMENU('Quit$Smaller AREA$Larger AREA$Set a new track$'// - 'Single drift-line$Drift from a wire$Drift from track$'// - 'Clean screen$Parameter menu','$',XCMIN,YCMIN,XCMAX,YCMAX, - IWKCH,IDEVCH,ICPET,ICHOIC,IFAIL) * Check the outcome of the menu. IF(IFAIL.NE.0)THEN CALL GRALOG('< graphics input screen > ') CALL GRNEXT PRINT *,' !!!!!! DRFGRA WARNING : Unable to extract a'// - ' value from the menu.' CALL TIMLOG('Drift section with graphics input. ') RETURN ENDIF *** Act accordingly, first the quit. IF(ICHOIC.EQ.1)THEN CALL GMSG(IWK,' ') CALL GRALOG('< graphics input screen > ') CALL GRNEXT CALL TIMLOG('Drift section with graphics input. ') RETURN ** Next the smaller AREA. ELSEIF(ICHOIC.EQ.2)THEN * Prompt the user for one edge point. CALL GMSG(IWK,'Please point to one edge.') * Initialise the LOCATOR to get the point. LSTR=0 PX=DXMIN PY=DYMIN IF(POLAR)CALL CFMRTC(PX,PY,PX,PY,1) CALL GINLC(IWKLC,IDEVLC,1,PX,PY,ILPET1, - XLMIN,XLMAX,YLMIN,YLMAX,LSTR,AUXSTR) * Get the point. IRETRY=0 210 CONTINUE IRETRY=IRETRY+1 CALL GRQLC(IWKLC,IDEVLC,IERR,NT,PX,PY) DXMINN=PX DYMINN=PY IF(POLAR)CALL CFMCTR(DXMINN,DYMINN,DXMINN,DYMINN,1) IF(NT.NE.1.OR.IERR.NE.1.OR.DXMINN.LT.DXMIN.OR. - DXMINN.GT.DXMAX.OR.DYMINN.LT.DYMIN.OR. - DYMINN.GT.DYMAX)THEN CALL GMSG(IWK,'Please point in the current AREA.') IF(IRETRY.LE.NRETRY)GOTO 210 GOTO 100 ENDIF * Prompt the user for the other edge point. CALL GMSG(IWK,'Please point to the opposite edge.') * Initialise the LOCATOR to get the point. LSTR=0 CALL GINLC(IWKLC,IDEVLC,1,PX,PY,ILPET2, - XLMIN,XLMAX,YLMIN,YLMAX,LSTR,AUXSTR) * Get the point. IRETRY=0 220 CONTINUE IRETRY=IRETRY+1 CALL GRQLC(IWKLC,IDEVLC,IERR,NT,PX,PY) DXMAXN=PX DYMAXN=PY IF(POLAR)CALL CFMCTR(DXMAXN,DYMAXN,DXMAXN,DYMAXN,1) IF(NT.NE.1.OR.IERR.NE.1.OR.DXMAXN.LT.DXMIN.OR. - DXMAXN.GT.DXMAX.OR.DYMAXN.LT.DYMIN.OR. - DYMAXN.GT.DYMAX)THEN CALL GMSG(IWK,'Please point in the current AREA.') IF(IRETRY.LE.NRETRY)GOTO 220 GOTO 100 ENDIF * Determine the new AREA. IF(DXMINN.EQ.DXMAXN.OR.DYMINN.EQ.DYMAXN)THEN CALL GMSG(IWK,'The new AREA is not valid.') ELSE DXMIN=MIN(DXMINN,DXMAXN) DXMAX=MAX(DXMINN,DXMAXN) DYMIN=MIN(DYMINN,DYMAXN) DYMAX=MAX(DYMINN,DYMAXN) CALL GMSG(IWK,'Redrawing the axes') CALL GRALOG('< graphics input screen > ') CALL GRNEXT CALL GRAXIS(DXMIN,DYMIN,DXMAX,DYMAX, - ' ') CALL CELLAY(DXMIN,DYMIN,DXMAX,DYMAX) XSING=0.5*(DXMIN+DXMAX) YSING=0.5*(DYMIN+DYMAX) ENDIF ** Next the bigger AREA. ELSEIF(ICHOIC.EQ.3)THEN * Prompt the user for the zoom factor. CALL GMSG(IWK,'Please enter the magnification factor.') * Initialise the VALUATOR. LSTR=0 CALL GINVL(IWKVL,IDEVVL,5.0,IVPET,XVMIN,XVMAX,YVMIN,YVMAX, - 0.01,100.0,LSTR,AUXSTR) * Obtain the zoom factor. IRETRY=0 270 CONTINUE IRETRY=IRETRY+1 CALL GRQVL(IWKVL,IDEVVL,IERR,ZOOM) IF(IERR.NE.1.OR.ZOOM.LE.0.0)THEN CALL GMSG(IWK, - 'Not a valid magnification, please try again.') IF(IRETRY.LE.NRETRY)GOTO 270 GOTO 100 ELSEIF(ABS(ZOOM-1.0).GE.1.0E-3)THEN AUX1=DXMIN AUX2=DXMAX DXMIN=AUX1-ABS(AUX2-AUX1)*(ZOOM-1.0)/2.0 DXMAX=AUX2+ABS(AUX2-AUX1)*(ZOOM-1.0)/2.0 AUX1=DYMIN AUX2=DYMAX DYMIN=AUX1-ABS(AUX2-AUX1)*(ZOOM-1.0)/2.0 DYMAX=AUX2+ABS(AUX2-AUX1)*(ZOOM-1.0)/2.0 CALL GMSG(IWK,'Redrawing the axes') CALL GRALOG('< graphics input screen > ') CALL GRNEXT CALL GRAXIS(DXMIN,DYMIN,DXMAX,DYMAX, - ' ') CALL CELLAY(DXMIN,DYMIN,DXMAX,DYMAX) XSING=0.5*(DXMIN+DXMAX) YSING=0.5*(DYMIN+DYMAX) ENDIF ** New track. ELSEIF(ICHOIC.EQ.4)THEN * Plot the current track in a segment. IF(TRFLAG(1))THEN XPL(1)=XT0 YPL(1)=YT0 XPL(2)=XT1 YPL(2)=YT1 CALL GCRSG(2) CALL GRATTS('TRACK','POLYLINE') CALL GPL(2,XPL,YPL) CALL GCLSG ENDIF * Prompt the user for one end point. CALL GMSG(IWK,'Please point to one end point.') * Initialise the LOCATOR to get the point. LSTR=0 CALL GINLC(IWKLC,IDEVLC,1,XT0,YT0,ILPET1, - XLMIN,XLMAX,YLMIN,YLMAX,LSTR,AUXSTR) * Get the point. IRETRY=0 230 CONTINUE IRETRY=IRETRY+1 CALL GRQLC(IWKLC,IDEVLC,IERR,NT,PX,PY) IF(NT.NE.1.OR.IERR.NE.1)THEN CALL GMSG(IWK,'Please point in the current AREA.') IF(IRETRY.LE.NRETRY)GOTO 230 GOTO 100 ENDIF XT0N=PX YT0N=PY * Prompt the user for the other edge point. CALL GMSG(IWK,'Please point to the other end.') * Initialise the LOCATOR to get the point. LSTR=0 CALL GINLC(IWKLC,IDEVLC,1,PX,PY,ILPET2, - XLMIN,XLMAX,YLMIN,YLMAX,LSTR,AUXSTR) * Get the point. IRETRY=0 240 CONTINUE IRETRY=IRETRY+1 CALL GRQLC(IWKLC,IDEVLC,IERR,NT,PX,PY) IF(NT.NE.1.OR.IERR.NE.1)THEN CALL GMSG(IWK,'Please point in the current AREA.') IF(IRETRY.LE.NRETRY)GOTO 240 GOTO 100 ENDIF * Update the track. XT0=XT0N YT0=YT0N XT1=PX YT1=PY * Drop the segment storing the old track. IF(TRFLAG(1))CALL GDSG(2) TRFLAG(1)=.TRUE. ** Single drift-line. ELSEIF(ICHOIC.EQ.5)THEN * Prompt the user for the starting point. CALL GMSG(IWK,'Please point to the starting point.') * Initialise the LOCATOR to get the point. LSTR=0 XPOS=XSING YPOS=YSING IF(POLAR)CALL CFMRTC(XPOS,YPOS,XPOS,YPOS,1) CALL GINLC(IWKLC,IDEVLC,1,XPOS,YPOS,ILPET1, - XLMIN,XLMAX,YLMIN,YLMAX,LSTR,AUXSTR) * Get the point. IRETRY=0 250 CONTINUE IRETRY=IRETRY+1 CALL GRQLC(IWKLC,IDEVLC,IERR,NT,PX,PY) XPOS=PX YPOS=PY IF(POLAR)CALL CFMCTR(XPOS,YPOS,XPOS,YPOS,1) IF(NT.NE.1.OR.IERR.NE.1.OR.XPOS.LT.DXMIN.OR.XPOS.GT.DXMAX - .OR.YPOS.LT.DYMIN.OR.YPOS.GT.DYMAX)THEN CALL GMSG(IWK,'Please point in the current AREA.') IF(IRETRY.LE.NRETRY)GOTO 250 GOTO 100 ENDIF XSING=XPOS YSING=YPOS CALL DLCALC(XPOS,YPOS,0.0,Q,ITYPE) IF(POLAR)CALL CF2RTC(XU,YU,XU,YU,NU) IF(ITYPE.EQ.2)THEN CALL GRATTS('ION-DRIFT-LINE','POLYLINE') ELSE CALL GRATTS('E-DRIFT-LINE','POLYLINE') ENDIF IF(NU.GE.2)CALL GPL2(NU,XU,YU) ** Drift-lines from a wire. ELSEIF(ICHOIC.EQ.6)THEN * Invite the user to point to one of the wires. CALL GMSG(IWK,'Please select a wire.') * Initialise the PICK device. LSTR=0 CALL GINPK(IWKPK,IDEVPK,1,1,1,IPPET, - XPMIN,XPMAX,YPMIN,YPMAX,LSTR,AUXSTR) * Get the wire number. IRETRY=0 260 CONTINUE IRETRY=IRETRY+1 CALL GRQPK(IWKPK,IDEVPK,IERR,ISGNA,IPCID) * Check the choice is valid. IF(IERR.NE.1.OR.IPCID.LE.0.OR.IPCID.GT.NWIRE)THEN CALL GMSG(IWK,'Invalid choice, please try again.') IF(IRETRY.LE.NRETRY)GOTO 260 GOTO 100 ELSEIF(-Q*E(IPCID).LT.0.AND.LREPSK)THEN CALL GMSG(IWK, - 'This wire attracts the particles, try again.') IF(IRETRY.LE.NRETRY)GOTO 260 GOTO 100 ENDIF * Get a reasonable distance from the wire. IF(-Q*E(IPCID).LT.0)THEN RDIST=0.51*RTRAP*D(IPCID) ELSE RDIST=0.51*D(IPCID) ENDIF * Figure out how many periods are covered by the present AREA. NXMIN=0 NXMAX=0 NYMIN=0 NYMAX=0 IF(PERX)THEN NXMIN=INT(DXMIN/SX)-1 NXMAX=INT(DXMAX/SX)+1 ENDIF IF(PERY)THEN NYMIN=INT(DYMIN/SY)-1 NYMAX=INT(DYMAX/SY)+1 ENDIF * Loop over the periods. DO 330 NX=NXMIN,NXMAX XPOS=X(IPCID)+NX*SX IF(XPOS.LE.DXMIN.OR.XPOS.GE.DXMAX)GOTO 330 DO 320 NY=NYMIN,NYMAX YPOS=Y(IPCID)+NY*SY IF(YPOS.LE.DYMIN.OR.YPOS.GE.DYMAX)GOTO 320 * Loop over the angles. DO 340 IANG=1,NLINED ANGLE=REAL(IANG)*2*PI/REAL(NLINED) CALL DLCALC(XPOS+RDIST*COS(ANGLE),YPOS+RDIST*SIN(ANGLE), - 0.0,-Q,ITYPE) IF(POLAR)CALL CF2RTC(XU,YU,XU,YU,NU) IF(ITYPE.EQ.2)THEN CALL GRATTS('ION-DRIFT-LINE','POLYLINE') ELSE CALL GRATTS('E-DRIFT-LINE','POLYLINE') ENDIF IF(NU.GE.2)CALL GPL2(NU,XU,YU) 340 CONTINUE 320 CONTINUE 330 CONTINUE ** Drift from the track. ELSEIF(ICHOIC.EQ.7)THEN IF(.NOT.TRFLAG(1))THEN CALL GMSG(IWK,'No track defined sofar.') GOTO 100 ENDIF * Plot the track. XPL(1)=XT0 YPL(1)=YT0 XPL(2)=XT1 YPL(2)=YT1 CALL GRATTS('TRACK','POLYLINE') CALL GPL(2,XPL,YPL) * And plot drift-lines. DO 300 I=1,NLINED XPOS=XT0+REAL(I-1)*(XT1-XT0)/REAL(NLINED-1) YPOS=YT0+REAL(I-1)*(YT1-YT0)/REAL(NLINED-1) IF(POLAR)CALL CFMCTR(XPOS,YPOS,XPOS,YPOS,1) CALL DLCALC(XPOS,YPOS,0.0,Q,ITYPE) IF(POLAR)CALL CF2RTC(XU,YU,XU,YU,NU) IF(ITYPE.EQ.2)THEN CALL GRATTS('ION-DRIFT-LINE','POLYLINE') ELSE CALL GRATTS('E-DRIFT-LINE','POLYLINE') ENDIF IF(NU.GE.2)CALL GPL2(NU,XU,YU) 300 CONTINUE ** Clear the page. ELSEIF(ICHOIC.EQ.8)THEN CALL GMSG(IWK,'Redrawing the axes.') CALL GRALOG('< graphics input screen > ') CALL GRNEXT CALL GRAXIS(DXMIN,DYMIN,DXMAX,DYMAX, - ' ') CALL CELLAY(DXMIN,DYMIN,DXMAX,DYMAX) XSING=0.5*(DXMIN+DXMAX) YSING=0.5*(DYMIN+DYMAX) ** The parameter menu. ELSEIF(ICHOIC.EQ.9)THEN * Initialise the menu. 400 CONTINUE NC=1 * Back to main menu. CHSTR(NC:NC+4)='Quit$' NC=NC+5 * Switch particle type. IF(ITYPE.EQ.1)THEN CHSTR(NC:NC+10)='Drift ions$' NC=NC+11 ELSE CHSTR(NC:NC+15)='Drift electrons$' NC=NC+16 ENDIF * Switch particle charge. IF(Q.LE.0)THEN CHSTR(NC:NC+16)='Set charge to +1$' NC=NC+17 ELSE CHSTR(NC:NC+16)='Set charge to -1$' NC=NC+17 ENDIF * Number of drift-lines. CALL OUTFMT(REAL(NLINED),2,AUXSTR,NCAUX,'LEFT') CHSTR(NC:NC+18+NCAUX)= - 'Number of lines ['//AUXSTR(1:NCAUX)//']$' NC=NC+19+NCAUX * Trap radius. CALL OUTFMT(RTRAP,2,AUXSTR,NCAUX,'LEFT') CHSTR(NC:NC+14+NCAUX)='Trap radius ['//AUXSTR(1:NCAUX)//']$' NC=NC+15+NCAUX * Epsilon. CALL OUTFMT(EPSDIF,2,AUXSTR,NCAUX,'LEFT') CHSTR(NC:NC+11+NCAUX)='Accuracy ['//AUXSTR(1:NCAUX)//']$' NC=NC+12+NCAUX * Checking options. IF(LREPSK)THEN CHSTR(NC:NC+20)='Skip repelling wires$' NC=NC+21 ELSE CHSTR(NC:NC+15)='Check all wires$' NC=NC+16 ENDIF * Read the user request from the menu. ICHOIC=2 CALL GRMENU(CHSTR(1:NC-1),'$',XCMIN,YCMIN,XCMAX,YCMAX, - IWKCH,IDEVCH,ICPET,ICHOIC,IFAIL) * Check the return code. IF(IFAIL.NE.0)THEN CALL GRALOG('< graphics input screen > ') CALL GRNEXT PRINT *,' !!!!!! DRFGRA WARNING : Unable to read a'// - ' choice with secondary menu.' CALL TIMLOG('Drift section with graphics input. ') RETURN ENDIF * Act according to the choice, first back to the main menu. IF(ICHOIC.EQ.1)THEN GOTO 100 * Particle type. ELSEIF(ICHOIC.EQ.2)THEN ITYPE=3-ITYPE * Charge. ELSEIF(ICHOIC.EQ.3)THEN Q=-Q * Number of drift-lines. ELSEIF(ICHOIC.EQ.4)THEN CALL GMSG(IWK, - 'Please enter the new number of drift-lines.') * Initialise the VALUATOR. LSTR=0 CALL GINVL(IWKVL,IDEVVL,REAL(NLINED),IVPET, - XVMIN,XVMAX,YVMIN,YVMAX,2.0,100.0,LSTR,AUXSTR) * Obtain the NLINED number. CALL GRQVL(IWKVL,IDEVVL,IERR,AUX) IF(IERR.NE.1.OR.AUX.LE.2.0.OR.AUX.GE.100.0)THEN CALL GMSG(IWK, - 'Not a valid number of drift-lines.') ELSE NLINED=INT(AUX) ENDIF * Trap radius. ELSEIF(ICHOIC.EQ.5)THEN CALL GMSG(IWK, - 'Please enter the new trapping radius.') * Initialise the VALUATOR. LSTR=0 CALL GINVL(IWKVL,IDEVVL,RTRAP,IVPET, - XVMIN,XVMAX,YVMIN,YVMAX,1.0,100.0,LSTR,AUXSTR) * Obtain the trap radius. CALL GRQVL(IWKVL,IDEVVL,IERR,AUX) IF(IERR.NE.1.OR.AUX.LE.1.0.OR.AUX.GE.100.0)THEN CALL GMSG(IWK,'Not a valid trapping radius.') ELSE RTRAP=AUX ENDIF * Epsilon. ELSEIF(ICHOIC.EQ.6)THEN CALL GMSG(IWK, - 'Please enter the new accuracy.') * Initialise the VALUATOR. LSTR=0 CALL GINVL(IWKVL,IDEVVL,EPSDIF,IVPET, - XVMIN,XVMAX,YVMIN,YVMAX,1.0E-10,1.0,LSTR,AUXSTR) * Obtain the accuracy parameter. CALL GRQVL(IWKVL,IDEVVL,IERR,AUX) IF(IERR.NE.1.OR.AUX.LE.0.0)THEN CALL GMSG(IWK,'Not a valid accuracy.') ELSE EPSDIF=AUX ENDIF * Skip/check of repelling wires. ELSEIF(ICHOIC.EQ.7)THEN LREPSK=.NOT.LREPSK * Any other choice. ELSE CALL GMSG(IWK,'Invalid choice, please try again.') ENDIF GOTO 400 ** Something unknown. ELSE CALL GMSG(IWK,'Invalid choice, try again.') ENDIF *** Return for a new cycle. GOTO 100 END +DECK,DRFPLT. SUBROUTINE DRFPLT *----------------------------------------------------------------------- * DRFPLT - Subroutine plotting the electric field, the magnetic field * and the potential in a variety of ways: histograms, contour * plots, vector plots and surface plots. * Variables : XPL,YPL : Used for plotting lines * FUNCT. : Stores the function text the plots * VAR : Array of input values for ALGEXE * GRID : Array of 'hights' for surface plots * COORD : Contains the ordinate of the graph data * VALUE : Contains the function values of the graph * HIST : Stores the histogram * CMIN,CMAX : Range of contour heights * HMIN,HMAX : Range in the histogram * NCHA : Number of bins in the histogram. * FLAG : Logicals used for parsing the command * LHIST ... : Determines whether the plot will be made * PHI,THETA : Viewing angle for 3-dimensional plots. * (Last changed on 12/ 2/99.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CONSTANTS. +SEQ,CELLDATA. +SEQ,GASDATA. +SEQ,PARAMETERS. +SEQ,GRAPHICS. +SEQ,PRINTPLOT. +SEQ,BFIELD. +SEQ,DRIFTLINE. DOUBLE PRECISION F0(3),XPOS1,YPOS1,XPOS2,YPOS2 REAL COORD(MXLIST),VALUE(MXLIST),RES(5),VAR(MXVAR), - HMIN,HMAX,GRSMIN,GRSMAX,RT0,RT1,PT0,PT1,XPOS,YPOS,ZPOS, - FACNRM,VOLT,CMIN,CMAX,QPLT,THETA,PHI,GMINR,GMAXR, - HMINR,HMAXR,CMINR,CMAXR,XXPOS,YYPOS,VXMIN,VYMIN,VXMAX,VYMAX INTEGER NCHA,NCONT,NGRPNT,MODVAR(MXVAR),MODRES(5),NCTOT,ILOC, - ISURF,IVECT1,IVECT2,IVECT3,IHIST,IFLAT,ICHK,JCHK,IHISRF, - NREXP,I,J, - INEXT,NWORD,IFAIL1,IFAIL2,NPNTR,NC1,NC2,NC3,NC4,NC5,II, - INPCMP,NCFTRA,ITYPE,IFAIL,IENTRA,ICOORD,NCHAR,NRES,NCAUX, - NCONTR,NCONTP,IENTRY,NCAUX1,NCAUX2,NCAUX3,NCAUX4 CHARACTER*(MXCHAR) STRING,FUNCT1,FUNCT2,FUNCT3,FUNCT4,FUNCT5, - FUNTRA CHARACTER*20 AUX1,AUX2,AUX3,AUX4 CHARACTER*10 VARLIS(MXVAR) LOGICAL USE(MXVAR),FLAG(MXWORD+5), - EVALE,EVALB,EVALV,EVALT,EVALD,EVALA,EVALL,EVALP, - LHIST,LVECT,LGRAPH,LCONT,LSURF,CAUTO,HAUTO,CLAB,LGRPRT, - LMCDR EXTERNAL INPCMP,DCONT COMMON /CN2DAT/ IENTRY,EVALE,EVALB,EVALV,EVALT,EVALD,EVALA,EVALL, - EVALP,QPLT,ITYPE,LMCDR +SELF,IF=NAG. DOUBLE PRECISION WS,DUM COMMON /MATRIX/ WS(MXWIRE,MXWIRE),CHTS(MXWIRE),DUM(3*MXWIRE+3) +SELF,IF=HIGZ. REAL WS,PAR,DUM,SMIN,SMAX COMMON /MATRIX/ WS(MXWIRE,MXWIRE),PAR(37), - DUM(MXWIRE**2+8*MXWIRE-31) +SELF,IF=SAVE. SAVE VARLIS,HMIN,HMAX,NCHA,NCONT,NGRPNT,PHI,THETA,LGRPRT +SELF. DATA (VARLIS(I),I=1,24) /'X ','Y ','EX ', - 'EY ','EZ ','E ','BX ', - 'BY ','BZ ','B ','VDX ', - 'VDY ','VDZ ','VD ','LORENTZ ', - 'TIME ','PATH ','DIFFUSION ','AVALANCHE ', - 'LOSS ','STATUS ','P ','Z ', - 'T '/ DATA HMIN,HMAX /0.0,10000.0/ DATA NCONT/21/ DATA NGRPNT/MXLIST/,LGRPRT/.FALSE./ DATA NCHA/100/ DATA PHI,THETA/30.0,60.0/ *** Define an output format. 1010 FORMAT(26X,A10,L2,3X,A20,2X,I2,2(2X,E10.3),2(2X,I6),2(2X,E10.3)) *** Identify the routine. IF(LIDENT)PRINT *,' /// ROUTINE DRFPLT ///' *** Preset the options, function strings etc, FUNCT1=' ' FUNCT2=' ' FUNCT3=' ' FUNCT4=' ' FUNCT5=' ' LGRAPH=.FALSE. LSURF=.FALSE. LVECT=.FALSE. LHIST=.FALSE. LCONT=.FALSE. FUNTRA='?' NCFTRA=1 CMIN=0.0 CMAX=10000.0 CAUTO=.TRUE. CLAB=.TRUE. HAUTO=.TRUE. GRSMIN=1 GRSMAX=-1 LMCDR=.FALSE. *** Drift line options. QPLT=-1.0 ITYPE=1 *** Make sure the variables have appropriate names IF(POLAR)THEN VARLIS(1)='R ' VARLIS(2)='PHI ' VARLIS(3)='ER ' VARLIS(4)='EPHI ' VARLIS(7)='BR ' VARLIS(8)='BPHI ' VARLIS(11)='VDR ' VARLIS(12)='VDPHI ' ELSE VARLIS(1)='X ' VARLIS(2)='Y ' VARLIS(3)='EX ' VARLIS(4)='EY ' VARLIS(7)='BX ' VARLIS(8)='BY ' VARLIS(11)='VDX ' VARLIS(12)='VDY ' ENDIF *** Examine the input, first step is finding out where the keywords are. CALL INPNUM(NWORD) DO 10 I=1,MXWORD+5 IF(I.EQ.1.OR.I.GT.NWORD)THEN FLAG(I)=.TRUE. ELSEIF(INPCMP(I,'A#NGLES')+INPCMP(I,'AUTO#MATIC')+ - INPCMP(I,'BI#NS')+INPCMP(I,'SC#ALE')+ - INPCMP(I,'PR#INT')+INPCMP(I,'NOPR#INT')+ - INPCMP(I,'C#ONTOUR')+INPCMP(I,'G#RAPH')+ - INPCMP(I,'H#ISTOGRAM')+INPCMP(I,'N')+ - INPCMP(I,'LAB#ELS')+INPCMP(I,'NOLAB#ELS')+ - INPCMP(I,'RA#NGE')+INPCMP(I,'S#URFACE')+ - INPCMP(I,'VE#CTOR')+INPCMP(I,'ON')+ - INPCMP(I,'EL#ECTRON')+INPCMP(I,'ION')+ - INPCMP(I,'POS#ITIVE')+INPCMP(I,'NEG#ATIVE')+ - INPCMP(I,'M#ONTE-C#ARLO-#DRIFT-#LINES')+ - INPCMP(I,'MC-#DRIFT-#LINES')+ - INPCMP(I,'NOM#ONTE-C#ARLO-#DRIFT-#LINES')+ - INPCMP(I,'NOMC-#DRIFT-#LINES')+ - INPCMP(I,'RUN#GE-K#UTTA-#DRIFT-#LINES')+ - INPCMP(I,'RKF-#DRIFT-#LINES').NE.0)THEN FLAG(I)=.TRUE. ELSE FLAG(I)=.FALSE. ENDIF 10 CONTINUE *** Start a loop over the list, INEXT=1 DO 20 I=2,NWORD IF(I.LT.INEXT)GOTO 20 * warn if the user uses a sub-keyword out of context. IF(INPCMP(I,'RA#NGE')+INPCMP(I,'N')+INPCMP(I,'BI#NS')+ - INPCMP(I,'LAB#ELS')+INPCMP(I,'NOLAB#ELS')+ - INPCMP(I,'A#NGLES')+INPCMP(I,'AUTO#MATIC')+ - INPCMP(I,'PR#INT')+INPCMP(I,'NOPR#INT')+ - INPCMP(I,'ON')+INPCMP(I,'SC#ALE').NE.0)THEN CALL INPMSG(I,'Valid option out of context. ') IF(.NOT.FLAG(I+1))THEN CALL INPMSG(I+1,'See the previous message. ') INEXT=I+2 IF(.NOT.FLAG(I+2))THEN CALL INPMSG(I+2,'See the previous messages. ') INEXT=I+3 ENDIF ENDIF * warn if an unknown keywords appear, ELSEIF(.NOT.FLAG(I))THEN CALL INPMSG(I,'Item is not a known keyword. ') ** Find out whether a GRAPH is requested next, ELSEIF(INPCMP(I,'G#RAPH').NE.0)THEN * Plot already requested ? IF(LGRAPH)PRINT *,' !!!!!! DRFPLT WARNING : Only one'// - ' graph per PLOT statement can be processed.' LGRAPH=.TRUE. * Store the function string. IF(FLAG(I+1))THEN FUNCT1(1:1)='VD' NC1=2 INEXT=I+1 ELSE CALL INPSTR(I+1,I+1,STRING,NC1) FUNCT1(1:NC1)=STRING(1:NC1) INEXT=I+2 ENDIF * Look for sub-keywords with GRAPH. DO 230 II=I,NWORD IF(II.LT.INEXT)GOTO 230 * Look for the subkeyword ON. IF(INPCMP(II,'ON').NE.0)THEN IF(FLAG(II+1))THEN CALL INPMSG(II,'The curve function is absent. ') ELSE CALL INPSTR(II+1,II+1,FUNTRA,NCFTRA) INEXT=II+2 ENDIF * Look for the subkeyword N. ELSEIF(INPCMP(II,'N').NE.0)THEN IF(FLAG(II+1))THEN CALL INPMSG(II,'number of points is missing. ') ELSE CALL INPCHK(II+1,1,IFAIL1) CALL INPRDI(II+1,NPNTR,NGRPNT) IF(NPNTR.LT.2.AND.IFAIL1.EQ.0)CALL INPMSG(II+1, - 'number of point less than 2. ') IF(NPNTR.GT.MXLIST.AND.IFAIL1.EQ.0)CALL INPMSG - (II+1,'number of points > MXLIST. ') IF(NPNTR.GE.2.AND.NPNTR.LE.MXLIST)NGRPNT=NPNTR INEXT=II+2 ENDIF * Look for print options. ELSEIF(INPCMP(II,'PR#INT').NE.0)THEN LGRPRT=.TRUE. INEXT=II+1 ELSEIF(INPCMP(II,'NOPR#INT').NE.0)THEN LGRPRT=.FALSE. INEXT=II+1 * Scale of the graph. ELSEIF(INPCMP(II,'SC#ALE')+INPCMP(II,'RA#NGE').NE.0)THEN IF(FLAG(II+1).OR.FLAG(II+2))THEN CALL INPMSG(II,'the arguments are missing. ') ELSE CALL INPCHK(II+1,2,IFAIL1) CALL INPRDR(II+1,GMINR,+1.0) CALL INPCHK(II+2,2,IFAIL2) CALL INPRDR(II+2,GMAXR,-1.0) IF(GMINR.EQ.GMAXR)THEN CALL INPMSG(II+1,'zero range in the') CALL INPMSG(II+2,'scale not permitted') ELSE GRSMIN=MIN(GMINR,GMAXR) GRSMAX=MAX(GMINR,GMAXR) ENDIF INEXT=II+3 ENDIF * Otherwise skip to the next keyword. ELSE GOTO 20 ENDIF 230 CONTINUE ** Find out whether a CONTOUR plot is requested next, ELSEIF(INPCMP(I,'C#ONTOUR').NE.0)THEN IF(LCONT)PRINT *,' !!!!!! DRFPLT WARNING : Only one'// - ' contour plot per PLOT statement can be processed.' LCONT=.TRUE. * Store the function string, using the default if absent. IF(FLAG(I+1))THEN FUNCT2(1:1)='VD' NC2=2 INEXT=I+1 ELSE CALL INPSTR(I+1,I+1,STRING,NC2) FUNCT2(1:NC2)=STRING(1:NC2) INEXT=I+2 ENDIF * Set default values for the range, depending on the function. CMIN=0.0 CMAX=10000.0 * Look for sub-keywords with CONTOUR. DO 210 II=I+1,NWORD IF(II.LT.INEXT)GOTO 210 * LABELing of the contours. IF(INPCMP(II,'LAB#ELS').NE.0)THEN CLAB=.TRUE. INEXT=II+1 ELSEIF(INPCMP(II,'NOLAB#ELS').NE.0)THEN CLAB=.FALSE. INEXT=II+1 * The RANGE subkeyword. ELSEIF(INPCMP(II,'RA#NGE').NE.0)THEN IF(INPCMP(II+1,'AUTO#MATIC').NE.0)THEN CMIN=0.0 CMAX=0.0 CAUTO=.TRUE. INEXT=II+2 ELSEIF((.NOT.FLAG(II+1)).AND.FLAG(II+2))THEN CALL INPCHK(II+1,2,IFAIL1) CALL INPRDR(II+1,CMINR,CMIN) CMIN=CMINR CMAX=CMINR CAUTO=.FALSE. INEXT=II+2 ELSEIF((.NOT.FLAG(II+1)).AND.(.NOT.FLAG(II+2)))THEN CALL INPCHK(II+1,2,IFAIL1) CALL INPCHK(II+2,2,IFAIL2) CALL INPRDR(II+1,CMINR,CMIN) CALL INPRDR(II+2,CMAXR,CMAX) CMIN=MIN(CMINR,CMAXR) CMAX=MAX(CMINR,CMAXR) CAUTO=.FALSE. INEXT=II+3 ELSE CALL INPMSG(II,'RANGE takes two arguments. ') IF(FLAG(II+1))THEN INEXT=II+1 ELSE CALL INPMSG(II+1, - 'Ignored, see previous message.') INEXT=II+2 ENDIF ENDIF * Sub keyword N. ELSEIF(INPCMP(II,'N').NE.0)THEN IF(FLAG(II+1))THEN CALL INPMSG(II,'N must have an argument. ') INEXT=II+1 ELSE CALL INPCHK(II+1,1,IFAIL1) CALL INPRDI(II+1,NCONTR,NCONT) IF(NCONTR.LT.0.AND.IFAIL1.EQ.0)CALL INPMSG(II+1, - 'number of contour steps is < 0') IF(NCONTR.GT.MXWIRE.AND.IFAIL1.EQ.0)CALL INPMSG - (II+1,'may not exceed MXWIRE. ') IF(NCONTR.GE.0.AND.NCONTR.LE.MXWIRE)NCONT=NCONTR INEXT=II+2 ENDIF * Otherwise skip to the next keyword. ELSE GOTO 20 ENDIF 210 CONTINUE ** A SURFACE (3 dimensional plot) has perhaps been requested, ELSEIF(INPCMP(I,'S#URFACE').NE.0)THEN IF(LSURF)PRINT *,' !!!!!! DRFPLT WARNING : Only one'// - ' surface per PLOT statement can be processed.' LSURF=.TRUE. IF(FLAG(I+1))THEN FUNCT3(1:1)='VD' NC3=2 INEXT=I+1 ELSE CALL INPSTR(I+1,I+1,STRING,NC3) FUNCT3(1:NC3)=STRING(1:NC3) INEXT=I+2 ENDIF * Look for sub-keywords with SURFACE. DO 220 II=I,NWORD IF(II.LT.INEXT)GOTO 220 * Look for the subkeyword ANGLE. IF(INPCMP(II,'A#NGLES').NE.0)THEN IF(.NOT.FLAG(II+1).AND.FLAG(II+2))THEN CALL INPMSG(II,'ANGLE has 2 args: theta, phi. ') CALL INPMSG(II+1,'See the previous message. ') INEXT=II+2 ELSEIF(FLAG(II+1))THEN CALL INPMSG(II,'ANGLE has 2 args: theta, phi. ') INEXT=II+1 ELSE CALL INPCHK(II+1,2,IFAIL1) CALL INPRDR(II+1,PHI,30.0) CALL INPCHK(II+2,2,IFAIL1) CALL INPRDR(II+2,THETA,60.0) INEXT=II+3 ENDIF * Otherwise skip to the next keyword. ELSE GOTO 20 ENDIF 220 CONTINUE ** A vector plot. ELSEIF(INPCMP(I,'VE#CTOR').NE.0)THEN IF(LVECT)PRINT *,' !!!!!! DRFPLT WARNING : Only one'// - ' vector plot per PLOT statement can be processed.' LVECT=.TRUE. IF(FLAG(I+1).OR.FLAG(I+2))THEN IF(.NOT.POLAR)THEN FUNCT4(1:11)='VDX,VDY,VDZ' NC4=11 ELSE FUNCT4(1:13)='VDR,VDPHI,VDZ' NC4=13 ENDIF IF(.NOT.FLAG(I+1).AND.FLAG(I+2))THEN CALL INPSTR(I+1,I+1,STRING,NCAUX) IF(INDEX(STRING(1:NCAUX),'@').NE.0)THEN FUNCT4(1:1)='@' NC4=1 ELSE CALL INPMSG(I+1, - 'Has 2 or 3 args, default used.') ENDIF INEXT=I+2 ELSE INEXT=I+1 ENDIF ELSE CALL INPSTR(I+1,I+1,STRING,NC4) FUNCT4(1:NC4+1)=STRING(1:NC4)//',' CALL INPSTR(I+2,I+2,STRING,NCAUX) FUNCT4(NC4+2:NC4+NCAUX+2)=STRING(1:NCAUX)//',' NC4=NC4+NCAUX+2 IF(.NOT.FLAG(I+3))THEN CALL INPSTR(I+3,I+3,STRING,NCAUX) FUNCT4(NC4+1:NC4+NCAUX)=STRING(1:NCAUX) NC4=NC4+NCAUX INEXT=I+4 ELSE FUNCT4(NC4+1:NC4+1)='0' NC4=NC4+1 INEXT=I+3 ENDIF ENDIF ** Finally, find out whether the next plot is a HISTOGRAM. ELSEIF(INPCMP(I,'H#ISTOGRAM').NE.0)THEN IF(LHIST)PRINT *,' !!!!!! DRFPLT WARNING : Only one'// - ' histogram per PLOT statement can be processed.' LHIST=.TRUE. IF(FLAG(I+1))THEN FUNCT5(1:1)='VD' NC5=2 HMIN=0.0 HMAX=10000.0 INEXT=I+1 ELSE CALL INPSTR(I+1,I+1,STRING,NC5) FUNCT5(1:NC5)=STRING(1:NC5) INEXT=I+2 ENDIF * Look for subkeywords associated with HISTOGRAM. DO 200 II=I,NWORD IF(II.LT.INEXT)GOTO 200 * The RANGE subkeyword. IF(INPCMP(II,'RA#NGE').NE.0)THEN IF(INPCMP(II+1,'AUTO#MATIC').NE.0)THEN HMIN=0.0 HMAX=0.0 HAUTO=.TRUE. INEXT=II+2 ELSEIF(.NOT.FLAG(II+1).AND..NOT.FLAG(II+2))THEN CALL INPCHK(II+1,2,IFAIL1) CALL INPCHK(II+2,2,IFAIL2) CALL INPRDR(II+1,HMINR,HMIN) CALL INPRDR(II+2,HMAXR,HMAX) HAUTO=.FALSE. IF(HMINR.EQ.HMAXR)THEN CALL INPMSG(II+1, - 'Zero range not permitted. ') CALL INPMSG(II+2, - 'See the previous message. ') ELSE HMIN=MIN(HMINR,HMAXR) HMAX=MAX(HMINR,HMAXR) ENDIF INEXT=II+3 ELSE CALL INPMSG(II,'RANGE takes two arguments. ') IF(FLAG(II+1))THEN INEXT=II+1 ELSE CALL INPMSG(II+1, - 'Ignored, see previous message.') INEXT=II+2 ENDIF ENDIF * The BINS subkeyword. ELSEIF(INPCMP(II,'BI#NS').NE.0)THEN IF(FLAG(II+1))THEN CALL INPMSG(II,'This keyword has one argument.') INEXT=II+1 ELSE CALL INPCHK(II+1,1,IFAIL) CALL INPRDI(II+1,NCHAR,MXCHA) IF(NCHAR.LE.1.OR.NCHAR.GT.MXCHA)THEN CALL INPMSG(II+1, - 'Inacceptable number of bins. ') ELSE NCHA=NCHAR ENDIF INEXT=II+2 ENDIF * Otherwise quit this loop. ELSE GOTO 20 ENDIF 200 CONTINUE ** Drift parameters. ELSEIF(INPCMP(I,'EL#ECTRON').NE.0)THEN ITYPE=1 ELSEIF(INPCMP(I,'ION').NE.0)THEN ITYPE=2 ELSEIF(INPCMP(I,'POS#ITIVE').NE.0)THEN QPLT=+1 ELSEIF(INPCMP(I,'NEG#ATIVE').NE.0)THEN QPLT=+1 ELSEIF(INPCMP(I,'M#ONTE-C#ARLO-#DRIFT-#LINES')+ - INPCMP(I,'MC-#DRIFT-#LINES').NE.0)THEN LMCDR=.TRUE. ELSEIF(INPCMP(I,'NOM#ONTE-C#ARLO-#DRIFT-#LINES')+ - INPCMP(I,'NOMC-#DRIFT-#LINES')+ - INPCMP(I,'RUN#GE-K#UTTA-#DRIFT-#LINES')+ - INPCMP(I,'RKF-#DRIFT-#LINES').NE.0)THEN LMCDR=.FALSE. ** Warn if the user aks for an unknown plot type or makes an error, ELSE CALL INPMSG(I,'Should have been a plot type. ') ENDIF 20 CONTINUE ** Print error messages. CALL INPERR *** Next print the list of plots if the DEBUG option is on. IF(LDEBUG)THEN WRITE(LUNOUT,'( - '' ++++++ DRFPLT DEBUG : List of requested plots:''/ - '' Type Y/N '', - ''Function (1:20) NC <--------Range-------> '', - ''# cont # bins <-------Angle-------->'')') IF(LGRAPH)THEN WRITE(LUNOUT,'(26X,A10,L2,3X,A20,1X,I3,34X,I6)') - 'Graph ',LGRAPH,FUNCT1(1:20),NC1,NGRPNT ELSE WRITE(LUNOUT,'(26X,A10,L2)') 'Graph ',LGRAPH ENDIF IF(LCONT.AND..NOT.CAUTO)THEN WRITE(LUNOUT, - '(26X,A7,3X,L2,3X,A20,1X,I3,2(2X,E10.3),2X,I6)') - 'Contour',LCONT,FUNCT2(1:20),NC2,CMIN,CMAX,NCONT ELSEIF(LCONT.AND.CAUTO)THEN WRITE(LUNOUT,'(26X,A7,3X,L2,3X,A20,1X,I3, - '' Automatic scaling'',2X,I6)') - 'Contour',LCONT,FUNCT2(1:20),NC2,NCONT ELSE WRITE(LUNOUT,'(26X,A10,L2)') 'Contour ',LCONT ENDIF IF(LSURF)THEN WRITE(LUNOUT, - '(26X,A10,L2,3X,A20,1X,I3,40X,2(2X,E10.3))') - 'Surface ',LSURF,FUNCT3(1:20),NC3,PHI,THETA ELSE WRITE(LUNOUT,'(26X,A10,L2)') 'Surface ',LSURF ENDIF IF(LVECT)THEN WRITE(LUNOUT,'(26X,A10,L2,3X,A20,1X,I3)') - 'Vector ',LVECT ,FUNCT4(1:20),NC4 ELSE PRINT '(26X,A10,L2)','Vector ',LVECT ENDIF IF(LHIST.AND..NOT.HAUTO)THEN WRITE(LUNOUT, - '(26X,A10,L2,3X,A20,1X,I3,2(2X,E10.3),10X,I6)') - 'Histogram ',LHIST ,FUNCT5(1:20),NC5, - HMIN,HMAX,NCHA ELSEIF(LHIST)THEN WRITE(LUNOUT,'(26X,A10,L2,3X,A20,1X,I3, - '' Automatic scaling'',10X,I6)') - 'Histogram ',LHIST ,FUNCT5(1:20),NC5,NCHA ELSE WRITE(LUNOUT,'(26X,A10,L2)') 'Histogram ',LHIST ENDIF WRITE(LUNOUT,'('' '')') ENDIF *** Take care of the 'GRAPH' type plots, translate curve function. IF(LGRAPH.AND.FUNTRA(1:NCFTRA).NE.'?')THEN CALL ALGPRE(FUNTRA,NCFTRA,VARLIS(24),1,NRES,USE(24), - IENTRA,IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! DRFPLT WARNING : Graph not made'// - ' because of an error in the track function.' CALL ALGCLR(IENTRA) GOTO 101 ELSEIF(NRES.NE.3)THEN PRINT *,' !!!!!! DRFPLT WARNING : Graph not made'// - ' because the curve does not give 3 results.' CALL ALGCLR(IENTRA) GOTO 101 ELSEIF(.NOT.USE(24))THEN PRINT *,' !!!!!! DRFPLT WARNING : Graph not made'// - ' because the track does not depend on T.' CALL ALGCLR(IENTRA) GOTO 101 ENDIF * If no curve is defined, the track must be. ELSEIF(LGRAPH.AND..NOT.TRFLAG(1))THEN PRINT *,' !!!!!! DRFPLT WARNING : Neither a track nor'// - ' a curve has been defined ; graph not made.' GOTO 101 ENDIF * Parameters look a priori acceptable. IF(LGRAPH)THEN * Transform the function into an instruction list, IF(INDEX(FUNCT1(1:NC1),'@').NE.0)THEN NRES=1 CALL ALGEDT(VARLIS,23,IENTRY,USE,NRES) FUNCT1='Edited function' NC1=15 ELSE CALL ALGPRE(FUNCT1,NC1,VARLIS,23,NRES,USE,IENTRY,IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! DRFPLT WARNING : Graph not'// - ' produced because of syntax errors.' GOTO 100 ENDIF ENDIF * Figure out which quatities are effectively used. EVALE=.FALSE. EVALB=.FALSE. EVALV=.FALSE. EVALT=.FALSE. EVALD=.FALSE. EVALA=.FALSE. EVALL=.FALSE. EVALP=.FALSE. IF(USE(3).OR.USE(4).OR.USE(5).OR.USE(6).OR.USE(15)) - EVALE=.TRUE. IF(USE(7).OR.USE(8).OR.USE(9).OR.USE(10))EVALB=.TRUE. IF(USE(11).OR.USE(12).OR.USE(13).OR.USE(14).OR. - USE(15))EVALV=.TRUE. IF(USE(16).OR.USE(17).OR.USE(18).OR.USE(19).OR. - USE(20).OR.USE(21))EVALT=.TRUE. IF(USE(17))EVALP=.TRUE. IF(USE(18))EVALD=.TRUE. IF(USE(19))EVALA=.TRUE. IF(USE(20))EVALL=.TRUE. * Be sure only one result is returned. IF(NRES.NE.1)THEN PRINT *,' !!!!!! DRFPLT WARNING : The function'// - ' does not return precisely 1 result; no graph.' GOTO 100 ENDIF * check the use of magnetic field quantities, IF(EVALB.AND..NOT.MAGOK)THEN PRINT *,' !!!!!! DRFPLT WARNING : The function to be'// - ' plotted uses magnetic field quantities,' PRINT *,' no such field has'// - ' been defined however ; plot not made.' GOTO 100 ENDIF IF((USE(7).OR.USE(8)).AND.POLAR)THEN PRINT *,' !!!!!! DRFPLT WARNING : Bx and By should'// - ' not be used with polar cells ; plot not made.' GOTO 100 ENDIF * Check use of absent gas data. IF(EVALD.AND..NOT.GASOK(3))THEN PRINT *,' !!!!!! DRFPLT WARNING : The graph tries'// - ' to use absent diffusion data ; plot not made.' GOTO 100 ENDIF IF(EVALA.AND..NOT.GASOK(4))THEN PRINT *,' !!!!!! DRFPLT WARNING : The graph tries'// - ' to use absent Townsend data ; plot not made.' GOTO 100 ENDIF IF(EVALL.AND..NOT.GASOK(6))THEN PRINT *,' !!!!!! DRFPLT WARNING : The graph tries'// - ' to use absent attachment data ; plot not made.' GOTO 100 ENDIF * Select the axis with the largest range for ordinate. IF(FUNTRA(1:NCFTRA).NE.'?')THEN ICOORD=3 ELSEIF(POLAR)THEN CALL CFMCTP(XT0,YT0,RT0,PT0,1) CALL CFMCTP(XT1,YT1,RT1,PT1,1) IF((ZT1-ZT0)**2.GT.(XT1-XT0)**2+(YT1-YT0)**2)THEN ICOORD=11 ELSEIF(ABS(RT0-RT1).GT.ABS(PT0-PT1))THEN ICOORD=1 ELSE ICOORD=2 ENDIF ELSE IF((ZT1-ZT0)**2.GT.(XT1-XT0)**2+(YT1-YT0)**2)THEN ICOORD=11 ELSEIF(ABS(XT0-XT1).GT.ABS(YT0-YT1))THEN ICOORD=1 ELSE ICOORD=2 ENDIF ENDIF * Print a heading for the numbers. IF(FUNTRA(1:NCFTRA).EQ.'?')THEN IF(LGRPRT)WRITE(LUNOUT,'(/'' GRAPH OF '',A, - '' ON '',A//2X,''Coordinate'',48X,''Function'')') - FUNCT1(1:NC1),'THE TRACK' ELSE IF(LGRPRT)WRITE(LUNOUT,'(/'' GRAPH OF '',A, - '' ON '',A//2X,''Coordinate'',48X,''Function'')') - FUNCT1(1:NC1),FUNTRA(1:NCFTRA) ENDIF * Fill the vectors, DO 30 I=1,NGRPNT IF(ICOORD.NE.3)THEN XPOS=XT0+REAL(I-1)*(XT1-XT0)/REAL(NGRPNT-1) YPOS=YT0+REAL(I-1)*(YT1-YT0)/REAL(NGRPNT-1) ZPOS=ZT0+REAL(I-1)*(ZT1-ZT0)/REAL(NGRPNT-1) IF(POLAR)CALL CFMCTR(XPOS,YPOS,XPOS,YPOS,1) ELSE VAR(1)=REAL(I-1)/REAL(NGRPNT-1) MODVAR(1)=2 CALL ALGEXE(IENTRA,VAR,MODVAR,1,RES,MODRES,3,IFAIL) XPOS=RES(1) YPOS=RES(2) ZPOS=RES(3) IF(POLAR)CALL CFMPTR(XPOS,YPOS,XPOS,YPOS,1,IFAIL1) IF(IFAIL1.NE.0)THEN XPOS=1.0 YPOS=0.0 ZPOS=0.0 PRINT *,' !!!!!! DRFPLT WARNING : The curve'// - ' function returns invalid coordinates.' ENDIF ENDIF CALL DCONT2(XPOS,YPOS,ZPOS,RES,ILOC) IF(ICOORD.EQ.3)THEN COORD(I)=REAL(I-1)/REAL(NGRPNT-1) ELSEIF(ICOORD.EQ.2)THEN COORD(I)=YPOS ELSEIF(ICOORD.EQ.11)THEN COORD(I)=ZPOS ELSE COORD(I)=XPOS ENDIF VALUE(I)=RES(1) * Print the point if this has been requested. IF(LGRPRT)WRITE(LUNOUT,'(4(2X,E15.8))') - XPOS,YPOS,ZPOS,VALUE(I) 30 CONTINUE * Plot the graph. IF(GRSMIN.LT.GRSMAX)CALL GRGRSC(GRSMIN,GRSMAX) IF(ICOORD.EQ.3)THEN CALL GRGRPH(COORD,VALUE,NGRPNT,'Curve parameter', - FUNCT1(NC1+1:40)//FUNCT1(1:NC1), - 'GRAPH OF '//FUNCT1(1:31)) ELSEIF(POLAR.AND.ICOORD.EQ.1)THEN CALL GRGRPH(COORD,VALUE,NGRPNT,'Radius [cm]', - FUNCT1(NC1+1:40)//FUNCT1(1:NC1), - 'GRAPH OF '//FUNCT1(1:31)) ELSEIF(POLAR.AND.ICOORD.EQ.2)THEN CALL GRGRPH(COORD,VALUE,NGRPNT,'Angle [degrees]', - FUNCT1(NC1+1:40)//FUNCT1(1:NC1), - 'GRAPH OF '//FUNCT1(1:31)) ELSEIF((.NOT.POLAR).AND.ICOORD.EQ.1)THEN CALL GRGRPH(COORD,VALUE,NGRPNT,'x-Axis [cm]', - FUNCT1(NC1+1:40)//FUNCT1(1:NC1), - 'GRAPH OF '//FUNCT1(1:31)) ELSEIF((.NOT.POLAR).AND.ICOORD.EQ.2)THEN CALL GRGRPH(COORD,VALUE,NGRPNT,'y-Axis [cm]', - FUNCT1(NC1+1:40)//FUNCT1(1:NC1), - 'GRAPH OF '//FUNCT1(1:31)) ELSEIF((.NOT.POLAR).AND.ICOORD.EQ.11)THEN CALL GRGRPH(COORD,VALUE,NGRPNT,'z-Axis [cm]', - FUNCT1(NC1+1:40)//FUNCT1(1:NC1), - 'GRAPH OF '//FUNCT1(1:31)) ELSE PRINT *,' ###### DRFPLT ERROR : Inconsistent axis'// - ' selection ; program bug - please report.' ENDIF * Log this frame and prepare for the next plot. CALL GRNEXT CALL GRALOG('Graph of '//FUNCT1(1:31)) CALL TIMLOG('Plotting the graph of '//FUNCT1(1:18)) * print the number of arithmetic errors. CALL ALGERR 100 CONTINUE * Release the entry points. CALL ALGCLR(IENTRY) IF(FUNTRA(1:NCFTRA).NE.'?')CALL ALGCLR(IENTRA) ENDIF * Continue here if the parameters were not acceptable. 101 CONTINUE *** Take care of the contours. IF(LCONT)THEN * Convert to an instruction list, IF(INDEX(FUNCT2(1:NC2),'@').NE.0)THEN NRES=1 CALL ALGEDT(VARLIS,23,IENTRY,USE,NRES) FUNCT2='Edited function' NC2=15 ELSE CALL ALGPRE(FUNCT2,NC2,VARLIS,23,NRES,USE,IENTRY,IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! DRFPLT WARNING : No contour'// - ' plot because of function syntax errors.' GOTO 110 ENDIF ENDIF * Be sure only one result is returned. IF(NRES.NE.1)THEN PRINT *,' !!!!!! DRFPLT WARNING : The function does'// - ' not return precisely 1 result; no contour.' GOTO 110 ENDIF * Figure out which quantities are effectively used. EVALE=.FALSE. EVALB=.FALSE. EVALV=.FALSE. EVALT=.FALSE. EVALD=.FALSE. EVALA=.FALSE. EVALL=.FALSE. EVALP=.FALSE. IF(USE(3).OR.USE(4).OR.USE(5).OR.USE(6).OR.USE(15)) - EVALE=.TRUE. IF(USE(7).OR.USE(8).OR.USE(9).OR.USE(10))EVALB=.TRUE. IF(USE(11).OR.USE(12).OR.USE(13).OR.USE(14).OR. - USE(15))EVALV=.TRUE. IF(USE(16).OR.USE(17).OR.USE(18).OR.USE(19).OR. - USE(20).OR.USE(21))EVALT=.TRUE. IF(USE(17))EVALP=.TRUE. IF(USE(18))EVALD=.TRUE. IF(USE(19))EVALA=.TRUE. IF(USE(20))EVALL=.TRUE. * Check the use of magnetic field quantities. IF(EVALB.AND..NOT.MAGOK)THEN PRINT *,' !!!!!! DRFPLT WARNING : The function to be'// - ' plotted uses magnetic field quantities,' PRINT *,' no such field has'// - ' been defined however ; plot not made.' GOTO 110 ENDIF IF((USE(7).OR.USE(8)).AND.POLAR)THEN PRINT *,' !!!!!! DRFPLT WARNING : Bx and By should'// - ' not be used with polar cells ; plot not made.' GOTO 110 ENDIF * Check use of absent gas data. IF(EVALD.AND..NOT.GASOK(3))THEN PRINT *,' !!!!!! DRFPLT WARNING : The contour tries'// - ' to use absent diffusion data ; plot not made.' GOTO 110 ENDIF IF(EVALA.AND..NOT.GASOK(4))THEN PRINT *,' !!!!!! DRFPLT WARNING : The contour tries'// - ' to use absent Townsend data ; plot not made.' GOTO 110 ENDIF IF(EVALL.AND..NOT.GASOK(6))THEN PRINT *,' !!!!!! DRFPLT WARNING : The contour tries'// - ' to use absent attachment data ; plot not made.' GOTO 110 ENDIF * Plot the contours. CALL GRCELL(VXMIN,VYMIN,VXMAX,VYMAX, - 'Contours of '//FUNCT2(1:NC2)) NCONTP=NCONT CALL GRCONT(DCONT,CMIN,CMAX,VXMIN,VYMIN,VXMAX,VYMAX, - NCONTP,CAUTO,POLAR,CLAB) CALL GRNEXT * Print the table of contour heights. CALL OUTFMT(CMIN,2,AUX1,NCAUX1,'LEFT') CALL OUTFMT(CMAX,2,AUX2,NCAUX2,'LEFT') CALL OUTFMT(REAL(NCONTP),2,AUX3,NCAUX3,'LEFT') CALL OUTFMT((CMAX-CMIN)/REAL(MAX(1,NCONTP)),2, - AUX4,NCAUX4,'LEFT') IF(NCONTP.GE.1)WRITE(LUNOUT,'(/'' The contours'', - '' correspond to '',A,'' = '',A,'' to '',A, - '' in '',A,'' steps.''/'' The interval between 2'', - '' contours is '',A,''.'')') - FUNCT2(1:NC2),AUX1(1:NCAUX1),AUX2(1:NCAUX2), - AUX3(1:NCAUX3),AUX4(1:NCAUX4) IF(NCONTP.EQ.0)WRITE(LUNOUT,'(/'' The contour'', - '' corresponds to '',A,'' = '',A,''.'')') - FUNCT2(1:NC2),AUX1(1:NCAUX1) * Keep track of the plots being made. CALL GRALOG('Contours of '//FUNCT2(1:NC2)//':') CALL TIMLOG('Plotting contours of '//FUNCT2(1:NC2)//':') * Print the number of arithmetic errors. CALL ALGERR 110 CONTINUE CALL ALGCLR(IENTRY) ENDIF *** If one of the other plots is asked for, prepare the function string. IF(LHIST.OR.LSURF.OR.LVECT)THEN NCTOT=0 IF(LSURF)THEN ISURF=1 FUNCT1(1:NC3)=FUNCT3(1:NC3) NCTOT=NC3 ENDIF IF(LVECT)THEN IF(LSURF)THEN IVECT1=2 IVECT2=3 IVECT3=4 FUNCT1(NCTOT+1:NCTOT+NC4+1)=','//FUNCT4(1:NC4) NCTOT=NCTOT+NC4+1 ELSE IVECT1=1 IVECT2=2 IVECT3=3 FUNCT1(1:NC4)=FUNCT4(1:NC4) NCTOT=NC4 ENDIF ENDIF IF(LHIST)THEN IF(LSURF.OR.LVECT)THEN IF(LSURF.AND..NOT.LVECT)IHIST=2 IF(LVECT.AND..NOT.LSURF)IHIST=4 IF(LSURF.AND. LVECT)IHIST=5 FUNCT1(NCTOT+1:NCTOT+NC5+1)=','//FUNCT5(1:NC5) NCTOT=NCTOT+NC5+1 ELSE IHIST=1 FUNCT1(1:NC5)=FUNCT5(1:NC5) NCTOT=NC5 ENDIF ENDIF * Turn it into an instruction list, NREXP=0 IF(LHIST)NREXP=NREXP+1 IF(LSURF)NREXP=NREXP+1 IF(LVECT)NREXP=NREXP+3 IF(INDEX(FUNCT1(1:NCTOT),'@').NE.0)THEN NRES=NREXP CALL ALGEDT(VARLIS,23,IENTRY,USE,NRES) FUNCT1='Edited function' NCTOT=15 ELSE CALL ALGPRE(FUNCT1,NCTOT,VARLIS,23,NRES,USE,IENTRY, - IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! DRFPLT WARNING : Plots not'// - ' produced because of syntax errors.' GOTO 120 ENDIF ENDIF * Be sure only one result is returned. IF(NRES.NE.NREXP)THEN PRINT *,' !!!!!! DRFPLT WARNING : The function does'// - ' not return the correct number of results;'// - ' histogram, surface and vector plot skipped.' GOTO 120 ENDIF * Figure out which quantities are effectively used. EVALE=.FALSE. EVALB=.FALSE. EVALV=.FALSE. EVALT=.FALSE. EVALD=.FALSE. EVALA=.FALSE. EVALL=.FALSE. EVALP=.FALSE. IF(USE(3).OR.USE(4).OR.USE(5).OR.USE(6).OR.USE(15)) - EVALE=.TRUE. IF(USE(7).OR.USE(8).OR.USE(9).OR.USE(10))EVALB=.TRUE. IF(USE(11).OR.USE(12).OR.USE(13).OR.USE(14).OR. - USE(15))EVALV=.TRUE. IF(USE(16).OR.USE(17).OR.USE(18).OR.USE(19).OR. - USE(20).OR.USE(21))EVALT=.TRUE. IF(USE(17))EVALP=.TRUE. IF(USE(18))EVALD=.TRUE. IF(USE(19))EVALA=.TRUE. IF(USE(20))EVALL=.TRUE. * check the use of magnetic field quantities, IF(EVALB.AND..NOT.MAGOK)THEN PRINT *,' !!!!!! DRFPLT WARNING : The function to be'// - ' plotted uses magnetic field quantities,' PRINT *,' no such field has'// - ' been defined however ; plot not made.' GOTO 120 ENDIF IF((USE(7).OR.USE(8)).AND.POLAR)THEN PRINT *,' !!!!!! DRFPLT WARNING : Bx and By should'// - ' not be used with polar cells ; plot not made.' GOTO 120 ENDIF * Check use of absent gas data. IF(EVALD.AND..NOT.GASOK(3))THEN PRINT *,' !!!!!! DRFPLT WARNING : The plot tries'// - ' to use absent diffusion data ; plot not made.' GOTO 120 ENDIF IF(EVALA.AND..NOT.GASOK(4))THEN PRINT *,' !!!!!! DRFPLT WARNING : The plot tries'// - ' to use absent Townsend data ; plot not made.' GOTO 120 ENDIF IF(EVALL.AND..NOT.GASOK(6))THEN PRINT *,' !!!!!! DRFPLT WARNING : The plot tries'// - ' to use absent attachment data ; plot not made.' GOTO 120 ENDIF +SELF,IF=NAG,HIGZ. * Obtain the matrix for surface plotting. IF(LSURF)THEN CALL BOOK('BOOK','MATRIX','SURFACE',IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! DRFPLT WARNING : Unable to'// - ' obtain storage for the surface plot.' PRINT *,' The plot'// - ' will not be made.' LSURF=.FALSE. ENDIF ENDIF +SELF. * Open a plotting frame for a VECTOR plot, if requested. IF(LVECT)THEN CALL GRCELL(VXMIN,VYMIN,VXMAX,VYMAX, - 'Vector plot of '//FUNCT4(1:NC4)) CALL GRALOG('Vector plot of '//FUNCT4(1:NC4)//':') * Otherwise, merely request the viewing area. ELSE CALL GRVIEW(VXMIN,VYMIN,VXMAX,VYMAX) ENDIF * Allocate an histogram, if needed. IF(LHIST)THEN CALL HISADM('ALLOCATE',IHISRF,NCHA,HMIN,HMAX, - HAUTO,IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! DRFPLT WARNING : Unable to'// - ' allocate histogram storage; histogram'// - ' cancelled.' LHIST=.FALSE. ENDIF ENDIF * Fill all the arrays and matrices required for these plots. CALL GRATTS('FUNCTION-1','POLYLINE') DO 50 I=1,NGRIDX IF(.NOT.POLAR)THEN XXPOS=VXMIN+REAL(I-1)*(VXMAX-VXMIN)/REAL(NGRIDX-1) ELSE XXPOS=LOG(EXP(VXMIN)+REAL(I-1)*(EXP(VXMAX)-EXP(VXMIN))/ - REAL(NGRIDX-1)) ENDIF * set a normalisation factor, to get the arrows more or less right IF(.NOT.POLAR)THEN FACNRM=MIN(VYMAX-VYMIN,VXMAX-VXMIN)/REAL(NGRIDX) ELSE FACNRM=LOG((EXP(VXMIN)+REAL(I-1)*(EXP(VXMAX)- - EXP(VXMIN))/REAL(NGRIDX))/(EXP(VXMIN)+REAL(I)* - (EXP(VXMAX)-EXP(VXMIN))/REAL(NGRIDX))) ENDIF DO 60 J=1,NGRIDY YYPOS=VYMIN+REAL(J-1)*(VYMAX-VYMIN)/REAL(NGRIDY-1) * Coordinate transformation to the viewing plane. XPOS=FPROJ(1,1)*XXPOS+FPROJ(2,1)*YYPOS+FPROJ(3,1) YPOS=FPROJ(1,2)*XXPOS+FPROJ(2,2)*YYPOS+FPROJ(3,2) ZPOS=FPROJ(1,3)*XXPOS+FPROJ(2,3)*YYPOS+FPROJ(3,3) IF(XPOS.LT.DXMIN.OR.XPOS.GT.DXMAX.OR. - YPOS.LT.DYMIN.OR.YPOS.GT.DYMAX.OR. - ZPOS.LT.DZMIN.OR.ZPOS.GT.DZMAX)THEN +SELF,IF=NAG,HIGZ. IF(LSURF)WS(I,J)=0.0 +SELF. GOTO 60 ENDIF * Evaluate the function. VAR(1)=XPOS VAR(2)=YPOS VAR(23)=ZPOS * Calculate the fields needed for the rest. IF(EVALE)CALL EFIELD(VAR(1),VAR(2),VAR(23), - VAR(3),VAR(4),VAR(5),VAR(6),VOLT,0,ILOC) IF(EVALB)CALL BFIELD(VAR(1),VAR(2),VAR(23), - VAR(7),VAR(8),VAR(9),VAR(10)) * Get the local drift velocity. IF(EVALV)THEN CALL DLCVEL(DBLE(VAR(1)),DBLE(VAR(2)),DBLE(VAR(23)), - F0,QPLT,ITYPE,ILOC) VAR(11)=REAL(F0(1)) VAR(12)=REAL(F0(2)) VAR(13)=REAL(F0(3)) VAR(14)=SQRT(VAR(11)**2+VAR(12)**2+VAR(13)**2) ENDIF * Lorentz angle. IF(EVALE.AND.EVALV)VAR(15)=ACOS(MAX(-1.0,MIN(1.0, - REAL((VAR(3)*VAR(11)+VAR(4)*VAR(12)+VAR(5)*VAR(13))/ - (VAR(6)*VAR(14)))))) * Store drift line related quantities. IF(EVALT)THEN CALL DLCALC(VAR(1),VAR(2),VAR(23),QPLT,ITYPE) VAR(16)=TU(NU) IF(EVALP)THEN VAR(17)=0.0 DO 64 II=2,NU IF(POLAR)THEN CALL CF2RTC(XU(II-1),YU(II-1),XPOS1,YPOS1,1) CALL CF2RTC(XU(II) ,YU(II) ,XPOS2,YPOS2,1) VAR(17)=VAR(17)+SQRT((XPOS2-XPOS1)**2+ - (YPOS2-YPOS1)**2+(ZU(II)-ZU(II-1))**2) ELSE VAR(17)=VAR(17)+SQRT((XU(II)-XU(II-1))**2+ - (YU(II)-YU(II-1))**2+ - (ZU(II)-ZU(II-1))**2) ENDIF 64 CONTINUE ENDIF IF(EVALD)CALL DLCDIF(VAR(18)) IF(EVALA)CALL DLCTWN(VAR(19)) IF(EVALL)CALL DLCATT(VAR(20)) VAR(21)=ISTAT ENDIF * Store gas pressure. VAR(22)=PGAS * Transform vectors and covectors to polar coordinates if needed. IF(POLAR)THEN CALL CFMRTP(VAR(1),VAR(2),VAR(1),VAR(2),1) VAR(3)=VAR(3)/VAR(1) VAR(4)=VAR(4)/VAR(1) VAR(6)=SQRT(VAR(3)**2+VAR(4)**2+VAR(5)**2) VAR(11)=VAR(11)*VAR(1) VAR(12)=VAR(12)*VAR(1) VAR(14)=SQRT(VAR(11)**2+VAR(12)**2+VAR(13)**2) ENDIF DO 65 II=1,23 MODVAR(II)=2 65 CONTINUE CALL ALGEXE(IENTRY,VAR,MODVAR,23,RES,MODRES,5,IFAIL) * Vector plot plotting. IF(LVECT)THEN IF(RES(IVECT1)**2+RES(IVECT2)**2+RES(IVECT3)**2.GT.0) - CALL PLAARR(XPOS,YPOS,ZPOS, - 0.5*FACNRM*RES(IVECT1)/SQRT(RES(IVECT1)**2+ - RES(IVECT2)**2+RES(IVECT3)**2), - 0.5*FACNRM*RES(IVECT2)/SQRT(RES(IVECT1)**2+ - RES(IVECT2)**2+RES(IVECT3)**2), - 0.5*FACNRM*RES(IVECT3)/SQRT(RES(IVECT1)**2+ - RES(IVECT2)**2+RES(IVECT3)**2)) ENDIF +SELF,IF=NAG,HIGZ. IF(LSURF)WS(I,J)=RES(ISURF) +SELF. * fill the histogram, if requested, IF(LHIST)CALL HISENT(IHISRF,RES(IHIST),1.0) 60 CONTINUE 50 CONTINUE CALL TIMLOG('Accumulating plot data on the grid: ') IF(LVECT)CALL GRNEXT * plot the 3-dimensional picture if requested IF(LSURF)THEN +SELF,IF=NAG. * Check that the surface is not flat. IFLAT=1 DO 80 ICHK=1,NGRIDX DO 70 JCHK=1,NGRIDY IF(ABS(WS(ICHK,JCHK)-WS(1,1)).GT.1.0E-5* - (1.0+ABS(WS(ICHK,JCHK))+ABS(WS(1,1))))IFLAT=0 70 CONTINUE 80 CONTINUE IF(IFLAT.NE.0)THEN PRINT *,' !!!!!! DRFPLT WARNING : The surface is', - ' not plotted because it is entirely flat.' CALL BOOK('RELEASE','MATRIX','SURFACE',IFAIL) GOTO 90 ENDIF * Switch the screen to graphics mode. CALL GRGRAF(.TRUE.) * Store the CH eXPansion, NAG has the nasty habit of changing it. CALL GQCHXP(IERR,CHEXP) IF(IERR.NE.0)CHEXP=1.0 * Initialize NAG. CALL X04AAF(1,10) CALL J06WAF CALL J06WCF(0.1D0,0.9D0,0.1D0,0.9D0) CALL J06WBF(0.0D0,1.0D0,0.0D0,1.0D0,1) IFAIL=0 IF(POLAR)THEN CALL J06HCF(WS,MXWIRE,NGRIDX,NGRIDY,DBLE(THETA), - DBLE(PHI),'Along a radius', - 'Increasing angle',IFAIL) ELSE CALL J06HCF(WS,MXWIRE,NGRIDX,NGRIDY,DBLE(THETA), - DBLE(PHI),'u-axis','v-axis',IFAIL) ENDIF CALL GRNEXT * Reset the CH eXPension factor to the original value, CALL GSCHXP(CHEXP) CALL TIMLOG('Making a 3-dimensional plot: ') CALL GRALOG('3-D plot of '//FUNCT3(1:28)) +SELF,IF=HIGZ. * Check that the surface is not flat. IFLAT=1 SMIN=WS(1,1) SMAX=WS(1,1) DO 80 ICHK=1,NGRIDX DO 70 JCHK=1,NGRIDY IF(ABS(WS(ICHK,JCHK)-WS(1,1)).GT.1.0E-5* - (1.0+ABS(WS(ICHK,JCHK))+ABS(WS(1,1))))IFLAT=0 SMIN=MIN(SMIN,WS(1,1)) SMAX=MAX(SMAX,WS(1,1)) 70 CONTINUE 80 CONTINUE IF(IFLAT.NE.0)THEN PRINT *,' !!!!!! DRFPLT WARNING : The surface is', - ' not plotted because it is entirely flat.' CALL BOOK('RELEASE','MATRIX','SURFACE',IFAIL) GOTO 90 ENDIF * Switch the screen to graphics mode. CALL GRGRAF(.TRUE.) * Fill the PAR vector. PAR(1)=THETA PAR(2)=PHI PAR(3)=VXMIN PAR(4)=VXMAX PAR(5)=VYMIN PAR(6)=VYMAX PAR(7)=SMIN PAR(8)=SMAX PAR(9)=1000+NGRIDX PAR(10)=1000+NGRIDY PAR(11)=510 PAR(12)=510 PAR(13)=510 PAR(14)=1 PAR(15)=1 PAR(16)=1 PAR(17)=0.02 PAR(18)=0.02 PAR(19)=0.02 PAR(20)=0.03 PAR(21)=2 PAR(22)=0.03 PAR(23)=0.03 PAR(24)=0.03 PAR(25)=7 PAR(26)=8 PAR(27)=9 PAR(28)=10 PAR(29)=11 PAR(30)=12 PAR(31)=13 PAR(32)=14 PAR(33)=15 PAR(34)=16 PAR(35)=17 PAR(36)=18 PAR(37)=19 * Plot the surface. CALL ISVP(1,0.1,0.9,0.1,0.9) CALL ISWN(1,0.0,1.0,0.0,1.0) CALL ISELNT(1) CALL IGTABL(MXWIRE,MXWIRE,WS,37,PAR,'S1') * Close the plot. CALL GRNEXT * Record what happened. CALL TIMLOG('Making a 3-dimensional plot: ') CALL GRALOG('3-D plot of '//FUNCT3(1:28)) * Release the matrix. CALL BOOK('RELEASE','MATRIX','SURFACE',IFAIL) +SELF,IF=-NAG,IF=-HIGZ. * No graphics system present to plot the surface. PRINT *,' !!!!!! DRFPLT WARNING : The plotting system', - ' used for this module has no SURFACE facilities.' +SELF. 90 CONTINUE ENDIF * plot the histogram if requested, delete after use. IF(LHIST)THEN CALL HISPLT(IHISRF,FUNCT5(1:NC5), - 'Histogram of '//FUNCT5(1:NC5),.TRUE.) IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) CALL GRNEXT CALL GRALOG('Histogram of '//FUNCT5(1:NC5)//':') CALL TIMLOG('Plotting an histogram of '// - FUNCT5(1:NC5)) CALL HISADM('DELETE',IHISRF,0,0.0,0.0,.FALSE.,IFAIL) ENDIF * print the number of arithmetic errors. CALL ALGERR 120 CONTINUE * release the algebra storage. CALL ALGCLR(IENTRY) ENDIF END +DECK,DCONT. SUBROUTINE DCONT(X0,Y0,FVAL,ILOC) *----------------------------------------------------------------------- * DCONT - Returns the function value of to the contour routine * (Last changed on 12/ 2/99.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,GASDATA. +SEQ,PARAMETERS. +SEQ,DRIFTLINE. +SEQ,PRINTPLOT. REAL RES(1),VAR(MXVAR),QPLT,X0,Y0,FVAL,VOLT INTEGER MODRES(1),MODVAR(MXVAR),ILOC,ILOC1,IENTRY,ITYPE,I,IFAIL DOUBLE PRECISION F0(3),XPOS1,YPOS1,XPOS2,YPOS2 LOGICAL EVALE,EVALB,EVALV,EVALT,EVALD,EVALA,EVALL,EVALP,LMCDR COMMON /CN2DAT/ IENTRY,EVALE,EVALB,EVALV,EVALT,EVALD,EVALA,EVALL, - EVALP,QPLT,ITYPE,LMCDR *** Ensure the location code is defined, also if EVALE is false. ILOC=0 *** Transform the coordinates. VAR(1)= FPROJ(1,1)*X0+FPROJ(2,1)*Y0+FPROJ(3,1) VAR(2)= FPROJ(1,2)*X0+FPROJ(2,2)*Y0+FPROJ(3,2) VAR(23)=FPROJ(1,3)*X0+FPROJ(2,3)*Y0+FPROJ(3,3) *** Calculate the fields needed for the rest. IF(EVALE)CALL EFIELD(VAR(1),VAR(2),VAR(23), - VAR(3),VAR(4),VAR(5),VAR(6),VOLT,0,ILOC) IF(EVALB)CALL BFIELD(VAR(1),VAR(2),VAR(23), - VAR(7),VAR(8),VAR(9),VAR(10)) * Location code -5 (in a material) is acceptable for contours. IF(ILOC.EQ.-5.AND.LCNTAM)ILOC=0 * Get the local drift velocity. IF(EVALV)THEN CALL DLCVEL(DBLE(VAR(1)),DBLE(VAR(2)),DBLE(VAR(23)), - F0,QPLT,ITYPE,ILOC1) VAR(11)=REAL(F0(1)) VAR(12)=REAL(F0(2)) VAR(13)=REAL(F0(3)) VAR(14)=SQRT(VAR(11)**2+VAR(12)**2+VAR(13)**2) ENDIF * Lorentz angle. IF(EVALE.AND.EVALV)VAR(15)=ACOS(MAX(-1.0,MIN(1.0, - REAL((VAR(3)*VAR(11)+VAR(4)*VAR(12)+VAR(5)*VAR(13))/ - (VAR(6)*VAR(14)))))) * Store drift line related quantities. IF(EVALT)THEN CALL DLCALC(VAR(1),VAR(2),VAR(23),QPLT,ITYPE) VAR(16)=TU(NU) IF(EVALP)THEN VAR(17)=0.0 DO 10 I=2,NU IF(POLAR)THEN CALL CF2RTC(XU(I-1),YU(I-1),XPOS1,YPOS1,1) CALL CF2RTC(XU(I) ,YU(I) ,XPOS2,YPOS2,1) VAR(17)=VAR(17)+SQRT((XPOS2-XPOS1)**2+ - (YPOS2-YPOS1)**2+(ZU(I)-ZU(I-1))**2) ELSE VAR(17)=VAR(17)+SQRT((XU(I)-XU(I-1))**2+ - (YU(I)-YU(I-1))**2+(ZU(I)-ZU(I-1))**2) ENDIF 10 CONTINUE ENDIF IF(EVALD)CALL DLCDIF(VAR(18)) IF(EVALA)CALL DLCTWN(VAR(19)) IF(EVALL)CALL DLCATT(VAR(20)) VAR(21)=ISTAT ENDIF * Store gas pressure. VAR(22)=PGAS * Transform vectors and covectors to polar coordinates if needed. IF(POLAR)THEN CALL CFMRTP(VAR(1),VAR(2),VAR(1),VAR(2),1) VAR(3)=VAR(3)/VAR(1) VAR(4)=VAR(4)/VAR(1) VAR(6)=SQRT(VAR(3)**2+VAR(4)**2+VAR(5)**2) VAR(11)=VAR(11)*VAR(1) VAR(12)=VAR(12)*VAR(1) VAR(14)=SQRT(VAR(11)**2+VAR(12)**2+VAR(13)**2) ENDIF * Assign modes. DO 20 I=1,23 MODVAR(I)=2 20 CONTINUE *** Evaluate the function CALL ALGEXE(IENTRY,VAR,MODVAR,23,RES,MODRES,1,IFAIL) * and return it to the contour routine. FVAL=RES(1) END +DECK,DCONT2. SUBROUTINE DCONT2(X0,Y0,Z0,FVAL,ILOC) *----------------------------------------------------------------------- * DCONT2 - Returns the function value for the graphs. * (Last changed on 12/ 2/99.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,GASDATA. +SEQ,PARAMETERS. +SEQ,DRIFTLINE. +SEQ,PRINTPLOT. REAL RES(1),VAR(MXVAR),QPLT,X0,Y0,Z0,FVAL,VOLT INTEGER MODRES(1),MODVAR(MXVAR),ILOC,ILOC1,IENTRY,ITYPE,I,IFAIL DOUBLE PRECISION F0(3),XPOS1,YPOS1,XPOS2,YPOS2 LOGICAL EVALE,EVALB,EVALV,EVALT,EVALD,EVALA,EVALL,EVALP,LMCDR COMMON /CN2DAT/ IENTRY,EVALE,EVALB,EVALV,EVALT,EVALD,EVALA,EVALL, - EVALP,QPLT,ITYPE,LMCDR *** Ensure the location code is defined, also if EVALE is false. ILOC=0 *** Transform the coordinates. VAR(1)= X0 VAR(2)= Y0 VAR(23)=Z0 *** Calculate the fields needed for the rest. IF(EVALE)CALL EFIELD(VAR(1),VAR(2),VAR(23), - VAR(3),VAR(4),VAR(5),VAR(6),VOLT,0,ILOC) IF(EVALB)CALL BFIELD(VAR(1),VAR(2),VAR(23), - VAR(7),VAR(8),VAR(9),VAR(10)) * Location code -5 (in a material) is acceptable for contours. IF(ILOC.EQ.-5.AND.LCNTAM)ILOC=0 * Get the local drift velocity. IF(EVALV)THEN CALL DLCVEL(DBLE(VAR(1)),DBLE(VAR(2)),DBLE(VAR(23)), - F0,QPLT,ITYPE,ILOC1) VAR(11)=REAL(F0(1)) VAR(12)=REAL(F0(2)) VAR(13)=REAL(F0(3)) VAR(14)=SQRT(VAR(11)**2+VAR(12)**2+VAR(13)**2) ENDIF * Lorentz angle. IF(EVALE.AND.EVALV)VAR(15)=ACOS(MAX(-1.0,MIN(1.0, - REAL((VAR(3)*VAR(11)+VAR(4)*VAR(12)+VAR(5)*VAR(13))/ - (VAR(6)*VAR(14)))))) * Store drift line related quantities. IF(EVALT)THEN IF(LMCDR)THEN CALL DLCMC(VAR(1),VAR(2),VAR(23),QPLT,ITYPE) ELSE CALL DLCALC(VAR(1),VAR(2),VAR(23),QPLT,ITYPE) ENDIF VAR(16)=TU(NU) IF(EVALP)THEN VAR(17)=0.0 DO 10 I=2,NU IF(POLAR)THEN CALL CF2RTC(XU(I-1),YU(I-1),XPOS1,YPOS1,1) CALL CF2RTC(XU(I) ,YU(I) ,XPOS2,YPOS2,1) VAR(17)=VAR(17)+SQRT((XPOS2-XPOS1)**2+ - (YPOS2-YPOS1)**2+(ZU(I)-ZU(I-1))**2) ELSE VAR(17)=VAR(17)+SQRT((XU(I)-XU(I-1))**2+ - (YU(I)-YU(I-1))**2+(ZU(I)-ZU(I-1))**2) ENDIF 10 CONTINUE ENDIF IF(EVALD)CALL DLCDIF(VAR(18)) IF(EVALA)CALL DLCTWN(VAR(19)) IF(EVALL)CALL DLCATT(VAR(20)) VAR(21)=ISTAT ENDIF * Store gas pressure. VAR(22)=PGAS * Transform vectors and covectors to polar coordinates if needed. IF(POLAR)THEN CALL CFMRTP(VAR(1),VAR(2),VAR(1),VAR(2),1) VAR(3)=VAR(3)/VAR(1) VAR(4)=VAR(4)/VAR(1) VAR(6)=SQRT(VAR(3)**2+VAR(4)**2+VAR(5)**2) VAR(11)=VAR(11)*VAR(1) VAR(12)=VAR(12)*VAR(1) VAR(14)=SQRT(VAR(11)**2+VAR(12)**2+VAR(13)**2) ENDIF * Assign modes. DO 20 I=1,23 MODVAR(I)=2 20 CONTINUE *** Evaluate the function CALL ALGEXE(IENTRY,VAR,MODVAR,23,RES,MODRES,1,IFAIL) * and return it to the contour routine. FVAL=RES(1) END +DECK,DRFTAB. SUBROUTINE DRFTAB *----------------------------------------------------------------------- * DRFTAB - Subroutine calculating and plotting drift lines given an * electric field. This routine lets the drift lines start on * a grid between (DXMIN,DYMIN) and (DXMAX,DYMAX) * VARIABLES : DTT : The drift time table * LCONT : if .TRUE. plot contours * LTABLE : if .TRUE. print the drift time table * CHTS : used by NAG routine, contour heights * (Last changed on 5/11/97.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,PARAMETERS. +SEQ,CELLDATA. +SEQ,GASDATA. +SEQ,CONSTANTS. +SEQ,PRINTPLOT. +SEQ,DRIFTLINE. CHARACTER*80 STATUS LOGICAL LCONT,LTABLE INTEGER NC,ITYPE REAL Q,XSTART,YSTART +SELF,IF=-HIGZ. DOUBLE PRECISION DTT(MXWIRE,MXWIRE),CHTS(MXWIRE),DUM(3*MXWIRE+3) COMMON /MATRIX/ DTT,CHTS,DUM +SELF,IF=HIGZ. REAL DTT,PAR,DUM COMMON /MATRIX/ DTT(MXWIRE,MXWIRE),PAR(37), - DUM(MXWIRE**2+8*MXWIRE-31) +SELF,IF=NAG. COMMON /LWSCOM/ LWS LOGICAL LWS(MXWIRE**2) EXTERNAL J06GBY,J06GBV +SELF,IF=SAVE. SAVE ITYPE,Q,LCONT,LTABLE +SELF. *** Preset the charge, particle type and the output options. DATA ITYPE / 1/ DATA Q / -1.0/ DATA LCONT /.FALSE./ DATA LTABLE/ .TRUE./ *** Define some formats. 1070 FORMAT('1DRIFT-TABLE',110X,'PART ',I1,'.',I1/122X,'========'// - ' Y X:',10(E11.4,1X:)) 1075 FORMAT('1DRIFT-TABLE',110X,'PART ',I1,'.',I1/122X,'========'// - ' Phi R:',10(E11.4,1X:)) 1080 FORMAT('1 List of drift lines used for the table:',/, - ' ======================================',//, - ' x-start y-start steps drift time', - ' remarks',/, - ' [cm] [cm] [microsec]'//) 1085 FORMAT('1 List of drift lines used for the table:',/, - ' ======================================',//, - ' r-start phi-start steps drift time', - ' remarks',/, - ' [cm] [degrees] [microsec]'//) *** Print a heading, if requested. IF(LIDENT)PRINT *,' /// ROUTINE DRFTAB ///' *** Have a look at the input string CALL INPNUM(NWORD) DO 10 I=2,NWORD IF(INPCMP(I,'NOCONT#OUR').NE.0)THEN LCONT=.FALSE. ELSEIF(INPCMP(I,'CONT#OUR').NE.0)THEN LCONT=.TRUE. +SELF,IF=-NAG,IF=-HIGZ. CALL INPMSG(I,'only in NAG/HIGZ compilations.') LCONT=.FALSE. +SELF. ELSEIF(INPCMP(I,'NOTAB#LE').NE.0)THEN LTABLE=.FALSE. ELSEIF(INPCMP(I,'TAB#LE').NE.0)THEN LTABLE=.TRUE. ELSEIF(INPCMP(I,'I#ON').NE.0)THEN IF(GASOK(2))THEN ITYPE=2 Q=+1 ELSE CALL INPMSG(I,'ion mobility data missing. ') ENDIF ELSEIF(INPCMP(I,'E#LECTRON').NE.0)THEN ITYPE=1 Q=-1 ELSEIF(INPCMP(I,'POS#ITIVE').NE.0)THEN Q=+1 ELSEIF(INPCMP(I,'NEG#ATIVE').NE.0)THEN Q=-1 ELSE CALL INPMSG(I,'the option is not known. ') ENDIF 10 CONTINUE CALL INPERR *** Make sure there is at least some output. IF(.NOT.(LTABLE.OR.LCONT))THEN PRINT *,' !!!!!! DRFTAB WARNING : Neither TABLE nor'// - ' CONTOUR output requested; routine not executed.' RETURN ENDIF *** Allocate storage for the matrix. CALL BOOK('BOOK','MATRIX','DTT',IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! DRFTAB WARNING : Unable to allocate'// - ' storage for the drift time table.' PRINT *,' Neither the table'// - ' nor the plot will be made.' RETURN ENDIF *** Print a heading for the table, depending on the coordinate system. IF(LDRPRT)THEN IF(.NOT.POLAR)WRITE(LUNOUT,1080) IF(POLAR)WRITE(LUNOUT,1085) ENDIF *** Prepare a plot (layout, frame number etc). IF(LDRPLT)THEN CALL GRAXIS(DXMIN,DYMIN,DXMAX,DYMAX, - 'DRIFT LINES FOR A DRIFT TIME TABLE ') CALL CELLAY(DXMIN,DYMIN,DXMAX,DYMAX) IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) IF(GASID.NE.' ')CALL GRCOMM(2,'Gas: '//GASID) CALL GRCOMM(3,'Drifting: electrons') CALL GRALOG('Drift lines for timing table. ') ENDIF *** Start drift lines from all over the grid, DO 20 I=1,NGRIDX DO 30 J=1,NGRIDY IF(POLAR)THEN XSTART=LOG(EXP(DXMIN)+REAL(I-1)*(EXP(DXMAX)-EXP(DXMIN))/ - REAL(NGRIDX-1)) ELSE XSTART=DXMIN+REAL(I-1)*(DXMAX-DXMIN)/REAL(NGRIDX-1) ENDIF YSTART=DYMIN+REAL(J-1)*(DYMAX-DYMIN)/REAL(NGRIDY-1) * calculate the drift line starting at (XSTART,YSTART), CALL DLCALC(XSTART,YSTART,0.0,Q,ITYPE) * and store the drift time in an array, DTT(I,J)=TU(NU) * print information on this drift line if requested, IF(LDRPRT)THEN IF(POLAR)CALL CFMRTP(XSTART,YSTART,XSTART,YSTART,1) CALL DLCSTF(ISTAT,STATUS,NC) WRITE(LUNOUT,'(1X,F10.3,1X,F10.3,I10,1X,E12.5,2X,A)') - XSTART,YSTART,NU,TU(NU),STATUS(1:NC) ENDIF * and plot the drift line obtained - if this is requested. IF(LDRPLT.AND.NU.GT.1)THEN IF(POLAR)CALL CF2RTC(XU,YU,XU,YU,NU) IF(NU.GT.1)CALL GPL2(NU,XU,YU) ENDIF 30 CONTINUE 20 CONTINUE *** Clear the screen if the drift lines have been plotted. IF(LDRPLT)CALL GRNEXT *** Print the table just obtained, if requested. IF(LTABLE)THEN DO 110 JJ=0,10*INT(REAL(NGRIDY-1)/10.0),10 JMAX=MIN(NGRIDY-JJ,10) DO 120 II=0,10*INT(REAL(NGRIDX-1)/10.0),10 IMAX=MIN(NGRIDX-II,10) IF(.NOT.POLAR)THEN WRITE(LUNOUT,1070) 1+II/10,1+JJ/10, - (DXMIN+(DXMAX-DXMIN)*REAL(II+I-1)/REAL(NGRIDX-1), - I=1,IMAX) ELSE WRITE(LUNOUT,1075) 1+II/10,1+JJ/10,(EXP(DXMIN)+ - (EXP(DXMAX)-EXP(DXMIN))*REAL(II+I-1)/ - REAL(NGRIDX-1),I=1,IMAX) ENDIF WRITE(LUNOUT,'('' '')') DO 130 J=1,JMAX YPOS=DYMIN+(DYMAX-DYMIN)*REAL(JJ+J-1)/REAL(NGRIDY-1) IF(POLAR)THEN WRITE(LUNOUT,'(1X,E10.3)') YPOS*180.0/PI ELSE WRITE(LUNOUT,'(1X,E10.3)') YPOS ENDIF WRITE(LUNOUT,'(12X,10(E11.4,1X:))') - (REAL(DTT(II+I,JJ+J)),I=1,IMAX) 130 CONTINUE 120 CONTINUE 110 CONTINUE ENDIF +SELF,IF=NAG. IF(LCONT)THEN * Store the CH eXPansion, NAG has the nasty habit of changing it. CALL GQCHXP(IERR,CHEXP) IF(IERR.NE.0)CHEXP=1.0 * Initialize NAG. CALL X04AAF(1,10) CALL J06XAF IF(.NOT.POLAR)THEN CALL GRAXIS(DXMIN,DYMIN,DXMAX,DYMAX, - 'CONTOURS OF THE DRIFT TIME ') CALL CELLAY(DXMIN,DYMIN,DXMAX,DYMAX) CALL J06WBF(DBLE(DXMIN),DBLE(DXMAX),DBLE(DYMIN), - DBLE(DYMAX),0) ELSE CALL CFMRTP(DXMIN,DYMIN,DXMINP,DYMINP,1) CALL CFMRTP(DXMAX,DYMAX,DXMAXP,DYMAXP,1) CALL GRCART(DXMINP,DYMINP,DXMAXP,DYMAXP, - ' Radial distance [cm]', - ' Angle [degrees]', - 'CONTOURS OF THE DRIFT TIME ') CALL J06WBF(DBLE(DXMINP),DBLE(DXMAXP),DBLE(DYMINP), - DBLE(DYMAXP),0) ENDIF IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) IF(GASID.NE.' ')CALL GRCOMM(2,'Gas: '//GASID) CALL J06WCF(0.1D0,0.9D0,0.1D0,0.9D0) NCHTS=10 IFAIL=1 IF(LKEYPL)THEN ILAB=1 ELSE ILAB=0 ENDIF CALL J06GBF(DTT,MXWIRE,1,NGRIDX,1,NGRIDY,NCHTS,CHTS,0, - J06GBY,ILAB,0,J06GBV,0,LWS,IFAIL) CALL GRNEXT *** Check the error condition returned by J06GBF. IF(IFAIL.EQ.1.OR.IFAIL.EQ.2)THEN PRINT *,' !!!!!! DRFTAB WARNING : Incorect input'// - ' parameters to J06GBF (program bug).' ELSEIF(IFAIL.NE.0)THEN PRINT *,' !!!!!! DRFTAB WARNING : Unknown error flag', - IFAIL,' returned by NAG routine J06GBF.' ENDIF * plot a contour table, if this has been requested. IF(LKEYPL)THEN CALL GRGRAF(.TRUE.) CALL J06GZF(CHTS,NCHTS,1,10,3) CALL GRALOG('Legend of the contour heights. ') CALL GRNEXT ENDIF * Reset the CH eXPension factor to the original value, CALL GSCHXP(CHEXP) ENDIF +SELF,IF=HIGZ. IF(LCONT)THEN * Check that the surface is not flat. IFLAT=1 CZMIN=DTT(1,1) CZMAX=DTT(1,1) DO 80 ICHK=1,NGRIDX DO 70 JCHK=1,NGRIDY IF(ABS(DTT(ICHK,JCHK)-DTT(1,1)).GT.1.0E-5* - (1.0+ABS(DTT(ICHK,JCHK))+ABS(DTT(1,1))))IFLAT=0 CZMIN=MIN(CZMIN,DTT(1,1)) CZMAX=MAX(CZMAX,DTT(1,1)) 70 CONTINUE 80 CONTINUE IF(IFLAT.NE.0)THEN PRINT *,' !!!!!! DRFTAB WARNING : Contours not'// - ' not plotted, all values identical.' GOTO 90 ENDIF * Switch the screen to graphics mode. CALL GRGRAF(.TRUE.) * Fill the PAR vector. PAR(1)=20 PAR(2)=0 PAR(3)=DXMIN PAR(4)=DXMAX PAR(5)=DYMIN PAR(6)=DYMAX PAR(7)=CZMIN PAR(8)=CZMAX PAR(9)=1000+NGRIDX PAR(10)=1000+NGRIDY * Plot a frame for the contours. IF(.NOT.POLAR)THEN CALL GRAXIS(DXMIN,DYMIN,DXMAX,DYMAX, - 'CONTOURS OF THE DRIFT TIME ') CALL CELLAY(DXMIN,DYMIN,DXMAX,DYMAX) PAR(3)=DXMIN PAR(4)=DXMAX PAR(5)=DYMIN PAR(6)=DYMAX ELSE CALL CFMRTP(DXMIN,DYMIN,DXMINP,DYMINP,1) CALL CFMRTP(DXMAX,DYMAX,DXMAXP,DYMAXP,1) CALL GRCART(DXMINP,DYMINP,DXMAXP,DYMAXP, - ' Radial distance [cm]', - ' Angle [degrees]', - 'CONTOURS OF THE DRIFT TIME ') PAR(3)=DXMINP PAR(4)=DXMAXP PAR(5)=DYMINP PAR(6)=DYMAXP ENDIF * Plot the contours. CALL ISVP(1,0.1,0.9,0.1,0.9) CALL ISWN(1,0.0,1.0,0.0,1.0) CALL ISELNT(1) CALL IGTABL(MXWIRE,MXWIRE,DTT,10,PAR,'C') * Close the plot. CALL GRNEXT * Record what happened. CALL GRALOG('Drift time table contours.') * Continue here in case of a flat function. 90 CONTINUE ENDIF +SELF. *** Deallocate the matrix. CALL BOOK('RELEASE','MATRIX','DTT',IFAIL) *** Register the amount of CPU time used for calculating drift lines. CALL TIMLOG('Drift lines for timing table: ') END +DECK,DRFXTP. SUBROUTINE DRFXTP *----------------------------------------------------------------------- * DRFXTP - Routine plotting and printing x(t) correlation plots for * all selected wires in the drift area. * VARIABLES : STRING : (Part of) the command; the header record. * INFILE : Used for producing comment strings. * LXTWRT : TRUE if the x(t) data are to be written. * FILE : Name of the x(t) data set, length NCFILE. * MEMBER : Member name, length NCMEMB. * REMARK : Remark field of the header, length NCREM. * DATE, TIME : Clock date and time (header record). * XSTEP : Sampling step size. * ANGLE : x(t) angle with the y-axis. * JUMP : Number of points to be interpolated. * ITERMX : Max number of minimisation loops. * A.L/R.MIN/MAX : Search angle limits. * P, Q, R(REF): Lines are represented as Px+Qy=R. * PRECIS : Tells whether an XT entry is enterpolated. * IXM, IXP : Sampling is done at X(I)+I*XSTEP I=IXM,IXP * XT( . , ) : 1-3: time, 4-6: C coordinate, 7: diffusion * TPARA, CPARA: Minimum of the fitted parabola. * (Last changed on 8/ 9/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,DRIFTLINE. +SEQ,CELLDATA. +SEQ,GASDATA. +SEQ,PRINTPLOT. +SEQ,PARAMETERS. +SEQ,CONSTANTS. REAL XT(7,MXLIST),XPL(MXLIST),YPL(MXLIST),ANG,QCHARG,P,Q,REF, - GRSMIN,GRSMAX,GMINR,GMAXR,XSTEP,XSTEPR,XXSTEP,XTXMIN,XTXMAX, - ANGLE,ANGLER,EPS,EPSR,CXTMIN,CXTMAX,RDIST,CPARA,TPARA, - CDRIFT,TDRIFT,ALMIN,ALMAX,ALMINR,ALMAXR,ARMIN,ARMAX, - ARMINR,ARMAXR,TMIN,TMAX,XTAUX,XTXMIR,XTXMAR,CSTEP INTEGER NXT(MXLIST),IXTFLG(MXLIST),NCFILE,NCMEMB,NCREM,KX,NWORD, - I,J,INEXT,ITERMX,ITERMR,JUMPR,JUMP,IFAIL,IFAIL1,IFAIL2,NDLC, - IXM,IXP,IIX,IX,JJX,JX,ISET,JSET,IANG,ITERSK,IMIN,ITAB,JTAB, - IOS,NPLOT,ITER,IFLAG,IIMIN,II,INPCMP,INXT LOGICAL XTSET(MXLIST),PRECIS(3),FLAG(MXWORD+3),LXTWRT,PRAUX, - LXTPRT,LXTPLT,EXMEMB CHARACTER*132 OUTSTR CHARACTER*80 STRING CHARACTER*30 INFILE CHARACTER*29 REMARK CHARACTER*(MXNAME) FILE CHARACTER*8 DATE,TIME,MEMBER EXTERNAL INPCMP +SELF,IF=SAVE. SAVE ANGLE,JUMP,ITERMX,EPS,ALMIN,ALMAX,ARMIN,ARMAX +SELF. *** Initialise the parameters to be remembered via DATA statements. DATA ANGLE /0.0/ DATA JUMP,ITERMX /1,5/ DATA EPS /1.0E-3/ DATA ALMIN,ALMAX,ARMIN,ARMAX /-90.0,90.0,-90.0,90.0/ DATA LXTPRT,LXTPLT /.TRUE.,.TRUE./ *** Define some formats. 1080 FORMAT('Angle to y =',F8.2,' degrees ') 1090 FORMAT('Wire no =',I3,' (type ',A1,') ') *** Identify the routine. IF(LIDENT)PRINT *,' /// ROUTINE DRFXTP ///' *** Preset some of the arguments. FILE=' ' MEMBER='< none >' REMARK='None' NCFILE=1 NCMEMB=8 NCREM=4 LXTWRT=.FALSE. GRSMIN=+1.0 GRSMAX=-1.0 * And obtain a rounded default value for the x-step. XSTEP=(DXMAX-DXMIN)/20.0 KX=NINT(LOG10(XSTEP)) IF(KX.GE.0)THEN XSTEP=XSTEP/10.0**KX ELSE XSTEP=XSTEP*10.0**(-KX) ENDIF IF(XSTEP.GE.0.1.AND.XSTEP.LT.0.2)THEN XXSTEP=0.1 ELSEIF(XSTEP.GE.0.2.AND.XSTEP.LT.0.5)THEN XXSTEP=0.2 ELSEIF(XSTEP.GE.0.5.AND.XSTEP.LT.1.0)THEN XXSTEP=0.5 ELSEIF(XSTEP.GE.1.0.AND.XSTEP.LT.2.0)THEN XXSTEP=1.0 ELSEIF(XSTEP.GE.2.0.AND.XSTEP.LT.5.0)THEN XXSTEP=2.0 ELSEIF(XSTEP.GE.5.0.AND.XSTEP.LT.10.0)THEN XXSTEP=5.0 ELSE PRINT *,' !!!!!! DRFXTP WARNING : Unable to find a default', - ' x-step; set to 1.' XXSTEP=1.0 ENDIF IF(KX.GE.0)THEN XSTEP=XXSTEP*10.0**KX ELSE XSTEP=XXSTEP/10.0**(-KX) ENDIF * Finally also set the range in x to the full range. XTXMIN=DXMIN XTXMAX=DXMAX *** Extract the parameters from the input. CALL INPNUM(NWORD) * Initialise the FLAG array. DO 10 I=1,MXWORD+3 IF(I.LE.NWORD)THEN FLAG(I)=.FALSE. ELSE FLAG(I)=.TRUE. ENDIF 10 CONTINUE * Mark the keywords. DO 20 I=1,NWORD IF(INPCMP(I,'ANG#LE')+INPCMP(I,'D#ATASET')+INPCMP(I,'J#UMP')+ - INPCMP(I,'L#EFT-#ANGLE-#RANGE')+INPCMP(I,'NO#NE')+ - INPCMP(I,'IT#ERATIONS')+INPCMP(I,'OFF')+ - INPCMP(I,'PREC#ISION')+INPCMP(I,'RAN#GE')+ - INPCMP(I,'REM#ARK')+INPCMP(I,'RI#GHT-#ANGLE-#RANGE')+ - INPCMP(I,'ST#EP')+INPCMP(I,'SC#ALE')+ - INPCMP(I,'PR#INT-#XT-#RELATION')+ - INPCMP(I,'NOPR#INT-#XT-#RELATION')+ - INPCMP(I,'PL#OT-#XT-#RELATION')+ - INPCMP(I,'NOPL#OT-#XT-#RELATION')+ - INPCMP(I,'X-ST#EP')+ - INPCMP(I,'X-R#ANGE').NE.0)FLAG(I)=.TRUE. 20 CONTINUE ** Next interpret the words. INEXT=2 DO 30 I=2,NWORD IF(I.LT.INEXT)GOTO 30 * Look for the ANGLE at which the tracks are going to be. IF(INPCMP(I,'ANG#LE').NE.0)THEN IF(FLAG(I+1))THEN CALL INPMSG(I,'the argument is missing. ') ELSE CALL INPCHK(I+1,2,IFAIL) CALL INPRDR(I+1,ANGLER,0.0) IF(ABS(ANGLER).GT.90.0.AND.IFAIL.EQ.0)THEN CALL INPMSG(I+1,'Too large an angle (Max = 90).') ELSEIF(IFAIL.EQ.0)THEN ANGLE=ANGLER ENDIF INEXT=I+2 ENDIF * Look for a DATASET (and perhaps a member) receiving the x(t)'s. ELSEIF(INPCMP(I,'D#ATASET').NE.0)THEN IF(FLAG(I+1))THEN CALL INPMSG(I,'the dataset name is missing. ') ELSE CALL INPSTR(I+1,I+1,STRING,NCFILE) FILE=STRING IF(.NOT.FLAG(I+2))THEN CALL INPSTR(I+2,I+2,STRING,NCMEMB) MEMBER=STRING INEXT=I+3 ELSE INEXT=I+2 ENDIF LXTWRT=.TRUE. ENDIF * Look for the number of ITERATION cycles. ELSEIF(INPCMP(I,'IT#ERATIONS').NE.0)THEN IF(INPCMP(I+1,'OFF')+INPCMP(I+1,'NO#NE').NE.0)THEN ITERMX=0 INEXT=I+2 ELSEIF(FLAG(I+1))THEN CALL INPMSG(I,'Argument (n or OFF) missing. ') ELSE CALL INPCHK(I+1,1,IFAIL) CALL INPRDI(I+1,ITERMR,5) IF(IFAIL.EQ.0.AND.ITERMR.LT.0)THEN CALL INPMSG(I+1,'Should be a positive integer. ') ELSEIF(IFAIL.EQ.0)THEN ITERMX=ITERMR ENDIF INEXT=I+2 ENDIF * Look for the number of intermediate points to be JUMPed. ELSEIF(INPCMP(I,'J#UMP').NE.0)THEN IF(FLAG(I+1))THEN CALL INPMSG(I,'the argument is missing. ') ELSE CALL INPCHK(I+1,1,IFAIL) CALL INPRDI(I+1,JUMPR,10) IF(JUMPR.LE.0.AND.IFAIL.EQ.0)THEN CALL INPMSG(I+1,'should be a positive number. ') ELSEIF(IFAIL.EQ.0)THEN JUMP=JUMPR ENDIF INEXT=I+2 ENDIF * Look for the LEFT-ANGLE-RANGE. ELSEIF(INPCMP(I,'L#EFT-#ANGLE-#RANGE').NE.0)THEN IF(FLAG(I+1).OR.FLAG(I+2))THEN CALL INPMSG(I,'The angle-range is incomplete.') IF(.NOT.FLAG(I+1).AND.FLAG(I+2))INEXT=I+2 ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPCHK(I+2,2,IFAIL2) CALL INPRDR(I+1,ALMINR,ALMIN) CALL INPRDR(I+2,ALMAXR,ALMAX) IF(ABS(ALMINR).GT.90.0.AND.IFAIL1.EQ.0)THEN CALL INPMSG(I,'See the next message. ') CALL INPMSG(I+1,'Not between -90 and +90 degr. ') ELSEIF(ABS(ALMAXR).GT.90.0.AND.IFAIL2.EQ.0)THEN CALL INPMSG(I,'See the next message. ') CALL INPMSG(I+2,'Not between -90 and +90 degr. ') ELSEIF(IFAIL1.EQ.0.AND.IFAIL2.EQ.0)THEN ALMIN=MIN(ALMINR,ALMAXR) ALMAX=MAX(ALMINR,ALMAXR) ENDIF INEXT=I+3 ENDIF * Look for the PRECISION (convergence parameter). ELSEIF(INPCMP(I,'PREC#ISION').NE.0)THEN IF(FLAG(I+1))THEN CALL INPMSG(I,'The argument is missing. ') ELSE CALL INPCHK(I+1,2,IFAIL) CALL INPRDR(I+1,EPSR,EPS) IF(EPSR.LE.0.AND.IFAIL.EQ.0)THEN CALL INPMSG(I+1,'Should be a positive number. ') ELSEIF(IFAIL.EQ.0)THEN EPS=EPSR ENDIF INEXT=I+2 ENDIF * Look for a REMARK replacing the default remark in the header, ELSEIF(INPCMP(I,'REM#ARK').NE.0)THEN IF(FLAG(I+1))THEN CALL INPMSG(I,'No remark has been found. ') ELSE CALL INPSTR(I+1,I+1,STRING,NCREM) REMARK=STRING(1:NCREM) INEXT=I+2 ENDIF * Look for the RIGHT-ANGLE-RANGE. ELSEIF(INPCMP(I,'RI#GHT-#ANGLE-#RANGE').NE.0)THEN IF(FLAG(I+1).OR.FLAG(I+2))THEN CALL INPMSG(I,'The angle-range is incomplete.') IF(.NOT.FLAG(I+1).AND.FLAG(I+2))INEXT=I+2 ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPCHK(I+2,2,IFAIL2) CALL INPRDR(I+1,ARMINR,ARMIN) CALL INPRDR(I+2,ARMAXR,ARMAX) IF(ABS(ARMINR).GT.90.0.AND.IFAIL1.EQ.0)THEN CALL INPMSG(I,'See the next message. ') CALL INPMSG(I+1,'Not between -90 and +90 degr. ') ELSEIF(ABS(ARMAXR).GT.90.0.AND.IFAIL2.EQ.0)THEN CALL INPMSG(I,'See the next message. ') CALL INPMSG(I+2,'Not between -90 and +90 degr. ') ELSEIF(IFAIL1.EQ.0.AND.IFAIL2.EQ.0)THEN ARMIN=MIN(ARMINR,ARMAXR) ARMAX=MAX(ARMINR,ARMAXR) ENDIF INEXT=I+3 ENDIF * Look for the plotting scale. ELSEIF(INPCMP(I,'SC#ALE').NE.0)THEN IF(FLAG(I+1).OR.FLAG(I+2))THEN CALL INPMSG(I,'the arguments are missing. ') ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,GMINR,+1.0) CALL INPCHK(I+2,2,IFAIL2) CALL INPRDR(I+2,GMAXR,-1.0) IF(GMINR.EQ.GMAXR)THEN CALL INPMSG(I+1,'zero range in the') CALL INPMSG(I+2,'scale not permitted') ELSE GRSMIN=MIN(GMINR,GMAXR) GRSMAX=MAX(GMINR,GMAXR) ENDIF INEXT=I+3 ENDIF * Look for a X-STEP size, if the default is not suitable. ELSEIF(INPCMP(I,'X-ST#EP')+INPCMP(I,'ST#EP').NE.0)THEN IF(FLAG(I+1))THEN CALL INPMSG(I,'The argument is missing. ') ELSE CALL INPCHK(I+1,2,IFAIL) CALL INPRDR(I+1,XSTEPR,XSTEP) IF(XSTEPR.LE.0.0.AND.IFAIL.EQ.0)THEN CALL INPMSG(I+1,'Should be a positive number. ') ELSEIF(XSTEPR.LT.(DXMAX-DXMIN)/MXLIST.AND. - IFAIL.EQ.0)THEN CALL INPMSG(I+1,'Too small, increase MXLIST. ') ELSEIF(IFAIL.EQ.0)THEN XSTEP=XSTEPR ENDIF INEXT=I+2 ENDIF * Look for an X-RANGE keyword. ELSEIF(INPCMP(I,'X-R#ANGE')+INPCMP(I,'RAN#GE').NE.0)THEN IF(FLAG(I+1))THEN CALL INPMSG(I,'Should have two arguments. ') ELSEIF(FLAG(I+2))THEN CALL INPMSG(I,'Should have two arguments. ') CALL INPMSG(I+1,'Argument can not be used. ') INEXT=I+2 ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPCHK(I+2,2,IFAIL2) CALL INPRDR(I+1,XTXMIR,DXMIN) CALL INPRDR(I+2,XTXMAR,DXMAX) IF(XTXMIR.EQ.XTXMAR)THEN CALL INPMSG(I+1,'Zero range not permitted. ') CALL INPMSG(I+2,'See the preceding message. ') ELSEIF((XTXMIR.LT.DXMIN.AND.XTXMAR.LT.DXMIN).OR. - (XTXMIR.GT.DXMAX.AND.XTXMAR.GT.DXMAX))THEN CALL INPMSG(I+1,'Range falls outside the area. ') CALL INPMSG(I+2,'See the preceding message. ') ELSE XTXMIN=MAX(MIN(XTXMIR,XTXMAR),DXMIN) XTXMAX=MIN(MAX(XTXMIR,XTXMAR),DXMAX) ENDIF INEXT=I+3 ENDIF * Printing options. ELSEIF(INPCMP(I,'PR#INT-#XT-#RELATION').NE.0)THEN LXTPRT=.TRUE. ELSEIF(INPCMP(I,'NOPR#INT-#XT-#RELATION').NE.0)THEN LXTPRT=.FALSE. * Plotting options. ELSEIF(INPCMP(I,'PL#OT-#XT-#RELATION').NE.0)THEN LXTPLT=.TRUE. ELSEIF(INPCMP(I,'NOPL#OT-#XT-#RELATION').NE.0)THEN LXTPLT=.FALSE. * OFF and NONE keywords out of sequence. ELSEIF(INPCMP(I,'OFF')+INPCMP(I,'NO#NE').NE.0)THEN CALL INPMSG(I,'Valid keyword out of sequence.') * Unknown keywords. ELSE CALL INPMSG(I,'The option is not known. ') ENDIF 30 CONTINUE * Print error messages. CALL INPERR * And check the length of the various identifiers. IF(NCFILE.GT.MXNAME)PRINT *,' !!!!!! DRFXTP WARNING : The file'// - ' name is truncated to MXNAME (=',MXNAME,') characters.' IF(NCMEMB.GT.8)PRINT *,' !!!!!! DRFXTP WARNING : The member'// - ' name is shortened to '//MEMBER//', first 8 characters.' IF(NCREM.GT.29)PRINT *,' !!!!!! DRFXTP 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. IF(LXTWRT)THEN CALL DSNREM(FILE(1:NCFILE),MEMBER(1:NCMEMB),'XTPLOT',EXMEMB) IF(JEXMEM.EQ.2.AND.EXMEMB)THEN PRINT *,' ------ DRFXTP MESSAGE : A copy of the'// - ' member exists; new member will be appended.' ELSEIF(JEXMEM.EQ.3.AND.EXMEMB)THEN PRINT *,' !!!!!! DRFXTP WARNING : A copy of the'// - ' member exists already; member will not be'// - ' written.' LXTWRT=.FALSE. ENDIF ENDIF * Define the line parameters P and Q such that P*X + Q*Y = R. P=COS(-PI*ANGLE/180.0) Q=SIN(-PI*ANGLE/180.0) * Set the drift-line counter to 0 initially. NDLC=0 *** Print some preliminary debugging output. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DRFXTP DEBUG : Start of'', - '' debugging output''//26X,''Current driftline parameters''/ - 26X,''RTRAP ='',F10.3,'' EPSDIF= '',E10.3,'' NLINED= '',I10/ - 26X,''AREA = ('',E10.3,'','',E10.3,'') ('',E10.3,'','', - E10.3,'')''/)') RTRAP,EPSDIF,NLINED,DXMIN,DYMIN,DXMAX,DYMAX IF(LDEBUG)WRITE(LUNOUT,'(26X,''Current x(t) specific settings''/ - 26X,''ANGLE = '',F10.3,'' P = '',E10.3,'' Q = '',E10.3/ - 26X,''XSTEP = '',E10.3,'' ITERMX = '',I6,'' JUMP = '',I6/ - 26X,''XTXMIN = '',E10.3,'' XTXMAX = '',E10.3)') - ANGLE,P,Q,XSTEP,ITERMX,JUMP,XTXMIN,XTXMAX IF(LDEBUG)WRITE(LUNOUT,'(26X,''Angles left: '',2E10.3,/ - 26X,''Angles right: '',2E10.3,/, - 26X,''EPS = '',E10.3)') ALMIN,ALMAX,ARMIN,ARMAX,EPS IF(LDEBUG)WRITE(LUNOUT,'(26X,''LXTWRT='',L1,'', FILE='',A,'','', - /26X,''MEMBER='',A,'', REMARK='',A)') - LXTWRT,FILE(1:NCFILE),MEMBER(1:NCMEMB),REMARK(1:NCREM) *** Pick the wires located inside the drift area. DO 100 I=1,NWIRE IF(X(I).LT.DXMIN.OR.X(I).GT.DXMAX.OR. - Y(I).LT.DYMIN.OR.Y(I).GT.DYMAX.OR.INDSW(I).EQ.0)GOTO 100 IF(LDEBUG)WRITE(LUNOUT,'(/26X,''Wire '',I3,'' (type '',A1, - '') at '',2F10.3,'' selected.'')') I,WIRTYP(I),X(I),Y(I) * Set the IXM and IXP parameters to ensure that the area is not left. IXM=JUMP*ANINT((XTXMIN-X(I))/(JUMP*XSTEP)) IXP=JUMP*ANINT((XTXMAX-X(I))/(JUMP*XSTEP)) IF(X(I)+IXM*XSTEP.LT.XTXMIN)IXM=IXM+JUMP IF(X(I)+IXP*XSTEP.GT.XTXMAX)IXP=IXP-JUMP * Check we remain in the storage allocated for the list. IF(IXP-IXM+1.GT.MXLIST)THEN PRINT *,' !!!!!! DRFXTP WARNING : No x(t) for wire ',I, - ' because MXLIST is too small.' PRINT *,' Consider making X-STEP'// - ' larger or choose a smaller AREA.' GOTO 100 ENDIF * Draw a set of axis if LDRPLT is on. IF(LDRPLT)THEN CALL GRAXIS(DXMIN,DYMIN,DXMAX,DYMAX, - 'DRIFT LINES USED FOR THE X(T) PLOT ') CALL CELLAY(DXMIN,DYMIN,DXMAX,DYMAX) IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) IF(GASID.NE.' ')CALL GRCOMM(2,'Gas: '//GASID) CALL GRATTS('E-DRIFT-LINE','POLYLINE') ENDIF *** Initialise the arrays for this wire. DO 110 ISET=1,MXLIST DO 105 JSET=1,7 XT(JSET,ISET)=0.0 105 CONTINUE NXT(ISET)=0 XTSET(ISET)=.FALSE. IXTFLG(ISET)=-11 110 CONTINUE *** Initialise the maximum and minimum of the C range. CXTMIN=Q*X(I)-P*Y(I) CXTMAX=Q*X(I)-P*Y(I) *** Loop around the wire to get a rough picture of the x(t) relation. QCHARG=1.0 DO 120 IANG=-NLINED/2,NLINED/2 * Translate into an angle taking the limits into account. IF(IANG.LT.0)THEN IF(NLINED.GT.2)THEN ANG=180.0+ALMIN+REAL(-IANG-1)*(ALMAX-ALMIN)/ - REAL(NLINED/2-1) ELSE ANG=180.0+0.5*(ALMIN+ALMAX) ENDIF ELSEIF(IANG.GT.0)THEN IF(NLINED.GT.2)THEN ANG=ARMIN+REAL(IANG-1)*(ARMAX-ARMIN)/REAL(NLINED/2-1) ELSE ANG=0.5*(ARMIN+ARMAX) ENDIF ELSE GOTO 120 ENDIF * Convert to radians. ANG=ANG*PI/180.0 * Calculate a radial drift-line. RDIST=D(I)*(0.5+1.0E-4*(1.0+MAX(ABS(X(I)),ABS(Y(I))))) IF(LDEBUG)PRINT *,' ++++++ DRFXTP DEBUG : RDIST/D=',RDIST/D(I) CALL DLCALC(X(I)+RDIST*COS(ANG),Y(I)+RDIST*SIN(ANG),0.0,QCHARG,1) * Plot and print data id requested. IF(LDRPLT.AND.NU.GT.1)CALL GPL2(NU,XU,YU) NDLC=NDLC+1 IF(LDEBUG)WRITE(LUNOUT,'(26X,''Angle='',F10.3,'' ISTAT='',I3, - '' NU='',I3)') 180.0*ANG/PI,ISTAT,NU *** Loop over the points for which a t is to be found. DO 130 IIX=IXM,IXP,JUMP IX=IIX-IXM+1 REF=P*(X(I)+IIX*XSTEP)+Q*Y(I) * Find the lowest t intersection for each x. CALL DRFXT1(P,Q,REF,CDRIFT,TDRIFT,IFAIL) IF(IFAIL.NE.0)GOTO 130 * Keep track of the extrema of C. IF(CXTMIN.GT.CDRIFT)CXTMIN=CDRIFT IF(CXTMAX.LT.CDRIFT)CXTMAX=CDRIFT * And store it in its proper place in XT(,IX). IF(NXT(IX).EQ.0)THEN XT(1,IX)=TDRIFT XT(4,IX)=CDRIFT NXT(IX)=1 ELSE DO 150 ITAB=1,NXT(IX) IF(ABS(TDRIFT-XT(ITAB,IX)).LE.1E-4*ABS(TDRIFT).AND. - ABS(CDRIFT-XT(ITAB+3,IX)).LE.1E-4*ABS(CDRIFT))THEN IF(LDEBUG)PRINT *,' ++++++ DRFXTP DEBUG : Not'// - ' storing this point (coincides).' GOTO 130 ENDIF IF(TDRIFT.LT.XT(ITAB,IX))THEN DO 160 JTAB=3,ITAB+1,-1 XT(JTAB,IX)=XT(JTAB-1,IX) XT(JTAB+3,IX)=XT(JTAB+2,IX) 160 CONTINUE XT(ITAB,IX)=TDRIFT XT(ITAB+3,IX)=CDRIFT GOTO 170 ENDIF 150 CONTINUE IF(NXT(IX).LT.3)THEN XT(NXT(IX)+1,IX)=TDRIFT XT(NXT(IX)+4,IX)=CDRIFT ENDIF 170 CONTINUE NXT(IX)=MIN(3,NXT(IX)+1) ENDIF XTSET(IX)=.TRUE. 130 CONTINUE 120 CONTINUE * Output the C extrema for debugging purposes, if requested. IF(LDEBUG)WRITE(LUNOUT,'(/26X,''Extrema for C are: '',2E15.8)') - CXTMIN,CXTMAX * And set the C-stepping size. CSTEP=ABS(CXTMAX-CXTMIN)/2.0 IF(CSTEP.LT.ABS(DYMAX-DYMIN)/(100.0*P))THEN CSTEP=(DYMAX-DYMIN)/(10.0*P) IF(LDEBUG)WRITE(LUNOUT,'(26X,''CSTEP too small, replaced'', - '' by'',E15.8,''.'')') CSTEP ENDIF *** Find more accurate values for all data points. QCHARG=-1.0 DO 200 IIX=IXM,IXP,JUMP * IX is a shorthand for the array indices corresponding with IIX. IX=IIX-IXM+1 * Set the track parameter. REF=P*(X(I)+IIX*XSTEP)+Q*Y(I) * Take correct action in case this point coincides with the wire. IF(IIX.EQ.0)THEN IF(LDEBUG)WRITE(LUNOUT,'(26X,''Point '',I3,'' coincides'', - '' with the wire, no minimisation.'')') IX XTSET(IX)=.TRUE. XT(1,IX)=0.0 XT(4,IX)=P*X(I)+Q*Y(I) XT(7,IX)=0.0 IXTFLG(IX)=-1 GOTO 200 ENDIF * Print the crude infomation we have so far, if debugging is on. IF(LDEBUG)THEN WRITE(LUNOUT,'(/26X,''Start of minimisation for point '',I3, - '' XTSET='',L1,'' NXT='',I3,/)') IX,XTSET(IX),NXT(IX) DO 205 INXT=1,NXT(IX) WRITE(LUNOUT,'(26X,'' c'',I1,''='',E15.8,'', t'',I1,''='', - E15.8)') INXT,XT(INXT+3,IX),INXT,XT(INXT,IX) 205 CONTINUE WRITE(*,'('' '')') ENDIF ** Next try to find 3 points forming a parabola. Case 1: no points. IF(NXT(IX).EQ.0)THEN IF(LDEBUG)WRITE(LUNOUT,'(26X,''Crude information absent'', - '' for this data-point, it is skipped.'')') IXTFLG(IX)=-2 GOTO 200 ENDIF ** Suppose we already have 3 points, make sure iteration makes sense. ITERSK=0 IF(NXT(IX).EQ.3)THEN CALL DRFXT2(XT(4,IX),XT(1,IX),XT(5,IX),XT(2,IX), - XT(6,IX),XT(3,IX),CPARA,TPARA,IFAIL,IFLAG) IF(IFLAG.EQ.+1.AND.IFAIL.EQ.0.AND. - ABS(TPARA-XT(1,IX)).LT.EPS*(TPARA+XT(1,IX)).AND. - (CPARA-MAX(XT(4,IX),XT(5,IX),XT(6,IX)))* - (CPARA-MIN(XT(4,IX),XT(5,IX),XT(6,IX))).LE.0)THEN ITERSK=1 IF(LDEBUG)WRITE(LUNOUT,'(26X,''Minimisation is not'', - '' meaningful: TPARA='',E15.8)') TPARA ENDIF ENDIF ** If no iteration has been requested, simply recalculate. IF(ITERMX.EQ.0.OR.ITERSK.EQ.1)THEN CALL DLCALC(P*REF+Q*XT(4,IX),Q*REF-P*XT(4,IX),0.0,QCHARG,1) IF(LDRPLT.AND.NU.GT.1)CALL GPL2(NU,XU,YU) NDLC=NDLC+1 IF(ISTAT.EQ.I)THEN XT(1,IX)=TU(NU) IF(LDEBUG)WRITE(LUNOUT,'(26X,''Precise value of t='', - E15.8,''.'')') XT(1,IX) IXTFLG(IX)=0 GOTO 310 ELSE IF(LDEBUG)WRITE(LUNOUT,'(26X,''Recalculation of'', - ''crude drift-line returns ISTAT='',I3)') ISTAT XTSET(IX)=.FALSE. IXTFLG(IX)=-3 GOTO 200 ENDIF ENDIF * Also initialise the PRECIS list. PRECIS(1)=.FALSE. PRECIS(2)=.FALSE. PRECIS(3)=.FALSE. ** In case there is a single crossing, add one new point. IF(NXT(IX).EQ.1)THEN IF(LDEBUG)WRITE(LUNOUT,'(26X,''One data point, search'', - '' for one new point towards the C range middle.'')') ITER=0 IF(XT(5,IX).GT.(CXTMAX-CXTMIN)/2.0)THEN XT(5,IX)=XT(4,IX)-CSTEP ELSE XT(5,IX)=XT(4,IX)+CSTEP ENDIF 210 CONTINUE CALL DLCALC(P*REF+Q*XT(5,IX),Q*REF-P*XT(5,IX),0.0,QCHARG,1) IF(LDRPLT.AND.NU.GT.1)CALL GPL2(NU,XU,YU) NDLC=NDLC+1 XT(2,IX)=TU(NU) PRECIS(2)=.TRUE. IF(LDEBUG)WRITE(LUNOUT,'(26X,''ITER='',I2,'', C='',E15.8, - '', T='',E15.8,'', ISTAT='',I3)') - ITER,XT(5,IX),XT(2,IX),ISTAT IF(ISTAT.NE.I)THEN XT(5,IX)=0.5*(XT(4,IX)+XT(5,IX)) ITER=ITER+1 IF(ITER.LE.ITERMX)GOTO 210 IF(LDEBUG)WRITE(LUNOUT,'(26X,''2nd point not found'')') IXTFLG(IX)=-4 XTSET(IX)=.FALSE. GOTO 200 ELSEIF(XT(2,IX).LT.XT(1,IX))THEN IF(LDEBUG)WRITE(LUNOUT,'(26X,''Second data point'', - '' has a T < T0, data points swapped.'')') XTAUX=XT(1,IX) XT(1,IX)=XT(2,IX) XT(2,IX)=XTAUX XTAUX=XT(4,IX) XT(4,IX)=XT(5,IX) XT(5,IX)=XTAUX PRAUX=PRECIS(1) PRECIS(1)=PRECIS(2) PRECIS(2)=PRAUX ENDIF NXT(IX)=2 ENDIF * Add a third point in the event there are two data points. IF(NXT(IX).EQ.2)THEN IF(LDEBUG)WRITE(LUNOUT,'(26X,''Two data points so far,'', - '' adding a point at a mirrored C.'')') ITER=0 XT(6,IX)=2*XT(4,IX)-XT(5,IX) 220 CONTINUE CALL DLCALC(P*REF+Q*XT(6,IX),Q*REF-P*XT(6,IX),0.0,QCHARG,1) IF(LDRPLT.AND.NU.GT.1)CALL GPL2(NU,XU,YU) NDLC=NDLC+1 XT(3,IX)=TU(NU) PRECIS(3)=.TRUE. IF(LDEBUG)WRITE(LUNOUT,'(26X,''ITER='',I2,'', C='',E15.8, - '', T='',E15.8,'', ISTAT='',I3)') - ITER,XT(6,IX),XT(3,IX),ISTAT IF(ISTAT.NE.I)THEN XT(6,IX)=0.5*(XT(4,IX)+XT(6,IX)) ITER=ITER+1 IF(ITER.LE.ITERMX)GOTO 220 IF(LDEBUG)WRITE(LUNOUT,'(26X,''3rd point not found'')') XTSET(IX)=.FALSE. IXTFLG(IX)=-5 GOTO 200 ELSEIF(XT(3,IX).LT.XT(1,IX))THEN IF(LDEBUG)WRITE(LUNOUT,'(26X,''Third data point'', - '' has a T < T0, data points swapped.'')') XTAUX=XT(1,IX) XT(1,IX)=XT(3,IX) XT(3,IX)=XTAUX XTAUX=XT(4,IX) XT(4,IX)=XT(6,IX) XT(6,IX)=XTAUX PRAUX=PRECIS(1) PRECIS(1)=PRECIS(3) PRECIS(3)=PRAUX ENDIF NXT(IX)=3 ENDIF ** Parabolic minimisation itself, first sort the XT array. IF(XT(4,IX).GT.XT(5,IX))THEN XTAUX=XT(2,IX) XT(2,IX)=XT(1,IX) XT(1,IX)=XTAUX XTAUX=XT(5,IX) XT(5,IX)=XT(4,IX) XT(4,IX)=XTAUX PRAUX=PRECIS(2) PRECIS(2)=PRECIS(1) PRECIS(1)=PRAUX ENDIF IF(XT(5,IX).GT.XT(6,IX))THEN XTAUX=XT(3,IX) XT(3,IX)=XT(2,IX) XT(2,IX)=XTAUX XTAUX=XT(6,IX) XT(6,IX)=XT(5,IX) XT(5,IX)=XTAUX PRAUX=PRECIS(3) PRECIS(3)=PRECIS(2) PRECIS(2)=PRAUX ENDIF IF(XT(4,IX).GT.XT(5,IX))THEN XTAUX=XT(2,IX) XT(2,IX)=XT(1,IX) XT(1,IX)=XTAUX XTAUX=XT(5,IX) XT(5,IX)=XT(4,IX) XT(4,IX)=XTAUX PRAUX=PRECIS(2) PRECIS(2)=PRECIS(1) PRECIS(1)=PRAUX ENDIF * Calculate exact drift time for one of the side points. IF(.NOT.PRECIS(1))THEN CALL DLCALC(P*REF+Q*XT(4,IX),Q*REF-P*XT(4,IX),0.0,QCHARG,1) IF(LDRPLT.AND.NU.GT.1)CALL GPL2(NU,XU,YU) NDLC=NDLC+1 XT(1,IX)=TU(NU) PRECIS(1)=.TRUE. ENDIF * Calculate exact drift time for the middle point, if not yet done. IF(.NOT.PRECIS(2))THEN CALL DLCALC(P*REF+Q*XT(5,IX),Q*REF-P*XT(5,IX),0.0,QCHARG,1) IF(LDRPLT.AND.NU.GT.1)CALL GPL2(NU,XU,YU) NDLC=NDLC+1 XT(2,IX)=TU(NU) PRECIS(2)=.TRUE. ENDIF * Calculate exact drift time for the other side point. IF(.NOT.PRECIS(3))THEN CALL DLCALC(P*REF+Q*XT(6,IX),Q*REF-P*XT(6,IX),0.0,QCHARG,1) IF(LDRPLT.AND.NU.GT.1)CALL GPL2(NU,XU,YU) NDLC=NDLC+1 XT(3,IX)=TU(NU) PRECIS(3)=.TRUE. ENDIF ** Starting point found, now proceed with parabolic minimisation. DO 300 J=1,ITERMX IF(LDEBUG)WRITE(LUNOUT,'(/26X,''Parabolic search loop '',I2,/, - 29X,''C,T low ='',E15.8,'', '',E15.8,'', Prec='',L1,/, - 29X,''C,T middle='',E15.8,'', '',E15.8,'', Prec='',L1,/, - 29X,''C,T high ='',E15.8,'', '',E15.8,'', Prec='',L1,/)') - J,(XT(II+3,IX),XT(II,IX),PRECIS(II),II=1,3) * Fit a parabola to the three points. CALL DRFXT2(XT(4,IX),XT(1,IX),XT(5,IX),XT(2,IX), - XT(6,IX),XT(3,IX),CPARA,TPARA,IFAIL,IFLAG) IF(IFLAG.NE.+1.OR.IFAIL.NE.0)THEN IF(LDEBUG)WRITE(LUNOUT,'(26X,''DRFXT2 returns on IFAIL='', - I2,'', IFLAG='',I2)') IFAIL,IFLAG XTSET(IX)=.FALSE. IXTFLG(IX)=-6 GOTO 200 ENDIF * Check whether the fit is at all acceptable. IF(XT(1,IX).GT.XT(2,IX).AND.XT(3,IX).GT.XT(2,IX).AND. - (CPARA-XT(4,IX))*(CPARA-XT(6,IX)).GE.0)THEN IF(LDEBUG)WRITE(LUNOUT,'(26X,''Inadequate fit.'')') IXTFLG(IX)=-10 XTSET(IX)=.FALSE. GOTO 200 ENDIF * Calculate a drift-line from the presumed minimum. CALL DLCALC(P*REF+Q*CPARA,Q*REF-P*CPARA,0.0,QCHARG,1) IF(LDRPLT.AND.NU.GT.1)CALL GPL2(NU,XU,YU) NDLC=NDLC+1 IF(ISTAT.NE.I)THEN IF(LDEBUG)WRITE(LUNOUT,'(26X,''Wire lost ISTAT='',I3)')ISTAT XTSET(IX)=.FALSE. IXTFLG(IX)=-3 GOTO 200 ENDIF * Print some debugging output if requested about the minimum. IF(LDEBUG)WRITE(LUNOUT,'(26X,''CPARA='',E15.8,'', TPARA='', - E15.8,'', TU(NU)='',E15.8)') CPARA,TPARA,TU(NU) * Stop if the change is very small, CPARA is internal. IF((CPARA-XT(4,IX))*(CPARA-XT(6,IX)).LT.0.0.AND. - ABS(TU(NU)-MIN(XT(1,IX),XT(2,IX),XT(3,IX))).LE. - EPS*(ABS(TU(NU)+MIN(XT(1,IX),XT(2,IX),XT(3,IX)))))THEN IF(TU(NU).LT.XT(2,IX))THEN XT(2,IX)=TU(NU) XT(5,IX)=CPARA ENDIF IF(LDEBUG)WRITE(LUNOUT,'(/26X,''Convergence :'', - '' C='',E15.8,'', T='',E15.8)') XT(5,IX),XT(2,IX) IXTFLG(IX)=J GOTO 310 * New point is worse but inside, replace outer point on same side. ELSEIF((CPARA-XT(4,IX))*(CPARA-XT(6,IX)).LT.0.0.AND. - TU(NU).GT.MIN(XT(1,IX),XT(2,IX),XT(3,IX)))THEN IF(CPARA.LT.XT(5,IX))THEN XT(1,IX)=TU(NU) XT(4,IX)=CPARA PRECIS(1)=.TRUE. IF(LDEBUG)WRITE(LUNOUT,'(26X, - ''Lower C point is replaced by new minimum.'')') ELSE XT(3,IX)=TU(NU) XT(6,IX)=CPARA PRECIS(3)=.TRUE. IF(LDEBUG)WRITE(LUNOUT,'(26X, - ''Higher C point is replaced by new minimum.'')') ENDIF * The new point is better and inside, remove opposite outer point. ELSEIF((CPARA-XT(4,IX))*(CPARA-XT(5,IX)).LT.0.0)THEN XT(6,IX)=XT(5,IX) XT(5,IX)=CPARA XT(3,IX)=XT(2,IX) XT(2,IX)=TU(NU) PRECIS(3)=PRECIS(2) PRECIS(2)=.TRUE. ELSEIF((CPARA-XT(5,IX))*(CPARA-XT(6,IX)).LT.0.0)THEN XT(4,IX)=XT(5,IX) XT(5,IX)=CPARA XT(1,IX)=XT(2,IX) XT(2,IX)=TU(NU) PRECIS(1)=PRECIS(2) PRECIS(2)=.TRUE. * New point outside, non-parabolic, shift to add new point. ELSEIF(CPARA.LE.XT(4,IX))THEN XT(6,IX)=XT(5,IX) XT(5,IX)=XT(4,IX) XT(4,IX)=CPARA XT(3,IX)=XT(2,IX) XT(2,IX)=XT(1,IX) XT(1,IX)=TU(NU) PRECIS(3)=PRECIS(2) PRECIS(2)=PRECIS(1) PRECIS(1)=.TRUE. ELSEIF(CPARA.GE.XT(6,IX))THEN XT(4,IX)=XT(5,IX) XT(5,IX)=XT(6,IX) XT(6,IX)=CPARA XT(1,IX)=XT(2,IX) XT(2,IX)=XT(3,IX) XT(3,IX)=TU(NU) PRECIS(1)=PRECIS(2) PRECIS(2)=PRECIS(3) PRECIS(3)=.TRUE. * Position not recognised (in view of some logic modifications ...). ELSE IF(LDEBUG)WRITE(LUNOUT,'(26X,''Unrecognised pos, quit'')') XTSET(IX)=.FALSE. IXTFLG(IX)=-8 GOTO 200 ENDIF * Warn if the process did not converge. 300 CONTINUE XTSET(IX)=.FALSE. IF(LDEBUG)WRITE(LUNOUT,'(/26X,''Not converged.'')') IXTFLG(IX)=-9 GOTO 200 ** End of the minimisation process. 310 CONTINUE * Calculate the integrated diffusion coefficient. IF(GASOK(3))CALL DLCDIF(XT(7,IX)) * Find the intersections of the drift-line with the R=const lines. DO 430 JJX=IIX-JUMP+1,IIX+JUMP-1 JX=JJX-IXM+1 IF(JJX.LT.IXM.OR.JJX.GT.IXP.OR.JX.EQ.IX)GOTO 430 REF=P*(X(I)+JJX*XSTEP)+Q*Y(I) CALL DRFXT1(P,Q,REF,CDRIFT,TDRIFT,IFAIL) IF(IFAIL.EQ.0)THEN XTSET(JX)=.TRUE. NXT(JX)=1 XT(1,JX)=TU(NU)-TDRIFT XT(4,JX)=CDRIFT IXTFLG(JX)=0 ENDIF 430 CONTINUE * Proceed with next point. 200 CONTINUE *** Close the plotframe for drift lines (if the plot is made). IF(LDRPLT)THEN CALL GRNEXT CALL GRALOG('Drift lines for an x(t)-plot ') ENDIF *** Plot the obtained x(t)-relation: store minimum in position 2. IF(LXTPLT)THEN DO 540 IIX=IXM,IXP IX=IIX-IXM+1 IF(NXT(IX).EQ.0)GOTO 540 IMIN=1 DO 530 IIMIN=2,NXT(IX) IF(XT(IIMIN,IX).LT.XT(IMIN,IX))IMIN=IIMIN 530 CONTINUE XT(2,IX)=XT(IMIN,IX) XT(5,IX)=XT(IMIN+3,IX) 540 CONTINUE * Datermine maximum and minimum. IF(GRSMIN.GT.GRSMAX)THEN TMIN=0.0 TMAX=0.0 DO 500 IIX=IXM,IXP IF(XTSET(IIX-IXM+1).AND.NXT(IIX-IXM+1).GT.0)THEN TMIN=MIN(TMIN,XT(2,IIX-IXM+1)) TMAX=MAX(TMAX,XT(2,IIX-IXM+1)) ENDIF 500 CONTINUE TMIN=0.9*TMIN TMAX=1.1*TMAX ELSE TMIN=GRSMIN TMAX=GRSMAX ENDIF * Open a frame to plot the curves in. CALL GRCART(XTXMIN-X(I),TMIN,XTXMAX-X(I),TMAX, - ' x-Distance from the Wire [cm]', - ' Minimum Drift Time [microsec]', - 'x(t)-Correlation plot ') * Add some comments to the plot. IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) IF(GASID.NE.' ')CALL GRCOMM(2,'Gas: '//GASID) WRITE(INFILE,1080) ANGLE CALL GRCOMM(3,INFILE) WRITE(INFILE,1090) I,WIRTYP(I) CALL GRCOMM(4,INFILE) * And plot the curves, first the minimum drift time itself. NPLOT=0 CALL GRATTS('FUNCTION-1','POLYLINE') CALL GRATTS('FUNCTION-1','POLYMARKER') DO 510 IIX=IXM,IXP IX=IIX-IXM+1 IF(XTSET(IX))THEN NPLOT=NPLOT+1 XPL(NPLOT)=IIX*XSTEP YPL(NPLOT)=XT(2,IX) ELSE IF(NPLOT.GT.1)THEN CALL GPL(NPLOT,XPL,YPL) ELSEIF(NPLOT.EQ.1)THEN CALL GPM(1,XPL,YPL) ENDIF NPLOT=0 ENDIF 510 CONTINUE IF(NPLOT.GT.1)THEN CALL GPL(NPLOT,XPL,YPL) ELSEIF(NPLOT.EQ.1)THEN CALL GPM(1,XPL,YPL) ENDIF * next the diffusion coefficient, provided the data is present. IF(GASOK(3))THEN CALL GRATTS('FUNCTION-2','POLYLINE') CALL GRATTS('FUNCTION-2','POLYMARKER') NPLOT=0 DO 520 IIX=IXM,IXP IX=IIX-IXM+1 IF(XTSET(IX).AND.IIX.EQ.JUMP*(IIX/JUMP))THEN NPLOT=NPLOT+1 XPL(NPLOT)=IIX*XSTEP YPL(NPLOT)=XT(7,IX) ELSE IF(NPLOT.GT.1)THEN CALL GPL(NPLOT,XPL,YPL) ELSEIF(NPLOT.EQ.1)THEN CALL GPM(1,XPL,YPL) ENDIF NPLOT=0 ENDIF 520 CONTINUE IF(NPLOT.GT.1)THEN CALL GPL(NPLOT,XPL,YPL) ELSEIF(NPLOT.EQ.1)THEN CALL GPM(1,XPL,YPL) ENDIF CALL GSLN(1) ENDIF * Close the plotframe and register the plot. CALL GRNEXT WRITE(INFILE,'(''x(t) plot for wire '',I3,'', type '',A1)') - I,WIRTYP(I) CALL GRALOG(INFILE//' ') ENDIF *** Open a dataset for the x(t) if LXTWRT is .TRUE. IF(LXTWRT)THEN * Open the file and inform DSNLOG. CALL DSNOPN(FILE,NCFILE,12,'WRITE-LIBRARY',IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! DRFXTP WARNING : Opening the file'// - FILE(1:NCFILE)//' failed ; write flag cancelled' LXTWRT=.FALSE. ENDIF CALL DSNLOG(FILE,'x(t)-plot ','Sequential','Write ') * Now write a heading record to the file. CALL DATTIM(DATE,TIME) WRITE(STRING,'(''% Created '',A8,'' At '',A8,1X,A8, - '' XTPLOT "Wire '',I3,'' type '',A1,'' angle '', - F7.1,''"'')') DATE,TIME,MEMBER,I,WIRTYP(I),ANGLE IF(REMARK.NE.'None')STRING(51:79)=REMARK WRITE(12,'(A80)') STRING * Specify the number of records to be written. WRITE(12,'('' This member contains '',I3,'' records.'')') - IXP-IXM+1 ENDIF ** Print a heading for the x(t) table. IF(LXTPRT)THEN WRITE(LUNOUT,'('' x(t)-CORRELATION FOR WIRE '',I3, - '' (TYPE '',A1,'')'',/, - '' ======================================'')') - I,WIRTYP(I) WRITE(LUNOUT,'('' Wire location: ('',E15.8,'','', - E15.8,'')'',/,'' Convergence at: '',E15.8)') - X(I),Y(I),EPS IF(ITERMX.EQ.0)THEN WRITE(LUNOUT,'('' Minimisation has been disabled.'')') ELSE WRITE(LUNOUT,'('' Minimisation has been enabled.'')') ENDIF WRITE(LUNOUT,'(/'' x-value corresponding t'', - '' corresponding y diffusion Remarks''/ - '' [cm] [microsec]'', - '' [cm] [microsec]''//)') ENDIF ** Write the data itself, interpreting the various flags. DO 620 JJX=IXM,IXP J=JJX-IXM+1 REF=P*(X(I)+JJX*XSTEP)+Q*Y(I) * Prepare a string containing roughly the data. IF(IXTFLG(J).GT.0)THEN WRITE(OUTSTR,'(2X,4(E15.8,2X),A,1X,I2,1X,A)') - JJX*XSTEP,XT(2,J),Q*REF-P*XT(5,J),XT(7,J), - ' Minimisation converged in',IXTFLG(J),'steps.' ELSEIF(IXTFLG(J).EQ.0)THEN WRITE(OUTSTR,'(2X,4(E15.8,2X),A)') - JJX*XSTEP,XT(2,J),Q*REF-P*XT(5,J),XT(7,J), - ' Minimisation not requested or not meaningful.' ELSEIF(IXTFLG(J).EQ.-1)THEN WRITE(OUTSTR,'(2X,4(E15.8,2X),A)') - JJX*XSTEP,XT(2,J),Q*REF-P*XT(5,J),XT(7,J), - ' The wire is located at this x-value.' ELSEIF(IXTFLG(J).EQ.-2)THEN WRITE(OUTSTR,'(2X,4(E15.8,2X),A)') - JJX*XSTEP,XT(2,J),Q*REF-P*XT(5,J),XT(7,J), - ' ! Drift-lines starting at this x, do not'// - ' reach the wire.' ELSEIF(IXTFLG(J).EQ.-3)THEN WRITE(OUTSTR,'(2X,4(E15.8,2X),A)') - JJX*XSTEP,XT(2,J),Q*REF-P*XT(5,J),XT(7,J), - ' # Recalculation of the optimum drift-line'// - ' failed.' ELSEIF(IXTFLG(J).EQ.-4)THEN WRITE(OUTSTR,'(2X,4(E15.8,2X),A)') - JJX*XSTEP,XT(2,J),Q*REF-P*XT(5,J),XT(7,J), - ' # Failure to add a 2nd data-point,'// - ' increase LINES.' ELSEIF(IXTFLG(J).EQ.-5)THEN WRITE(OUTSTR,'(2X,4(E15.8,2X),A)') - JJX*XSTEP,XT(2,J),Q*REF-P*XT(5,J),XT(7,J), - ' # Failure to add a third data-point,'// - ' increase LINES.' ELSEIF(IXTFLG(J).EQ.-6)THEN WRITE(OUTSTR,'(2X,4(E15.8,2X),A)') - JJX*XSTEP,XT(2,J),Q*REF-P*XT(5,J),XT(7,J), - ' ! The minimisation process diverged.' ELSEIF(IXTFLG(J).EQ.-7)THEN WRITE(OUTSTR,'(2X,4(E15.8,2X),A)') - JJX*XSTEP,XT(2,J),Q*REF-P*XT(5,J),XT(7,J), - ' ! The minimum does not look parabolic.' ELSEIF(IXTFLG(J).EQ.-8)THEN WRITE(OUTSTR,'(2X,4(E15.8,2X),A)') - JJX*XSTEP,XT(2,J),Q*REF-P*XT(5,J),XT(7,J), - ' # Internal error ; program bug - please report.' ELSEIF(IXTFLG(J).EQ.-9)THEN WRITE(OUTSTR,'(2X,4(E15.8,2X),A)') - JJX*XSTEP,XT(2,J),Q*REF-P*XT(5,J),XT(7,J), - ' ! Minimisation attempted, but no convergence.' ELSEIF(IXTFLG(J).EQ.-10)THEN WRITE(OUTSTR,'(2X,4(E15.8,2X),A)') - JJX*XSTEP,XT(2,J),Q*REF-P*XT(5,J),XT(7,J), - ' # Inadequate parabolic fit; program bug.' ELSEIF(IXTFLG(J).EQ.-11)THEN WRITE(OUTSTR,'(2X,4(E15.8,2X),A)') - JJX*XSTEP,XT(2,J),Q*REF-P*XT(5,J),XT(7,J), - ' ! No drift-line found which could'// - ' be interpolated.' ELSE WRITE(OUTSTR,'(2X,4(E15.8,2X),A)') - JJX*XSTEP,XT(2,J),Q*REF-P*XT(5,J),XT(7,J), - ' # x(t) flag not recognised; program bug.' ENDIF * Remove irrelevant fields. IF(.NOT.GASOK(3).OR..NOT.XTSET(J))OUTSTR(54:68)= - ' Not available' IF(NXT(J).EQ.0.AND.JJX.NE.0)OUTSTR(20:51)= - ' Not available Not available' IF(IXTFLG(J).EQ.0.AND.JJX.NE.JUMP*INT(REAL(JJX)/REAL(JUMP))) - OUTSTR(54:)= - ' Not available Interpolated data-point.' * And output the string to the relevant units. IF(LXTPRT)WRITE(LUNOUT,'(A)',IOSTAT=IOS,ERR=2010) OUTSTR IF(LXTWRT)WRITE(12,'(L1,A)',IOSTAT=IOS,ERR=2010) - XTSET(J),OUTSTR(2:) * Next data point. 620 CONTINUE * Close the file, if openend. IF(LXTWRT)CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) *** Proceed with next wire. 100 CONTINUE *** Normal end of this routine. CALL TIMLOG('Calculating x(t) relations: ') IF(LDEBUG)PRINT *,' ++++++ DRFXTP DEBUG : End of debug output.' RETURN *** Handle I/O problems. 2010 CONTINUE PRINT *,' ###### DRFXTP ERROR : Error while'// - ' writing the x(t) data set ; attempt to close.' CALL INPIOS(IOS) CLOSE(UNIT=12,IOSTAT=IOS,ERR=2030) RETURN 2030 CONTINUE PRINT *,' ###### DRFXTP ERROR : Unable to close the data set'// - ' of the x(t) relations ; results not predictable.' CALL INPIOS(IOS) END +DECK,DRFXT1. SUBROUTINE DRFXT1(P,Q,REF,C,T,IFAIL) *----------------------------------------------------------------------- * DRFXT1 - Auxiliary routine to DRFXTP, locating intersections of * drift-lines with a straight line. * VARIABLES : P, Q, REF : P x + Q y = REF is the straight line. * C, T : Intersection parameters. * IFAIL : 1 if no intersection was found, 0 else. *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,DRIFTLINE. +SEQ,PRINTPLOT. +SEQ,CONSTANTS. DOUBLE PRECISION RD1,RD2 REAL P,Q,REF,C,T *** Loop over the drift-line, starting at lower t. DO 10 IU=2,NU RD1=P*XU(IU-1)+Q*YU(IU-1) RD2=P*XU(IU)+Q*YU(IU) IF((RD1-REF)*(RD2-REF).LE.0.0)THEN * Few data-points before and after. IF(RD1.EQ.RD2)THEN T=TU(IU-1) C=Q*XU(IU-1)-P*YU(IU-1) ELSE T=TU(IU-1)+(TU(IU)-TU(IU-1))*(REF-RD1)/(RD2-RD1) C=Q*(XU(IU-1)+(XU(IU)-XU(IU-1))*(REF-RD1)/ - (RD2-RD1))-P*(YU(IU-1)+(YU(IU)-YU(IU-1))* - (REF-RD1)/(RD2-RD1)) ENDIF IFAIL=0 RETURN ENDIF 10 CONTINUE *** Apparently no intersection has been found, return on IFAIL=1. IFAIL=1 END +DECK,DRFXT2. SUBROUTINE DRFXT2(U1,V1,U2,V2,U3,V3,UMIN,VMIN,IFAIL,IFLAG) *----------------------------------------------------------------------- * DRFXT2 - Determines the minimum of a parabola, the expressions have * been calculated using the Macsyma system. * VARIABLES : IFAIL : 1 if the parabola is degenerated. * IFLAG : -1 maximum, 0 failure, +1 minimum. *----------------------------------------------------------------------- DOUBLE PRECISION X1,Y1,X2,Y2,X3,Y3,DIV1,DIV2,XMIN,YMIN IFAIL=1 IFLAG=0 UMIN=0 VMIN=0 *** Make a double precision copy X1=U1 Y1=V1 X2=U2 Y2=V2 X3=U3 Y3=V3 *** Prevent divisions by zero. DIV1=2*(X1*(Y3-Y2)+X2*(Y1-Y3)+X3*(Y2-Y1)) DIV2=X1**2*(X2-X3)+X2**2*(X3-X1)+X3**2*(X1-X2) IF(DIV1.EQ.0.OR.DIV2.EQ.0)RETURN XMIN=(X1**2*(Y3-Y2)+X2**2*(Y1-Y3)+X3**2*(Y2-Y1))/DIV1 YMIN=(X1**2*(X2*Y3-X3*Y2)+X2**2*(X3*Y1-X1*Y3)+ - X3**2*(X1*Y2-X2*Y1)-DIV1*XMIN**2/2)/DIV2 IFAIL=0 *** See whether it is a maximum or a minimum. IF(DIV1/DIV2.GT.0)THEN IFLAG=+1 ELSE IFLAG=-1 ENDIF *** Make a single precision copy. UMIN=XMIN VMIN=YMIN END +DECK,DRFCLS. SUBROUTINE DRFCLS *----------------------------------------------------------------------- * DRFCLS - Studies clustering * (Last changed on 12/ 6/97.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PARAMETERS. INTEGER NNHIST PARAMETER(NNHIST=6) INTEGER NWORD,INEXT,I,IFAIL1,IFAIL2,IFAIL3,IFAIL4,IFAIL5,IFAIL6, - NITER,NITERR,NCHA(NNHIST),NCHAR,NPAIR,IRSIZE,IRCLUS,IRDELT, - IRRANG,IRETOT,IRECLS,NCLUS,INPCMP,INPTYP,J REAL XCLS,YCLS,ZCLS,ECLS,RANGE,XINP0,XINP1,TRALEN,DIST,ETOT, - RANGEH(2,NNHIST),RMINR,RMAXR LOGICAL DONE,LKEEP,AUTO(NNHIST),LHISPL EXTERNAL INPCMP,INPTYP +SELF,IF=SAVE. SAVE NITER,NCHA,LKEEP,LHISPL +SELF. DATA NITER /200/, LKEEP /.FALSE./, LHISPL /.TRUE./ *** Initial binning settings. DO 20 I=1,NNHIST AUTO(I)=.TRUE. RANGEH(1,I)=0 RANGEH(2,I)=0 NCHA(I)=100 20 CONTINUE *** Count words. CALL INPNUM(NWORD) *** Loop over the words. INEXT=2 DO 10 I=2,NWORD IF(I.LT.INEXT)GOTO 10 * Number of iterations. IF(INPCMP(I,'ITER#ATIONS')+INPCMP(I,'ITER#ATE').NE.0)THEN IF(I+1.GT.NWORD.OR.INPTYP(I+1).NE.1)THEN CALL INPMSG(I,'Has 1 integer argument.') ELSE CALL INPCHK(I+1,1,IFAIL1) CALL INPRDI(I+1,NITERR,NITER) IF(NITERR.GT.0)THEN NITER=NITERR ELSE CALL INPMSG(I+1,'Must be > 0.') ENDIF INEXT=I+2 ENDIF * Number of bins. ELSEIF(INPCMP(I,'BIN#S')+INPCMP(I,'CH#ANNELS').NE.0)THEN IF(I+1.GT.NWORD.OR.INPTYP(I+1).NE.1)THEN CALL INPMSG(I,'Has 1 integer argument.') ELSE CALL INPCHK(I+1,1,IFAIL1) CALL INPRDI(I+1,NCHAR,100) IF(NCHAR.GT.0.AND.NCHAR.LE.MXCHA)THEN DO 30 J=1,NNHIST NCHA(J)=NCHAR 30 CONTINUE ELSE CALL INPMSG(I+1,'Not in [1,MXCHA].') ENDIF INEXT=I+2 ENDIF ELSEIF(INPCMP(I,'CL#USTERS-S#IZE-BIN#S')+ - INPCMP(I,'CL#USTERS-S#IZE-CH#ANNELS').NE.0)THEN IF(I+1.GT.NWORD.OR.INPTYP(I+1).NE.1)THEN CALL INPMSG(I,'Has 1 integer argument.') ELSE CALL INPCHK(I+1,1,IFAIL1) CALL INPRDI(I+1,NCHAR,100) IF(NCHAR.GT.0.AND.NCHAR.LE.MXCHA)THEN NCHA(1)=NCHAR ELSE CALL INPMSG(I+1,'Not in [1,MXCHA].') ENDIF INEXT=I+2 ENDIF ELSEIF(INPCMP(I,'CL#USTERS-C#OUNT-BIN#S')+ - INPCMP(I,'CL#USTERS-C#OUNT-CH#ANNELS').NE.0)THEN IF(I+1.GT.NWORD.OR.INPTYP(I+1).NE.1)THEN CALL INPMSG(I,'Has 1 integer argument.') ELSE CALL INPCHK(I+1,1,IFAIL1) CALL INPRDI(I+1,NCHAR,100) IF(NCHAR.GT.0.AND.NCHAR.LE.MXCHA)THEN NCHA(2)=NCHAR ELSE CALL INPMSG(I+1,'Not in [1,MXCHA].') ENDIF INEXT=I+2 ENDIF ELSEIF(INPCMP(I,'DEL#TA-R#ANGE-BIN#S')+ - INPCMP(I,'DELTA-R#ANGE-CH#ANNELS').NE.0)THEN IF(I+1.GT.NWORD.OR.INPTYP(I+1).NE.1)THEN CALL INPMSG(I,'Has 1 integer argument.') ELSE CALL INPCHK(I+1,1,IFAIL1) CALL INPRDI(I+1,NCHAR,100) IF(NCHAR.GT.0.AND.NCHAR.LE.MXCHA)THEN NCHA(3)=NCHAR ELSE CALL INPMSG(I+1,'Not in [1,MXCHA].') ENDIF INEXT=I+2 ENDIF ELSEIF(INPCMP(I,'TR#ACK-R#ANGE-BIN#S')+ - INPCMP(I,'TR#ACK-R#ANGE-CH#ANNELS').NE.0)THEN IF(I+1.GT.NWORD.OR.INPTYP(I+1).NE.1)THEN CALL INPMSG(I,'Has 1 integer argument.') ELSE CALL INPCHK(I+1,1,IFAIL1) CALL INPRDI(I+1,NCHAR,100) IF(NCHAR.GT.0.AND.NCHAR.LE.MXCHA)THEN NCHA(4)=NCHAR ELSE CALL INPMSG(I+1,'Not in [1,MXCHA].') ENDIF INEXT=I+2 ENDIF ELSEIF(INPCMP(I,'CL#USTERS-E#NERGY-BIN#S')+ - INPCMP(I,'CL#USTERS-E#NERGY-CH#ANNELS').NE.0)THEN IF(I+1.GT.NWORD.OR.INPTYP(I+1).NE.1)THEN CALL INPMSG(I,'Has 1 integer argument.') ELSE CALL INPCHK(I+1,1,IFAIL1) CALL INPRDI(I+1,NCHAR,100) IF(NCHAR.GT.0.AND.NCHAR.LE.MXCHA)THEN NCHA(5)=NCHAR ELSE CALL INPMSG(I+1,'Not in [1,MXCHA].') ENDIF INEXT=I+2 ENDIF ELSEIF(INPCMP(I,'E#NERGY-L#OSS-BIN#S')+ - INPCMP(I,'E#NERGY-L#OSS-CH#ANNELS').NE.0)THEN IF(I+1.GT.NWORD.OR.INPTYP(I+1).NE.1)THEN CALL INPMSG(I,'Has 1 integer argument.') ELSE CALL INPCHK(I+1,1,IFAIL1) CALL INPRDI(I+1,NCHAR,100) IF(NCHAR.GT.0.AND.NCHAR.LE.MXCHA)THEN NCHA(6)=NCHAR ELSE CALL INPMSG(I+1,'Not in [1,MXCHA].') ENDIF INEXT=I+2 ENDIF * Ranges of the various histograms. ELSEIF(INPCMP(I,'CL#USTERS-S#IZE-RAN#GE').NE.0)THEN IF(INPCMP(I+1,'AUTO#MATIC').NE.0)THEN AUTO(1)=.TRUE. INEXT=I+2 ELSEIF((INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2).OR. - (INPTYP(I+2).NE.1.AND.INPTYP(I+2).NE.2).OR. - I+2.GT.NWORD)THEN CALL INPMSG(I,'Has 2 real arguments.') ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPCHK(I+2,2,IFAIL2) CALL INPRDR(I+1,RMINR,RANGEH(1,1)) CALL INPRDR(I+2,RMAXR,RANGEH(2,1)) IF(RMINR.EQ.RMAXR)THEN CALL INPMSG(I,'Zero range not permitted.') ELSE RANGEH(1,1)=RMINR RANGEH(2,1)=RMAXR AUTO(1)=.FALSE. ENDIF INEXT=I+3 ENDIF ELSEIF(INPCMP(I,'CL#USTERS-C#OUNT-RAN#GE').NE.0)THEN IF(INPCMP(I+1,'AUTO#MATIC').NE.0)THEN AUTO(2)=.TRUE. INEXT=I+2 ELSEIF((INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2).OR. - (INPTYP(I+2).NE.1.AND.INPTYP(I+2).NE.2).OR. - I+2.GT.NWORD)THEN CALL INPMSG(I,'Has 2 real arguments.') ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPCHK(I+2,2,IFAIL2) CALL INPRDR(I+1,RMINR,RANGEH(1,1)) CALL INPRDR(I+2,RMAXR,RANGEH(2,1)) IF(RMINR.EQ.RMAXR)THEN CALL INPMSG(I,'Zero range not permitted.') ELSE RANGEH(1,2)=RMINR RANGEH(2,2)=RMAXR AUTO(2)=.FALSE. ENDIF INEXT=I+3 ENDIF ELSEIF(INPCMP(I,'DEL#TA-R#ANGE-RAN#GE').NE.0)THEN IF(INPCMP(I+1,'AUTO#MATIC').NE.0)THEN AUTO(3)=.TRUE. INEXT=I+2 ELSEIF((INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2).OR. - (INPTYP(I+2).NE.1.AND.INPTYP(I+2).NE.2).OR. - I+2.GT.NWORD)THEN CALL INPMSG(I,'Has 2 real arguments.') ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPCHK(I+2,2,IFAIL2) CALL INPRDR(I+1,RMINR,RANGEH(1,1)) CALL INPRDR(I+2,RMAXR,RANGEH(2,1)) IF(RMINR.EQ.RMAXR)THEN CALL INPMSG(I,'Zero range not permitted.') ELSE RANGEH(1,3)=RMINR RANGEH(2,3)=RMAXR AUTO(3)=.FALSE. ENDIF INEXT=I+3 ENDIF ELSEIF(INPCMP(I,'TR#ACK-R#ANGE-RAN#GE').NE.0)THEN IF(INPCMP(I+1,'AUTO#MATIC').NE.0)THEN AUTO(4)=.TRUE. INEXT=I+2 ELSEIF((INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2).OR. - (INPTYP(I+2).NE.1.AND.INPTYP(I+2).NE.2).OR. - I+2.GT.NWORD)THEN CALL INPMSG(I,'Has 2 real arguments.') ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPCHK(I+2,2,IFAIL2) CALL INPRDR(I+1,RMINR,RANGEH(1,1)) CALL INPRDR(I+2,RMAXR,RANGEH(2,1)) IF(RMINR.EQ.RMAXR)THEN CALL INPMSG(I,'Zero range not permitted.') ELSE RANGEH(1,4)=RMINR RANGEH(2,4)=RMAXR AUTO(4)=.FALSE. ENDIF INEXT=I+3 ENDIF ELSEIF(INPCMP(I,'CL#USTERS-E#NERGY-RAN#GE').NE.0)THEN IF(INPCMP(I+1,'AUTO#MATIC').NE.0)THEN AUTO(5)=.TRUE. INEXT=I+2 ELSEIF((INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2).OR. - (INPTYP(I+2).NE.1.AND.INPTYP(I+2).NE.2).OR. - I+2.GT.NWORD)THEN CALL INPMSG(I,'Has 2 real arguments.') ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPCHK(I+2,2,IFAIL2) CALL INPRDR(I+1,RMINR,RANGEH(1,1)) CALL INPRDR(I+2,RMAXR,RANGEH(2,1)) IF(RMINR.EQ.RMAXR)THEN CALL INPMSG(I,'Zero range not permitted.') ELSE RANGEH(1,5)=RMINR RANGEH(2,5)=RMAXR AUTO(5)=.FALSE. ENDIF INEXT=I+3 ENDIF ELSEIF(INPCMP(I,'E#NERGY-L#OSS-RAN#GE').NE.0)THEN IF(INPCMP(I+1,'AUTO#MATIC').NE.0)THEN AUTO(6)=.TRUE. INEXT=I+2 ELSEIF((INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2).OR. - (INPTYP(I+2).NE.1.AND.INPTYP(I+2).NE.2).OR. - I+2.GT.NWORD)THEN CALL INPMSG(I,'Has 2 real arguments.') ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPCHK(I+2,2,IFAIL2) CALL INPRDR(I+1,RMINR,RANGEH(1,1)) CALL INPRDR(I+2,RMAXR,RANGEH(2,1)) IF(RMINR.EQ.RMAXR)THEN CALL INPMSG(I,'Zero range not permitted.') ELSE RANGEH(1,6)=RMINR RANGEH(2,6)=RMAXR AUTO(6)=.FALSE. ENDIF INEXT=I+3 ENDIF * Keep histograms or not. ELSEIF(INPCMP(I,'KEEP-#HISTOGRAMS').NE.0)THEN LKEEP=.TRUE. ELSEIF(INPCMP(I,'NOKEEP-#HISTOGRAMS').NE.0)THEN LKEEP=.FALSE. * Plot the histograms or not. ELSEIF(INPCMP(I,'PL#OT-#HISTOGRAMS').NE.0)THEN LHISPL=.TRUE. ELSEIF(INPCMP(I,'NOPL#OT-#HISTOGRAMS').NE.0)THEN LHISPL=.FALSE. * Other keywords are not known. ELSE CALL INPMSG(I,'Not a known keyword.') ENDIF 10 CONTINUE * Print error messages. CALL INPERR *** Set the progress print. CALL PROINT('CLUSTER',1,6) *** Book histograms. CALL HISADM('INTEGER',IRSIZE,NCHA(1),RANGEH(1,1),RANGEH(2,1), - AUTO(1),IFAIL1) CALL HISADM('INTEGER',IRCLUS,NCHA(2),RANGEH(1,2),RANGEH(2,2), - AUTO(2),IFAIL2) CALL HISADM('ALLOCATE',IRDELT,NCHA(3),RANGEH(1,3),RANGEH(2,3), - AUTO(3),IFAIL3) CALL HISADM('ALLOCATE',IRRANG,NCHA(4),RANGEH(1,4),RANGEH(2,4), - AUTO(4),IFAIL4) CALL HISADM('ALLOCATE',IRECLS,NCHA(5),RANGEH(1,5),RANGEH(2,5), - AUTO(5),IFAIL5) CALL HISADM('ALLOCATE',IRETOT,NCHA(6),RANGEH(1,6),RANGEH(2,6), - AUTO(6),IFAIL6) IF(IFAIL1.NE.0.OR.IFAIL2.NE.0.OR.IFAIL3.NE.0.OR. - IFAIL4.NE.0.OR.IFAIL5.NE.0.OR.IFAIL6.NE.0)THEN PRINT *,' !!!!!! DRFCLS WARNING : Allocating one or more'// - ' histograms failed; no plots.' GOTO 500 ENDIF *** Now generate the true sample. CALL PROFLD(1,'Tracks',REAL(NITER)) DO 200 I=1,NITER IF(I.EQ.10*(I/10))CALL PROSTA(1,REAL(I)) NCLUS=0 RANGE=0 ETOT=0 * Prepare track. CALL TRACLI * Loop over clusters. 210 CONTINUE * Generate clusters. CALL TRACLS(XCLS,YCLS,ZCLS,ECLS,NPAIR,DONE,IFAIL1) * Check whether done. IF(DONE)THEN CALL HISENT(IRCLUS,REAL(NCLUS),1.0) CALL HISENT(IRRANG,RANGE,1.0) CALL HISENT(IRETOT,ETOT,1.0) GOTO 200 * Check error status. ELSEIF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! DRFCLS WARNING : Cluster generation'// - ' failed; no plots made.' GOTO 500 ENDIF * Enter size in histogram. CALL HISENT(IRSIZE,REAL(NPAIR),1.0) * Enter energy in histogram. CALL HISENT(IRECLS,1E6*ECLS,1.0) * Keep range up to date. RANGE=MAX(RANGE,SQRT((XCLS-XT0)**2+(YCLS-YT0)**2+ - (ZCLS-ZT0)**2)) * Keep energy up to date. ETOT=ETOT+ECLS * Compute distance from track. TRALEN=(XT1-XT0)**2+(YT1-YT0)**2+(ZT1-ZT0)**2 IF(TRALEN.LE.0.0)THEN DIST=SQRT((XT1-XCLS)**2+(YT1-YCLS)**2+(ZT1-ZCLS)**2) ELSE XINP0=(XT1-XT0)*(XCLS-XT0)+(YT1-YT0)*(YCLS-YT0)+ - (ZT1-ZT0)*(ZCLS-ZT0) XINP1=(XT0-XT1)*(XCLS-XT1)+(YT0-YT1)*(YCLS-YT1)+ - (ZT0-ZT1)*(ZCLS-ZT1) IF(XINP1**2*((XCLS-XT0)**2+(YCLS-YT0)**2+ - (ZCLS-ZT0)**2).GT.XINP0**2*((XCLS-XT1)**2+ - (YCLS-YT1)**2+(ZCLS-ZT1)**2))THEN DIST=SQRT(MAX(0.0,(XCLS-XT0)**2+(YCLS-YT0)**2+ - (ZCLS-ZT0)**2-XINP0**2/TRALEN)) ELSE DIST=SQRT(MAX(0.0,(XCLS-XT1)**2+(YCLS-YT1)**2+ - (ZCLS-ZT1)**2-XINP1**2/TRALEN)) ENDIF ENDIF CALL HISENT(IRDELT,DIST,1.0) * Increment statistics. NCLUS=NCLUS+1 GOTO 210 200 CONTINUE CALL PROEND *** Plot the histograms. IF(LHISPL)THEN CALL HISPLT(IRCLUS,'Number of deposits', - 'Number of clusters per track',.TRUE.) CALL GRNEXT CALL HISPLT(IRSIZE,'Number of electrons', - 'Number of electrons per cluster',.TRUE.) CALL GRNEXT CALL HISPLT(IRRANG,'Range [cm]', - 'Range of the track',.TRUE.) CALL GRNEXT CALL HISPLT(IRDELT,'Distance [cm]', - 'Distance between cluster and track',.TRUE.) CALL GRNEXT CALL HISPLT(IRECLS,'Energy [eV]', - 'Energy per cluster',.TRUE.) CALL GRNEXT CALL HISPLT(IRETOT,'Energy [MeV]', - 'Total energy loss',.TRUE.) CALL GRNEXT ENDIF *** Delete histograms. 500 CONTINUE IF(LKEEP)THEN CALL HISSAV(IRSIZE,'SIZE',IFAIL1) CALL HISSAV(IRCLUS,'CLUSTERS',IFAIL2) CALL HISSAV(IRDELT,'DELTA',IFAIL3) CALL HISSAV(IRRANG,'RANGE',IFAIL4) CALL HISSAV(IRETOT,'DE',IFAIL5) CALL HISSAV(IRECLS,'ECLUSTER',IFAIL6) IF(IFAIL1.NE.0.OR.IFAIL2.NE.0.OR.IFAIL3.NE.0.OR. - IFAIL4.NE.0.OR.IFAIL5.NE.0.OR.IFAIL6.NE.0)THEN PRINT *,' !!!!!! DRFCLS WARNING : Saving one or'// - ' more histograms failed.' ELSE PRINT *,' ------ DRFCLS MESSAGE : Histograms saved'// - ' as SIZE, CLUSTERS, DELTA, RANGE, DE and'// - ' ECLUSTER.' ENDIF ELSE CALL HISADM('DELETE',IRSIZE,NCHA,0.0,0.0,.FALSE.,IFAIL1) CALL HISADM('DELETE',IRCLUS,NCHA,0.0,0.0,.FALSE.,IFAIL2) CALL HISADM('DELETE',IRDELT,NCHA,0.0,0.0,.FALSE.,IFAIL3) CALL HISADM('DELETE',IRRANG,NCHA,0.0,0.0,.FALSE.,IFAIL4) CALL HISADM('DELETE',IRECLS,NCHA,0.0,0.0,.FALSE.,IFAIL5) CALL HISADM('DELETE',IRETOT,NCHA,0.0,0.0,.FALSE.,IFAIL6) IF(IFAIL1.NE.0.OR.IFAIL2.NE.0.OR.IFAIL3.NE.0.OR. - IFAIL4.NE.0.OR.IFAIL5.NE.0.OR.IFAIL6.NE.0) - PRINT *,' !!!!!! DRFCLS WARNING : Deleting one'// - ' or more histograms failed.' ENDIF END +PATCH,DRIFTCAL. +DECK,DLCALC. SUBROUTINE DLCALC(X1,Y1,Z1,Q,ITYPE) *----------------------------------------------------------------------- * DLCALC - Subroutine doing the actual drift line calculations. It * communicates with the outside through sequence DRIFTLINE. * The calculations are based on a Runge-Kutta-Fehlberg method * which has the advantage of controlling the stepsize and the * error while needing only relatively few calls to EFIELD. * Full details are given in the reference quoted below. * VARIABLES : H : Current stepsize (it is in fact a delta t). * HPREV : Stores the previous value of H (comparison) * INITCH : Used for checking initial stepsize (1 = ok) * Other variables such as F0, F1, F2, F3, PHII, PHIII, * CI. ,CII. , BETA.. etc are explained in the reference. * REFERENCE : Stoer + Bulirsch, Einfuhrung in die Numerische * Mathematic II, chapter 7, page 122, 1978, HTB, Springer. * (Last changed on 30/11/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,PARAMETERS. +SEQ,DRIFTLINE. +SEQ,PRINTPLOT. DOUBLE PRECISION F0(3),F1(3),F2(3),F3(3),PHII(3),PHIII(3), - X0,Y0,Z0,H,HPREV,CI0,CI1,CI2,CII0,CII2,CII3, - BETA10,BETA20,BETA21,BETA30,BETA31,BETA32, - DIST21,DIST22,DIST23,XST0,YST0,XST1,YST1 INTEGER IPLANE,IFLAG1,IFLAG2,IFLAG3,ILOC,ILOC1,ILOC2,ILOC3, - INITCH,ITYPE,IOUT REAL Q,X1,Y1,Z1,EX,EY,EZ,ETOT,VOLT *** Initialise the constants appearing in the RKF formulas. PARAMETER(CI0 =214.0D0/ 891.0D0,CI1 = 1.0D0/ 33.0D0, - CI2 =650.0D0/ 891.0D0,CII0 = 533.0D0/2106.0D0, - CII2 =800.0D0/1053.0D0,CII3 = -1.0D0/ 78.0D0, - BETA10= 1.0D0/ 4.0D0,BETA20=-189.0D0/ 800.0D0, - BETA21=729.0D0/ 800.0D0,BETA30= 214.0D0/ 891.0D0, - BETA31= 1.0D0/ 33.0D0,BETA32= 650.0D0/ 891.0D0) *** Use these lines if the compiler rejects the PARAMETER statements. C+SELF,IF=SAVE. C SAVE CI0,CI1,CI2,CII0,CII2,CII3 C SAVE BETA10,BETA20,BETA21,BETA30,BETA31,BETA32 C+SELF. C DATA CI0 ,CI1 ,CI2 /0.240179574, 0.030303030, 0.729517396/ C DATA CII0 ,CII2 ,CII3 /0.253086420, 0.759734093,-0.012820513/ C DATA BETA10,BETA20,BETA21/0.25, -0.23625, 0.91125 / C DATA BETA30,BETA31,BETA32/0.240179574, 0.030303030, 0.729517396/ *** Identify the routine if requested. IF(LIDENT)PRINT *,' /// ROUTINE DLCALC ///' *** Initialise the output position and time vectors. NU=1 XU(1)=DBLE(X1) YU(1)=DBLE(Y1) ZU(1)=DBLE(Z1) TU(1)=0.0D0 ISTAT=0 IPTYPE=ITYPE IPTECH=1 QPCHAR=Q *** Check the initial position, setting a status code if appropriate. CALL EFIELD(X1,Y1,Z1,EX,EY,EZ,ETOT,VOLT,0,ILOC) * In a wire. IF(ILOC.GT.0.AND.ILOC.LE.MXWIRE)THEN IF((X(ILOC)-X1)**2+(Y(ILOC)-Y1)**2.LE.0.25*D(ILOC)**2)THEN ISTAT=ILOC ELSE ISTAT=ILOC+MXWIRE ENDIF * Outside the planes. ELSEIF(ILOC.EQ.-1.OR.ILOC.EQ.-4)THEN IF(YNPLAN(1).AND.X1.LE.COPLAN(1))THEN ISTAT=-11 ELSEIF(YNPLAN(2).AND.X1.GE.COPLAN(2))THEN ISTAT=-12 ELSEIF(YNPLAN(3).AND.Y1.LE.COPLAN(3))THEN ISTAT=-13 ELSEIF(YNPLAN(4).AND.Y1.GE.COPLAN(4))THEN ISTAT=-14 ELSEIF(TUBE)THEN CALL INTUBE(X1,Y1,COTUBE,NTUBE,IOUT) IF(IOUT.EQ.1)ISTAT=-15 ENDIF IF(ISTAT.EQ.0)THEN PRINT *,' !!!!!! DLCALC WARNING : Field location'// - ' code does not match geometry; please report.' ISTAT=-4 ENDIF * In a material. ELSEIF(ILOC.EQ.-5)THEN ISTAT=-5 * Outside the mesh. ELSEIF(ILOC.EQ.-6)THEN ISTAT=-6 * Other bizarre codes. ELSEIF(ILOC.NE.0)THEN PRINT *,' ###### DLCALC ERROR : Unexpected ILOC=',ILOC, - ' received from EFIELD ; program bug, please report.' ISTAT=-3 ENDIF * Always return if location code is non-zero. IF(ILOC.NE.0)RETURN *** Check the initial status, establishing eg the target wire. CALL DLCSTA(Q,ITYPE) IF(ISTAT.NE.0)RETURN *** Set the initial step-size, zero drift-field should be exceptional. CALL DLCVEL(DBLE(X1),DBLE(Y1),DBLE(Z1),F0,Q,ITYPE,ILOC) IF(F0(1)**2+F0(2)**2+F0(3)**2.EQ.0.0)THEN PRINT *,' !!!!!! DLCALC WARNING : Drift line starts from'// - ' a zero E-field point.' ISTAT=-3 RETURN ELSE H=EPSDIF/SQRT(F0(1)**2+F0(2)**2+F0(3)**2) ENDIF * Allow INITCH cycles to adjust the initial step-size. INITCH=3 20 CONTINUE NU=1 * And also store the initial point locally in scalar double precision. X0=DBLE(X1) Y0=DBLE(Y1) Z0=DBLE(Z1) *** Take steps of size H (adjusted every cycle). 30 CONTINUE CALL DLCVEL( - X0+H*BETA10*F0(1), - Y0+H*BETA10*F0(2), - Z0+H*BETA10*F0(3), - F1,Q,ITYPE,ILOC1) CALL DLCVEL( - X0+H*(BETA20*F0(1)+BETA21*F1(1)), - Y0+H*(BETA20*F0(2)+BETA21*F1(2)), - Z0+H*(BETA20*F0(3)+BETA21*F1(3)), - F2,Q,ITYPE,ILOC2) CALL DLCVEL( - X0+H*(BETA30*F0(1)+BETA31*F1(1)+BETA32*F2(1)), - Y0+H*(BETA30*F0(2)+BETA31*F1(2)+BETA32*F2(2)), - Z0+H*(BETA30*F0(3)+BETA31*F1(3)+BETA32*F2(3)), - F3,Q,ITYPE,ILOC3) *** Check that the target wire is not crossed while exploring the field. IF(ITARG.GT.0)THEN CALL DLCMIN(XTARG,YTARG,X0,Y0, - X0+H*BETA10*F0(1),Y0+H*BETA10*F0(2), - DIST21,IFLAG1) CALL DLCMIN(XTARG,YTARG,X0,Y0, - X0+H*(BETA20*F0(1)+BETA21*F1(1)), - Y0+H*(BETA20*F0(2)+BETA21*F1(2)), - DIST22,IFLAG2) CALL DLCMIN(XTARG,YTARG,X0,Y0, - X0+H*(BETA30*F0(1)+BETA31*F1(1)+BETA32*F2(1)), - Y0+H*(BETA30*F0(2)+BETA31*F1(2)+BETA32*F2(2)), - DIST23,IFLAG3) * If it is, quit at this point after terminating via DLCWIR. IF(DIST21.LT.0.25*DTARG**2.OR.DIST22.LT.0.25*DTARG**2.OR. - DIST23.LT.0.25*DTARG**2)THEN IF(LDEBUG)PRINT *,' ++++++ DLCALC DEBUG : DLCWIR', - ' entered from DLCALC.' CALL DLCWIR(1,Q,ITYPE) RETURN ENDIF ENDIF *** Check that none of the planes was crossed during this computation. IF(YNPLAN(1).OR.YNPLAN(2).OR.YNPLAN(3).OR.YNPLAN(4))THEN XST0=MIN(X0+H*BETA10*F0(1),X0+H*(BETA20*F0(1)+BETA21*F1(1)), - X0+H*(BETA30*F0(1)+BETA31*F1(1)+BETA32*F2(1))) YST0=MIN(Y0+H*BETA10*F0(2),Y0+H*(BETA20*F0(2)+BETA21*F1(2)), - Y0+H*(BETA30*F0(2)+BETA31*F1(2)+BETA32*F2(2))) XST1=MAX(X0+H*BETA10*F0(1),X0+H*(BETA20*F0(1)+BETA21*F1(1)), - X0+H*(BETA30*F0(1)+BETA31*F1(1)+BETA32*F2(1))) YST1=MAX(Y0+H*BETA10*F0(2),Y0+H*(BETA20*F0(2)+BETA21*F1(2)), - Y0+H*(BETA30*F0(2)+BETA31*F1(2)+BETA32*F2(2))) IPLANE=0 IF(YNPLAN(1).AND.XST0.LE.COPLAN(1))IPLANE=1 IF(YNPLAN(2).AND.XST1.GE.COPLAN(2))IPLANE=2 IF(YNPLAN(3).AND.YST0.LE.COPLAN(3))IPLANE=3 IF(YNPLAN(4).AND.YST1.GE.COPLAN(4))IPLANE=4 IF(IPLANE.NE.0)THEN IF(LDEBUG)PRINT *,' ++++++ DLCALC DEBUG : Plane ', - IPLANE,' was crossed during the last step.' CALL DLCPLA(IPLANE,Q,ITYPE) RETURN ENDIF ENDIF *** Check that no dielectric was entered nor that the mesh was left. IF(ICTYPE.EQ.0.AND.(ILOC1.NE.0.OR.ILOC2.NE.0.OR.ILOC3.NE.0))THEN IF(ILOC1.NE.0)THEN CALL DLCFMP(X0,Y0,Z0, - X0+H*BETA10*F0(1), - Y0+H*BETA10*F0(2), - Z0+H*BETA10*F0(3), - ILOC1,Q,ITYPE) ELSEIF(ILOC2.NE.0)THEN CALL DLCFMP(X0,Y0,Z0, - X0+H*(BETA20*F0(1)+BETA21*F1(1)), - Y0+H*(BETA20*F0(2)+BETA21*F1(2)), - Z0+H*(BETA20*F0(3)+BETA21*F1(3)), - ILOC2,Q,ITYPE) ELSEIF(ILOC3.NE.0)THEN CALL DLCFMP(X0,Y0,Z0, - X0+H*(BETA30*F0(1)+BETA31*F1(1)+BETA32*F2(1)), - Y0+H*(BETA30*F0(2)+BETA31*F1(2)+BETA32*F2(2)), - Z0+H*(BETA30*F0(3)+BETA31*F1(3)+BETA32*F2(3)), - ILOC3,Q,ITYPE) ENDIF IF(LDEBUG)PRINT *,' ++++++ DLCALC DEBUG : Drift medium', - ' or mesh left at NU=',NU,' ILOC=',ILOC1,ILOC2,ILOC3 RETURN ENDIF *** Now set up the correction for (X0,Y0,Z0). PHII(1)=CI0*F0(1)+CI1*F1(1)+CI2*F2(1) PHII(2)=CI0*F0(2)+CI1*F1(2)+CI2*F2(2) PHII(3)=CI0*F0(3)+CI1*F1(3)+CI2*F2(3) PHIII(1)=CII0*F0(1)+CII2*F2(1)+CII3*F3(1) PHIII(2)=CII0*F0(2)+CII2*F2(2)+CII3*F3(2) PHIII(3)=CII0*F0(3)+CII2*F2(3)+CII3*F3(3) *** Be sure that the step has non-zero length. IF(SQRT(PHII(1)**2+PHII(2)**2+PHII(3)**2).LE.0)THEN IF(LDEBUG)PRINT *,' ++++++ DLCALC DEBUG : Step ',NU, - ' has 0 length; abandoned.' ISTAT=-3 RETURN *** Check step size. ELSEIF(LSTMAX.AND. - H*SQRT(PHII(1)**2+PHII(2)**2+PHII(3)**2).GT.STMAX)THEN H=0.5*STMAX/SQRT(PHII(1)**2+PHII(2)**2+PHII(3)**2) IF(LDEBUG)PRINT *,' ++++++ DLCALC DEBUG : Step ',NU, - ' is considered too long; H is reduced.' GOTO 30 C*** Don't allow H to become too large in view of the time resolution. C ELSEIF(H*ABS(PHII(1)).GT.(DXMAX-DXMIN)/10.0.OR. C - H*ABS(PHII(2)).GT.(DYMAX-DYMIN)/10.0)THEN C H=H/2 C IF(LDEBUG)PRINT *,' ++++++ DLCALC DEBUG : Step ',NU, C - ' is considered too long; H is divided by 2.' C GOTO 30 *** Check bending angle. ELSEIF(LKINK.AND.NU.GT.1)THEN IF(PHII(1)*(XU(NU)-XU(NU-1))+ - PHII(2)*(YU(NU)-YU(NU-1))+ - PHII(3)*(ZU(NU)-ZU(NU-1)).LT.0)THEN ISTAT=-3 IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCALC DEBUG :'', - '' Step '',I3,'': bending angle exceeds pi/2.''/ - 26X,''Proposed step: '',3E15.8/ - 26X,''Previous step: '',3E15.8/ - 26X,''Inner product: '',E15.8)') - NU+1,PHII(1),PHII(2),PHII(3),XU(NU)-XU(NU-1), - YU(NU)-YU(NU-1),ZU(NU)-ZU(NU-1), - PHII(1)*(XU(NU)-XU(NU-1))+ - PHII(2)*(YU(NU)-YU(NU-1))+ - PHII(3)*(ZU(NU)-ZU(NU-1)) RETURN ENDIF ENDIF *** Redefine X0, Y0 and Z0. X0=X0+H*PHII(1) Y0=Y0+H*PHII(2) Z0=Z0+H*PHII(3) *** Copy new X0 and Y0 to XU and YU, add new TU. NU=NU+1 XU(NU)=X0 YU(NU)=Y0 ZU(NU)=Z0 TU(NU)=TU(NU-1)+H *** Check particle position. CALL DLCSTA(Q,ITYPE) IF(ISTAT.NE.0)RETURN *** Adjust step size according to the accuracy of the two estimates. HPREV=H IF(PHII(1).NE.PHIII(1).OR.PHII(2).NE.PHIII(2).OR. - PHII(3).NE.PHIII(3))THEN H=SQRT(H*EPSDIF/(ABS(PHII(1)-PHIII(1))+ - ABS(PHII(2)-PHIII(2))+ABS(PHII(3)-PHIII(3)))) ELSE IF(LDEBUG)PRINT *,' ++++++ DLCALC DEBUG : H increased by', - ' a factor of 2 in step ',NU,' (equal estimates).' H=H*2.0D0 ENDIF *** Make sure that H is different from zero; this should always be ok. IF(H.EQ.0.0D0)THEN PRINT *,' ###### DLCALC ERROR : Step ',NU,' step size is', - ' zero (program bug) ; the calculation is abandoned.' ISTAT=-3 RETURN ENDIF *** Check the initial step size. IF(INITCH.GT.0.AND.(H.LT.HPREV/5.0))THEN C IF(LDEBUG)PRINT *,' ++++++ DLCALC DEBUG : Stepsize', C - ' reinitialised, current value is ',H INITCH=INITCH-1 GOTO 20 ENDIF INITCH=0 *** Don't allow H to grow too quickly. IF(H.GT.10.0*HPREV)THEN H=10.0*HPREV C IF(LDEBUG)PRINT *,' ++++++ DLCALC DEBUG : Step ',NU, C - ' H restricted to 10 times HPREV.' ENDIF *** Make sure we haven't got more than MXLIST points already. IF(NU.EQ.MXLIST)THEN ISTAT=-2 RETURN ENDIF *** Stop in case H tends to become too small. IF(H*(ABS(PHII(1))+ABS(PHII(2))+ABS(PHII(3))).LT.EPSDIF)THEN IF(LDEBUG)PRINT *,' ++++++ DLCALC DEBUG : The step size', - ' has become smaller than EPSDIF; line abandoned.' ISTAT=-3 RETURN ENDIF *** Remember: F0 equals F3 of the previous step. F0(1)=F3(1) F0(2)=F3(2) F0(3)=F3(3) GOTO 30 END +DECK,DLCMC. SUBROUTINE DLCMC(X1,Y1,Z1,Q,ITYPE) *----------------------------------------------------------------------- * DLCMC - Subroutine that computes a drift line using a Monte-Carlo * technique to take account of diffusion. * VARIABLES : * REFERENCE : * (Last changed on 4/ 2/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,GASDATA. +SEQ,PARAMETERS. +SEQ,DRIFTLINE. +SEQ,PRINTPLOT. +SEQ,CONSTANTS. DOUBLE PRECISION F0(3),X0,Y0,Z0,THETA,PHI,DIST,X0NEW,Y0NEW,Z0NEW, - DVEC(3) REAL Q,X1,Y1,Z1,EX,EY,EZ,ETOT,VOLT,GASDFT,GASDFL,DT,DL,RNDNOR, - TSTEP,RNDEXP,TCOLL,BX,BY,BZ,BTOT INTEGER IFLAG,ILOC,ITYPE,IPLANE,IOUT EXTERNAL GASDFT,GASDFL,RNDNOR,RNDEXP *** Identify the routine if requested. IF(LIDENT)PRINT *,' /// ROUTINE DLCMC ///' *** Initial debugging output. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCMC DEBUG : MC drift'', - '' from ('',E15.8,'','',E15.8,'','',E15.8,''), Q='',E8.1, - '' type='',I2,''.'')') X1,Y1,Z1,Q,ITYPE *** Initialise the output position and time vectors. NU=1 XU(1)=DBLE(X1) YU(1)=DBLE(Y1) ZU(1)=DBLE(Z1) TU(1)=0.0D0 ISTAT=0 IPTYPE=ITYPE IPTECH=2 QPCHAR=Q *** Check the initial position, setting a status code if appropriate. CALL EFIELD(X1,Y1,Z1,EX,EY,EZ,ETOT,VOLT,0,ILOC) CALL BFIELD(X1,Y1,Z1,BX,BY,BZ,BTOT) * In a wire. IF(ILOC.GT.0.AND.ILOC.LE.MXWIRE)THEN IF((X(ILOC)-X1)**2+(Y(ILOC)-Y1)**2.LE.0.25*D(ILOC)**2)THEN ISTAT=ILOC ELSE ISTAT=ILOC+MXWIRE ENDIF * Outside the planes. ELSEIF(ILOC.EQ.-1.OR.ILOC.EQ.-4)THEN IF(YNPLAN(1).AND.X1.LE.COPLAN(1))THEN ISTAT=-11 ELSEIF(YNPLAN(2).AND.X1.GE.COPLAN(2))THEN ISTAT=-12 ELSEIF(YNPLAN(3).AND.Y1.LE.COPLAN(3))THEN ISTAT=-13 ELSEIF(YNPLAN(4).AND.Y1.GE.COPLAN(4))THEN ISTAT=-14 ELSEIF(TUBE)THEN CALL INTUBE(X1,Y1,COTUBE,NTUBE,IOUT) IF(IOUT.EQ.1)ISTAT=-15 ENDIF IF(ISTAT.EQ.0)THEN PRINT *,' !!!!!! DLCMC WARNING : Field location'// - ' code does not match geometry; please report.' ISTAT=-4 ENDIF * In a material. ELSEIF(ILOC.EQ.-5)THEN ISTAT=-5 * Outside the mesh. ELSEIF(ILOC.EQ.-6)THEN ISTAT=-6 * Other bizarre codes. ELSEIF(ILOC.NE.0)THEN PRINT *,' ###### DLCMC ERROR : Unexpected ILOC=',ILOC, - ' received from EFIELD ; program bug, please report.' ISTAT=-3 ENDIF * Always return if location code is non-zero. IF(ILOC.NE.0)RETURN *** Check the initial status, establishing eg the target wire. CALL DLCSTA(Q,ITYPE) IF(ISTAT.NE.0)RETURN *** Store the initial point locally in scalar double precision. X0=DBLE(X1) Y0=DBLE(Y1) Z0=DBLE(Z1) *** Start making steps. 30 CONTINUE * Compute drift velocity. CALL DLCVEL(X0,Y0,Z0,F0,Q,ITYPE,ILOC) * Ensure the norm is not zero. IF(SQRT(F0(1)**2+F0(2)**2+F0(3)**2).LE.0)THEN IF(LDEBUG)PRINT *,' ++++++ DLCMC DEBUG : Velocity'// - ' is zero at NU=',NU,'; returning with ISTAT=-3.' ISTAT=-3 RETURN ENDIF * Compute the diffusion terms. IF(ITYPE.EQ.1)THEN IF(GASOK(8))THEN DT=GASDFT(EX,EY,EZ,BX,BY,BZ) ELSE DT=0 ENDIF IF(GASOK(3))THEN DL=GASDFL(EX,EY,EZ,BX,BY,BZ) ELSE DL=0 ENDIF ELSE DT=DTION DL=DLION ENDIF * If making fixed size time steps ... IF(MCMETH.EQ.0)THEN TSTEP=TMC * If making fixed distance steps ... ELSEIF(MCMETH.EQ.1)THEN TSTEP=DMC/SQRT(F0(1)**2+F0(2)**2+F0(3)**2) * If making steps based on collision time ... ELSE TCOLL=1E8*EMASS*SQRT(F0(1)**2+F0(2)**2+F0(3)**2)/ - (ECHARG*SQRT(EX**2+EY**2+EZ**2)) C PRINT *,' Collision time=',TCOLL*1000000,' psec' TSTEP=NMC*RNDEXP(TCOLL) ENDIF * Draw a random diffusion direction in the particle frame. DVEC(1)=SQRT(SQRT(F0(1)**2+F0(2)**2+F0(3)**2)*TSTEP)* - RNDNOR(0.0,DL) DVEC(2)=SQRT(SQRT(F0(1)**2+F0(2)**2+F0(3)**2)*TSTEP)* - RNDNOR(0.0,DT) DVEC(3)=SQRT(SQRT(F0(1)**2+F0(2)**2+F0(3)**2)*TSTEP)* - RNDNOR(0.0,DT) * Compute rotation to align (1,0,0) with the drift velocity vector. IF(F0(1)**2+F0(2)**2.LE.0)THEN IF(F0(3).LT.0)THEN THETA=-PI/2 ELSEIF(F0(3).GT.0)THEN THETA=+PI/2 ELSE IF(LDEBUG)PRINT *,' ++++++ DLCMC DEBUG : Velocity', - ' vector of length = 0 seen; returning ISTAT=-3.' ISTAT=-3 RETURN ENDIF PHI=0 ELSE PHI=ATAN2(F0(2),F0(1)) THETA=ATAN2(F0(3),SQRT(F0(1)**2+F0(2)**2)) ENDIF * Compute the proposed end-point of this step. X0NEW=X0+TSTEP*F0(1)+COS(PHI)*COS(THETA)*DVEC(1)- - SIN(PHI)*DVEC(2)-COS(PHI)*SIN(THETA)*DVEC(3) Y0NEW=Y0+TSTEP*F0(2)+SIN(PHI)*COS(THETA)*DVEC(1)+ - COS(PHI)*DVEC(2)-SIN(PHI)*SIN(THETA)*DVEC(3) Z0NEW=Z0+TSTEP*F0(3)+SIN(THETA)*DVEC(1)+COS(THETA)*DVEC(3) *** Check that the target wire is not crossed while exploring the field. IF(ITARG.GT.0)THEN CALL DLCMIN(XTARG,YTARG,X0,Y0,X0NEW,Y0NEW,DIST,IFLAG) * If it is, quit at this point after terminating via DLCWIR. IF(DIST.LT.0.25*DTARG**2)THEN IF(LDEBUG)PRINT *,' ++++++ DLCMC DEBUG : DLCWIR', - ' entered from DLCMC.' CALL DLCWIR(1,Q,ITYPE) RETURN ENDIF ENDIF *** Check that none of the planes was crossed during this computation. IF(YNPLAN(1).OR.YNPLAN(2).OR.YNPLAN(3).OR.YNPLAN(4))THEN IPLANE=0 IF(YNPLAN(1).AND.X0NEW.LE.COPLAN(1))IPLANE=1 IF(YNPLAN(2).AND.X0NEW.GE.COPLAN(2))IPLANE=2 IF(YNPLAN(3).AND.Y0NEW.LE.COPLAN(3))IPLANE=3 IF(YNPLAN(4).AND.Y0NEW.GE.COPLAN(4))IPLANE=4 IF(IPLANE.NE.0)THEN IF(LDEBUG)PRINT *,' ++++++ DLCMC DEBUG : Plane ', - IPLANE,' was crossed during the last step.' CALL DLCPLA(IPLANE,Q,ITYPE) RETURN ENDIF ENDIF *** Compute the electric field for the next step. CALL EFIELD(REAL(X0NEW),REAL(Y0NEW),REAL(Z0NEW),EX,EY,EZ,ETOT, - VOLT,0,ILOC) CALL BFIELD(REAL(X0NEW),REAL(Y0NEW),REAL(Z0NEW),BX,BY,BZ,BTOT) *** Check that no dielectric was entered nor that the mesh was left. IF(ICTYPE.EQ.0.AND.ILOC.NE.0)THEN CALL DLCFMP(X0,Y0,Z0,X0NEW,Y0NEW,Z0NEW,ILOC,Q,ITYPE) IF(LDEBUG)PRINT *,' ++++++ DLCMC DEBUG : Drift', - ' medium or mesh left at NU=',NU,' ILOC=',ILOC RETURN ENDIF *** Redefine X0, Y0 and Z0. X0=X0NEW Y0=Y0NEW Z0=Z0NEW *** Copy new X0 and Y0 to XU and YU, add new TU. NU=NU+1 XU(NU)=X0 YU(NU)=Y0 ZU(NU)=Z0 TU(NU)=TU(NU-1)+TSTEP *** Check particle position. CALL DLCSTA(Q,ITYPE) IF(ISTAT.NE.0)RETURN *** Make sure all exceptions have been caught. IF(ILOC.NE.0)THEN IF(LDEBUG)PRINT *,' ++++++ DLCMC DEBUG : Received ILOC=', - ILOC,' from EFIELD, NU=',NU,'; returning ISTAT=-3.' ISTAT=-3 RETURN * Make sure the field is not zero. ELSEIF(SQRT(EX**2+EY**2+EZ**2).LE.0)THEN IF(LDEBUG)PRINT *,' ++++++ DLCMC DEBUG : Electric field', - ' zero at NU=',NU,'; returning with ISTAT=-3.' ISTAT=-3 RETURN * Make sure we haven't got more than MXLIST points already. ELSEIF(NU.EQ.MXLIST)THEN ISTAT=-2 RETURN ENDIF *** And go for the next step. GOTO 30 END +DECK,DLCMCA. SUBROUTINE DLCMCA(X1,Y1,Z1,NETOT,NITOT,STAT, - NHIST,IHIST,ITYPE,IENTRY,OPTION) *----------------------------------------------------------------------- * DLCMCA - Subroutine that computes a drift line using a Monte-Carlo * technique to take account of diffusion and of avalanche * formation. * VARIABLES : * REFERENCE : * (Last changed on 22/ 1/01.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,GASDATA. +SEQ,PARAMETERS. +SEQ,DRIFTLINE. +SEQ,PRINTPLOT. +SEQ,CONSTANTS. INTEGER MXVEC PARAMETER(MXVEC=10000) REAL XLIST(MXMCA),YLIST(MXMCA),ZLIST(MXMCA),TLIST(MXMCA), - Q,X1,Y1,Z1,GASTWN,GASATT,PROBTH,PALPHA,PETA,TOFF, - ALPHA(MXLIST),ETA(MXLIST),RVECU(MXVEC),RVECN(MXVEC) INTEGER IFAIL,NLIST(MXMCA),NMCA,IPART,I,J,K,L,IMCA,NINTER, - NELEC,NION,NETOT,NITOT,NHIST,IHIST(*),IENTRY(*),ITYPE(2,*), - IVECU,IVECN,NEW,NMAX LOGICAL LELEPL,LIONPL,LTOWN,LATTA,STAT(4) COMMON /MCAMAT/ XLIST,YLIST,ZLIST,TLIST,NLIST CHARACTER*(*) OPTION EXTERNAL GASTWN,GASATT *** Identify the routine if requested. IF(LIDENT)PRINT *,' /// ROUTINE DLCMCA ///' *** Initial debugging output. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCMCA DEBUG : MC drift'', - '' from ('',E15.8,'','',E15.8,'','',E15.8,'')'')') X1,Y1,Z1 *** Make sure that electron drift velocities are available. IF(.NOT.GASOK(1))THEN PRINT *,' !!!!!! DLCMCA WARNING : Electron drift velocity'// - ' data missing; no avalanche.' RETURN ENDIF *** Obtain the matrix to store the avalanche development. CALL BOOK('BOOK','MCAMAT','MCA',IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! DLCMCA WARNING : Unable to obtain'// - ' storage for the avalanche; avalanche not computed.' RETURN ENDIF *** Default options. LELEPL=.FALSE. LIONPL=.FALSE. LTOWN=GASOK(4) LATTA=GASOK(6) NMAX=0 *** Default settings of parameters. PROBTH=0.01 *** Decode the options. IF(INDEX(OPTION,'NOPLOT-ELECTRON').NE.0)THEN LELEPL=.FALSE. ELSEIF(INDEX(OPTION,'PLOT-ELECTRON').NE.0)THEN LELEPL=.TRUE. ENDIF IF(INDEX(OPTION,'NOPLOT-ION').NE.0)THEN LIONPL=.FALSE. ELSEIF(INDEX(OPTION,'PLOT-ION').NE.0)THEN IF(.NOT.GASOK(2))THEN PRINT *,' !!!!!! DLCMCA WARNING : Ion mobilities are'// - ' absent; can not compute ion drift lines.' ELSE LIONPL=.TRUE. ENDIF ENDIF IF(INDEX(OPTION,'NOTOWNSEND').NE.0)THEN LTOWN=.FALSE. ELSEIF(INDEX(OPTION,'TOWNSEND').NE.0.AND..NOT.GASOK(4))THEN PRINT *,' !!!!!! DLCMCA WARNING : Townsend data is not'// - ' present; TOWNSEND option not valid.' ELSEIF(INDEX(OPTION,'TOWNSEND').NE.0)THEN LTOWN=.TRUE. ENDIF IF(INDEX(OPTION,'NOATTACHMENT').NE.0)THEN LATTA=.FALSE. ELSEIF(INDEX(OPTION,'ATTACHMENT').NE.0.AND..NOT.GASOK(6))THEN PRINT *,' !!!!!! DLCMCA WARNING : Attachment data is not'// - ' present; ATTACHMENT option not valid.' ELSEIF(INDEX(OPTION,'ATTACHMENT').NE.0)THEN LATTA=.TRUE. ENDIF IF(INDEX(OPTION,'ABORT-100000').NE.0)THEN NMAX=100000 ELSEIF(INDEX(OPTION,'ABORT-10000').NE.0)THEN NMAX=10000 ELSEIF(INDEX(OPTION,'ABORT-1000').NE.0)THEN NMAX=1000 ELSEIF(INDEX(OPTION,'ABORT-100').NE.0)THEN NMAX=100 ENDIF *** Make sure that some kind of output has been requested. IF(.NOT.(LATTA.OR.LTOWN))THEN PRINT *,' !!!!!! DLCMCA WARNING : Neither attachment not'// - ' multiplication to be included; no avalanche.' CALL BOOK('RELEASE','MCAMAT','MCA',IFAIL) RETURN ENDIF *** Initialise the avalanche table. NMCA=1 XLIST(1)=X1 YLIST(1)=Y1 ZLIST(1)=Z1 TLIST(1)=0 NLIST(1)=1 NETOT=1 NITOT=0 *** Loop over the table. IMCA=0 100 CONTINUE * Check we are still in the table. IMCA=IMCA+1 IF(IMCA.GT.NMCA)THEN CALL BOOK('RELEASE','MCAMAT','MCA',IFAIL) RETURN ENDIF *** Loop over the electrons at this location. DO 40 J=1,NLIST(IMCA) * Compute an electron drift line. Q=-1 IPART=1 CALL DLCMC(XLIST(IMCA),YLIST(IMCA),ZLIST(IMCA),Q,IPART) * Compute alpha and eta vectors. CALL DLCEQU(ALPHA,ETA,IFAIL) * Offset the time of the electrons by the starting time. DO 10 I=1,NU TU(I)=TU(I)+TLIST(IMCA) 10 CONTINUE *** Follow the avalanche development DO 20 I=1,NU-1 * Set initial number of electrons and ions. NELEC=1 NION=0 * Compute the number of subdivisions. NINTER=(ALPHA(I)+ETA(I))/PROBTH IF(NINTER.LT.1)NINTER=1 *** Loop over the subdivisions. DO 50 K=1,NINTER * Probabilities for gain and loss. PALPHA=ALPHA(I)/REAL(NINTER) PETA=ETA(I)/REAL(NINTER) * Gaussian approximation. IF(NELEC.GT.100)THEN DATA IVECN/0/ IF(IVECN.EQ.0.OR.IVECN+2.GT.MXVEC)THEN CALL RNORML(RVECN,MXVEC) IVECN=1 ENDIF IF(LTOWN)THEN NELEC=NELEC+NINT(REAL(NELEC)*PALPHA+RVECN(IVECN)* - SQRT(REAL(NELEC)*PALPHA*(1-PALPHA))) NION=NION+NINT(REAL(NELEC)*PALPHA+RVECN(IVECN)* - SQRT(REAL(NELEC)*PALPHA*(1-PALPHA))) IVECN=IVECN+1 ENDIF IF(LATTA)THEN NELEC=NELEC-NINT(REAL(NELEC)*PETA+RVECN(IVECN)* - SQRT(REAL(NELEC)*PETA*(1-PETA))) IVECN=IVECN+1 ENDIF * Binomial approximation. ELSE NEW=0 DO 80 L=1,NELEC DATA IVECU/0/ IF(IVECU.EQ.0.OR.IVECU+2.GT.MXVEC)THEN CALL RANLUX(RVECU,MXVEC) IVECU=1 ENDIF IF(LTOWN)THEN IF(RVECU(IVECU).LT.PALPHA)THEN NEW=NEW+1 NION=NION+1 ENDIF IVECU=IVECU+1 ENDIF IF(LATTA)THEN IF(RVECU(IVECU).LT.PETA)NEW=NEW-1 IVECU=IVECU+1 ENDIF 80 CONTINUE NELEC=NELEC+NEW ENDIF * Verify that there still is an electron. IF(NELEC.LE.0)THEN NETOT=NETOT-1 IF(STAT(2))CALL DLCMCF(REAL(XU(I)+XU(I+1))/2, - REAL(YU(I)+YU(I+1))/2,REAL(ZU(I)+ZU(I+1))/2, - REAL(TU(I)+TU(I+1))/2,1,NHIST,IHIST, - ITYPE,IENTRY,2) GOTO 60 ENDIF * Next subdivision. 50 CONTINUE 60 CONTINUE *** If at least 1 new electron has been created, add to the table. IF(NELEC.GT.1)THEN * Ensure we do not pass the maximum permitted avalanche size. IF(NMCA+1.GT.NMAX.AND.NMAX.GT.0)THEN PRINT *,' !!!!!! DLCMCA WARNING : Avalanche exceeds'// - ' maximum permitted size; avalanche ended.' CALL BOOK('RELEASE','MCAMAT','MCA',IFAIL) RETURN * Ensure there is still space in the table. ELSEIF(NMCA+1.GT.MXMCA)THEN PRINT *,' !!!!!! DLCMCA WARNING : Overflow of'// - ' secondary electron table; avalanche ended.' CALL BOOK('RELEASE','MCAMAT','MCA',IFAIL) RETURN ENDIF * Add the point to the table, NMCA=NMCA+1 XLIST(NMCA)=XU(I+1) YLIST(NMCA)=YU(I+1) ZLIST(NMCA)=ZU(I+1) TLIST(NMCA)=TU(I+1) NLIST(NMCA)=NELEC-1 * And also enter in the overall statistics. NETOT=NETOT+NELEC-1 * And enter the newly created electrons in the histograms. IF(STAT(1))CALL DLCMCF(REAL(XU(I)+XU(I+1))/2, - REAL(YU(I)+YU(I+1))/2,REAL(ZU(I)+ZU(I+1))/2, - REAL(TU(I)+TU(I+1))/2,NELEC-1,NHIST,IHIST, - ITYPE,IENTRY,1) ENDIF *** Also compute the newly produced ions if requested. IF(NION.GE.1.AND.(LIONPL.OR.STAT(4)))THEN * Store offset time. TOFF=TU(I+1) * Make a backup of the electron drift line. CALL DLCBCK('SAVE') DO 30 K=1,NION * Compute the ion drift lines. Q=+1 IPART=2 CALL DLCMC(XLIST(NMCA),YLIST(NMCA),ZLIST(NMCA),Q,IPART) * Offset the time of the ions by the starting time. DO 90 L=1,NU TU(L)=TU(L)+TOFF 90 CONTINUE * Enter the ion end point in the histograms if requested. IF(STAT(4))CALL DLCMCF(REAL(XU(NU)),REAL(YU(NU)), - REAL(ZU(NU)),REAL(TU(NU)),1, - NHIST,IHIST,ITYPE,IENTRY,4) * Plot the ion drift line. IF(LIONPL)CALL DLCPLT 30 CONTINUE * Restore electron drift line. CALL DLCBCK('RESTORE') ENDIF *** Keep track of ion statistics. NITOT=NITOT+NION *** Make sure the electron is still alive. IF(NELEC.LE.0)THEN NU=I GOTO 70 ENDIF 20 CONTINUE * If electron survived, register its end point. IF(STAT(3))CALL DLCMCF(REAL(XU(NU)), - REAL(YU(NU)),REAL(ZU(NU)),REAL(TU(NU)),1, - NHIST,IHIST,ITYPE,IENTRY,3) * Plot the electron if requested. 70 CONTINUE IF(LELEPL)CALL DLCPLT * Proceed with next electron. 40 CONTINUE *** And proceed with the next table entry. GOTO 100 END +DECK,DLCMCF. SUBROUTINE DLCMCF(XPOS,YPOS,ZPOS,TPOS,N,NHIST,IHIST,ITYPE,IENTRY, - ISTAT) *----------------------------------------------------------------------- * DLCMCF - Takes care of histogramming for DLCMCA. * VARIABLES : * (Last changed on 27/ 9/97.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,PRINTPLOT. REAL XPOS,YPOS,ZPOS,TPOS,XXPOS,YYPOS,VAR(16),RES(2) INTEGER N,NHIST,IHIST(*),ITYPE(2,*),IENTRY(*),ISTAT,MODVAR(16), - MODRES(2),IFAIL,I,NREXP,IENTR *** For polar cells, convert to polar coordinates. IF(POLAR)THEN CALL CFMRTP(XPOS,YPOS,XXPOS,YYPOS,1) ELSE XXPOS=XPOS YYPOS=YPOS ENDIF *** Enter the values in the appropriate locations. DO 10 I=1,16 VAR(I)=0 MODVAR(I)=2 10 CONTINUE * Variables for pair creation. IF(ISTAT.EQ.1)THEN VAR(1)=XXPOS VAR(2)=YYPOS VAR(3)=ZPOS VAR(4)=TPOS * Electron attachment. ELSEIF(ISTAT.EQ.2)THEN VAR(5)=XXPOS VAR(6)=YYPOS VAR(7)=ZPOS VAR(8)=TPOS * Electron end of drift line. ELSEIF(ISTAT.EQ.3)THEN VAR(9)=XXPOS VAR(10)=YYPOS VAR(11)=ZPOS VAR(12)=TPOS * Ion end of drift line. ELSEIF(ISTAT.EQ.4)THEN VAR(13)=XXPOS VAR(14)=YYPOS VAR(15)=ZPOS VAR(16)=TPOS * Other (unknown) types. ELSE PRINT *,' ###### DLCMCF ERROR : Invalid statistics'// - ' code received; no histogram entry.' RETURN ENDIF *** Loop over the histograms. DO 20 I=1,NHIST IF(ISTAT.NE.ITYPE(1,I))GOTO 20 * Preset results. RES(1)=0 RES(2)=0 * Evaluate formulae. NREXP=ITYPE(2,I) IENTR=IENTRY(I) CALL AL2EXE(IENTR,VAR,MODVAR,16,RES,MODRES,NREXP,IFAIL) * Check that there was no error. IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! DLCMCF WARNING : Arithmetic error while'// - ' evaluating a histogram function.' * Make sure that the mode is correct. ELSEIF(MODRES(1).NE.2)THEN PRINT *,' !!!!!! DLCMCF WARNING : Formula resulted in'// - ' non-number type entry; no histogram entry.' * In case of conditional filling, check mode of condition. ELSEIF(ITYPE(2,I).EQ.2.AND.MODRES(2).NE.3)THEN PRINT *,' !!!!!! DLCMCF WARNING : Formula resulted in'// - ' non-logical type condition no histogram entry.' * Fill. ELSEIF(ITYPE(2,I).EQ.1.OR.NINT(RES(2)).EQ.1)THEN CALL HISENT(IHIST(I),RES(1),REAL(N)) ENDIF 20 CONTINUE END +DECK,DLCMCT. SUBROUTINE DLCMCT(NE,NI) *----------------------------------------------------------------------- * DLCMCT - Generates a random avalanche development. * VARIABLES : * (Last changed on 4/ 2/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,GASDATA. +SEQ,PARAMETERS. +SEQ,DRIFTLINE. +SEQ,PRINTPLOT. +SEQ,CONSTANTS. INTEGER NE,NI,NEW,ILOC,NINTER,I,J,K,MXVEC,IVECU,IVECN PARAMETER(MXVEC=10000) REAL GASTWN,GASATT,XPOS1,YPOS1,XPOS2,YPOS2,EX,EY,EZ,ETOT, - VOLT,ALPHA(MXLIST),ETA(MXLIST),STEP,SCALE,SUB1,SUB2, - PROBTH,RVECU(MXVEC),RVECN(MXVEC),PALPHA,PETA,BX,BY,BZ,BTOT DOUBLE PRECISION VD(3),VTERM(3),WG6(6),TG6(6) LOGICAL TRY1,TRY2,DONE PARAMETER(PROBTH=0.01) LOGICAL LTOWN,LATTA EXTERNAL GASTWN,GASATT +SELF,IF=SAVE. SAVE IVECU,IVECN,RVECU,RVECN +SELF. *** Locations and weights for 6-point Gaussian integration. DATA (TG6(I),WG6(I),I=1,6) / - -0.93246 95142 03152 028D0, 0.17132 44923 79170 345D0, - -0.66120 93864 66264 514D0, 0.36076 15730 48138 608D0, - -0.23861 91860 83196 909D0, 0.46791 39345 72691 047D0, - 0.23861 91860 83196 909D0, 0.46791 39345 72691 047D0, - 0.66120 93864 66264 514D0, 0.36076 15730 48138 608D0, - 0.93246 95142 03152 028D0, 0.17132 44923 79170 345D0/ *** Identify the routine if requested. IF(LIDENT)PRINT *,' /// ROUTINE DLCMCT ///' *** Initial number of electrons. NE=1 NI=0 *** Make sure that electron drift velocities are available. IF(.NOT.(GASOK(1).AND.GASOK(4)))THEN PRINT *,' !!!!!! DLCMCT WARNING : Electron drift velocity'// - ' data / avalanche data missing; no avalanche.' RETURN ENDIF * Establish the flags. LTOWN=.FALSE. LATTA=.FALSE. IF(GASOK(4))LTOWN=.TRUE. IF(GASOK(6))LATTA=.TRUE. *** Check that a drift line exists. IF(IPTYPE.NE.1.OR.NU.LT.2)THEN PRINT *,' !!!!!! DLCMCT WARNING : Current drift line is'// - ' not for an electron or too short; no avalanche.' RETURN ENDIF *** Loop a first time over the drift line to check for returns. DO 100 I=1,NU-1 * Scaling factor for projected length. IF(LAVPRO)THEN VD(1)=0 VD(2)=0 VD(3)=0 DO 330 J=1,6 CALL DLCVEL( - XU(I)+(1+TG6(J))/2*(XU(I+1)-XU(I)), - YU(I)+(1+TG6(J))/2*(YU(I+1)-YU(I)), - ZU(I)+(1+TG6(J))/2*(ZU(I+1)-ZU(I)), - VTERM,QPCHAR,IPTYPE,ILOC) VD(1)=VD(1)+WG6(J)*VTERM(1) VD(2)=VD(2)+WG6(J)*VTERM(2) VD(3)=VD(3)+WG6(J)*VTERM(3) 330 CONTINUE IF(((XU(I+1)-XU(I))**2+ - (YU(I+1)-YU(I))**2+ - (ZU(I+1)-ZU(I))**2)* - (VD(1)**2+VD(2)**2+VD(3)**2).LE.0)THEN SCALE=0 ELSE SCALE=((XU(I+1)-XU(I))*VD(1)+ - (YU(I+1)-YU(I))*VD(2)+ - (ZU(I+1)-ZU(I))*VD(3))/ - SQRT(((XU(I+1)-XU(I))**2+ - (YU(I+1)-YU(I))**2+ - (ZU(I+1)-ZU(I))**2)* - (VD(1)**2+VD(2)**2+VD(3)**2)) ENDIF ELSE SCALE=1 ENDIF * Length of the step. XPOS1=REAL(XU(I)) YPOS1=REAL(YU(I)) IF(POLAR)CALL CFMRTC(XPOS1,YPOS1,XPOS1,YPOS1,1) XPOS2=REAL(XU(I+1)) YPOS2=REAL(YU(I+1)) IF(POLAR)CALL CFMRTC(XPOS2,YPOS2,XPOS2,YPOS2,1) STEP=SQRT((XPOS1-XPOS2)**2+(YPOS1-YPOS2)**2+(ZU(I+1)-ZU(I))**2) * Compute the mean Townsend and attachment coefficients. ALPHA(I)=0 ETA(I)=0 DO 320 J=1,6 CALL EFIELD( - REAL(XU(I)+(1+TG6(J))/2*(XU(I+1)-XU(I))), - REAL(YU(I)+(1+TG6(J))/2*(YU(I+1)-YU(I))), - REAL(ZU(I)+(1+TG6(J))/2*(ZU(I+1)-ZU(I))), - EX,EY,EZ,ETOT,VOLT,0,ILOC) CALL BFIELD( - REAL(XU(I)+(1+TG6(J))/2*(XU(I+1)-XU(I))), - REAL(YU(I)+(1+TG6(J))/2*(YU(I+1)-YU(I))), - REAL(ZU(I)+(1+TG6(J))/2*(ZU(I+1)-ZU(I))), - BX,BY,BZ,BTOT) IF(LTOWN)ALPHA(I)=ALPHA(I)+WG6(J)*GASTWN(EX,EY,EZ,BX,BY,BZ) IF(LATTA)ETA(I)=ETA(I)+WG6(J)*GASATT(EX,EY,EZ,BX,BY,BZ) 320 CONTINUE ALPHA(I)=ALPHA(I)*STEP*SCALE/2 ETA(I)=ETA(I)*STEP*SCALE/2 * Next point on the drift line. 100 CONTINUE *** Skip equilibration if there projection hasn't been requested. IF(.NOT.LAVPRO)GOTO 300 *** Try to alpha-equilibrate the returning parts. DO 110 I=1,NU-1 IF(ALPHA(I).LT.0)THEN * Targets for subtracting. SUB1=-ALPHA(I)/2 SUB2=-ALPHA(I)/2 TRY1=.TRUE. TRY2=.TRUE. * Try to subtract half in earlier points. DO 120 J=1,I-1 IF(ALPHA(I-J).GT.SUB1)THEN ALPHA(I-J)=ALPHA(I-J)-SUB1 ALPHA(I)=ALPHA(I)+SUB1 SUB1=0 GOTO 130 ELSEIF(ALPHA(I-J).GT.0)THEN ALPHA(I)=ALPHA(I)+ALPHA(I-J) SUB1=SUB1-ALPHA(I-J) ALPHA(I-J)=0 ENDIF 120 CONTINUE TRY1=.FALSE. 130 CONTINUE * Try to subtract the other half in later points. DO 140 J=1,NU-I-1 IF(ALPHA(I+J).GT.SUB2)THEN ALPHA(I+J)=ALPHA(I+J)-SUB2 ALPHA(I)=ALPHA(I)+SUB2 SUB2=0 GOTO 150 ELSEIF(ALPHA(I+J).GT.0)THEN ALPHA(I)=ALPHA(I)+ALPHA(I+J) SUB2=SUB2-ALPHA(I+J) ALPHA(I+J)=0 ENDIF 140 CONTINUE TRY2=.FALSE. 150 CONTINUE * Done if both sides have margin left. DONE=.FALSE. IF(TRY1.AND.TRY2)THEN DONE=.TRUE. * Try lower side again. ELSEIF(TRY1)THEN SUB1=-ALPHA(I) DO 160 J=1,I-1 IF(ALPHA(I-J).GT.SUB1)THEN ALPHA(I-J)=ALPHA(I-J)-SUB1 ALPHA(I)=ALPHA(I)+SUB1 SUB1=0 DONE=.TRUE. GOTO 170 ELSEIF(ALPHA(I-J).GT.0)THEN ALPHA(I)=ALPHA(I)+ALPHA(I-J) SUB1=SUB1-ALPHA(I-J) ALPHA(I-J)=0 ENDIF 160 CONTINUE 170 CONTINUE * Try upper side again. ELSEIF(TRY2)THEN SUB2=-ALPHA(I) DO 180 J=1,NU-I-1 IF(ALPHA(I+J).GT.SUB2)THEN ALPHA(I+J)=ALPHA(I+J)-SUB2 ALPHA(I)=ALPHA(I)+SUB2 SUB2=0 DONE=.TRUE. GOTO 190 ELSEIF(ALPHA(I+J).GT.0)THEN ALPHA(I)=ALPHA(I)+ALPHA(I+J) SUB2=SUB2-ALPHA(I+J) ALPHA(I+J)=0 ENDIF 180 CONTINUE 190 CONTINUE ENDIF * See whether we succeeded. IF(.NOT.DONE)THEN PRINT *,' !!!!!! DLCMCT WARNING : Unable to even out'// - ' backwards alpha steps; inaccurate avalanche.' GOTO 200 ENDIF ENDIF 110 CONTINUE 200 CONTINUE *** Try to eta-equilibrate the returning parts. DO 210 I=1,NU-1 IF(ETA(I).LT.0)THEN * Targets for subtracting. SUB1=-ETA(I)/2 SUB2=-ETA(I)/2 TRY1=.TRUE. TRY2=.TRUE. * Try to subtract half in earlier points. DO 220 J=1,I-1 IF(ETA(I-J).GT.SUB1)THEN ETA(I-J)=ETA(I-J)-SUB1 ETA(I)=ETA(I)+SUB1 SUB1=0 GOTO 230 ELSEIF(ETA(I-J).GT.0)THEN ETA(I)=ETA(I)+ETA(I-J) SUB1=SUB1-ETA(I-J) ETA(I-J)=0 ENDIF 220 CONTINUE TRY1=.FALSE. 230 CONTINUE * Try to subtract the other half in later points. DO 240 J=1,NU-I-1 IF(ETA(I+J).GT.SUB2)THEN ETA(I+J)=ETA(I+J)-SUB2 ETA(I)=ETA(I)+SUB2 SUB2=0 GOTO 250 ELSEIF(ETA(I+J).GT.0)THEN ETA(I)=ETA(I)+ETA(I+J) SUB2=SUB2-ETA(I+J) ETA(I+J)=0 ENDIF 240 CONTINUE TRY2=.FALSE. 250 CONTINUE * Done if both sides have margin left. DONE=.FALSE. IF(TRY1.AND.TRY2)THEN DONE=.TRUE. * Try lower side again. ELSEIF(TRY1)THEN SUB1=-ETA(I) DO 260 J=1,I-1 IF(ETA(I-J).GT.SUB1)THEN ETA(I-J)=ETA(I-J)-SUB1 ETA(I)=ETA(I)+SUB1 SUB1=0 DONE=.TRUE. GOTO 270 ELSEIF(ETA(I-J).GT.0)THEN ETA(I)=ETA(I)+ETA(I-J) SUB1=SUB1-ETA(I-J) ETA(I-J)=0 ENDIF 260 CONTINUE 270 CONTINUE * Try upper side again. ELSEIF(TRY2)THEN SUB2=-ETA(I) DO 280 J=1,NU-I-1 IF(ETA(I+J).GT.SUB2)THEN ETA(I+J)=ETA(I+J)-SUB2 ETA(I)=ETA(I)+SUB2 SUB2=0 DONE=.TRUE. GOTO 290 ELSEIF(ETA(I+J).GT.0)THEN ETA(I)=ETA(I)+ETA(I+J) SUB2=SUB2-ETA(I+J) ETA(I+J)=0 ENDIF 280 CONTINUE 290 CONTINUE ENDIF * See whether we succeeded. IF(.NOT.DONE)THEN PRINT *,' !!!!!! DLCMCT WARNING : Unable to even out'// - ' backwards eta steps; inaccurate avalanche.' GOTO 300 ENDIF ENDIF 210 CONTINUE 300 CONTINUE *** Loop over the drift line. DO 10 I=1,NU-1 * Compute the number of subdivisions. NINTER=(ALPHA(I)+ETA(I))/PROBTH IF(NINTER.LT.1)NINTER=1 ** Loop over the subdivisions. DO 20 J=1,NINTER * Probabilities for gain and loss. PALPHA=ALPHA(I)/REAL(NINTER) PETA=ETA(I)/REAL(NINTER) * Gaussian approximation. IF(NE.GT.100)THEN DATA IVECN/0/ IF(IVECN.EQ.0.OR.IVECN+2.GT.MXVEC)THEN CALL RNORML(RVECN,MXVEC) IVECN=1 ENDIF IF(LTOWN)THEN NE=NE+NINT(REAL(NE)*PALPHA+RVECN(IVECN)* - SQRT(REAL(NE)*PALPHA*(1-PALPHA))) NI=NI+NINT(REAL(NE)*PALPHA+RVECN(IVECN)* - SQRT(REAL(NE)*PALPHA*(1-PALPHA))) IVECN=IVECN+1 ENDIF IF(LATTA)THEN NE=NE-NINT(REAL(NE)*PETA+RVECN(IVECN)* - SQRT(REAL(NE)*PETA*(1-PETA))) IVECN=IVECN+1 ENDIF * Binomial approximation. ELSE NEW=0 DO 30 K=1,NE DATA IVECU/0/ IF(IVECU.EQ.0.OR.IVECU+2.GT.MXVEC)THEN CALL RANLUX(RVECU,MXVEC) IVECU=1 ENDIF IF(LTOWN)THEN IF(RVECU(IVECU).LT.PALPHA)THEN NEW=NEW+1 NI=NI+1 ENDIF IVECU=IVECU+1 ENDIF IF(LATTA)THEN IF(RVECU(IVECU).LT.PETA)NEW=NEW-1 IVECU=IVECU+1 ENDIF 30 CONTINUE NE=NE+NEW ENDIF * Verify that there still is an electron. IF(NE.LE.0)THEN NE=0 RETURN ENDIF * Next subdivision. 20 CONTINUE ** Next step of the drift line. 10 CONTINUE END +DECK,DLCEQU. SUBROUTINE DLCEQU(ALPHA,ETA,IFAIL) *----------------------------------------------------------------------- * DLCEQU - Computes equilibrated alpha's and eta's over the current * drift line. * VARIABLES : * (Last changed on 13/ 5/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,GASDATA. +SEQ,PARAMETERS. +SEQ,DRIFTLINE. +SEQ,PRINTPLOT. +SEQ,CONSTANTS. INTEGER ILOC,I,J,IFAIL,IRES REAL GASTWN,GASATT,XPOS1,YPOS1,XPOS2,YPOS2,EX,EY,EZ,ETOT, - VOLT,ALPHA(MXLIST),ETA(MXLIST),STEP,SCALE,SUB1,SUB2, - BX,BY,BZ,BTOT,DRES DOUBLE PRECISION VD(3),VTERM(3),WG6(6),TG6(6) LOGICAL TRY1,TRY2,DONE LOGICAL LTOWN,LATTA EXTERNAL GASTWN,GASATT *** Locations and weights for 6-point Gaussian integration. DATA (TG6(I),WG6(I),I=1,6) / - -0.93246 95142 03152 028D0, 0.17132 44923 79170 345D0, - -0.66120 93864 66264 514D0, 0.36076 15730 48138 608D0, - -0.23861 91860 83196 909D0, 0.46791 39345 72691 047D0, - 0.23861 91860 83196 909D0, 0.46791 39345 72691 047D0, - 0.66120 93864 66264 514D0, 0.36076 15730 48138 608D0, - 0.93246 95142 03152 028D0, 0.17132 44923 79170 345D0/ *** Identify the routine if requested. IF(LIDENT)PRINT *,' /// ROUTINE DLCEQU ///' *** Assume this will fail. IFAIL=1 *** Make sure that electron drift velocities are available. IF(.NOT.(GASOK(1).AND.GASOK(4)))THEN PRINT *,' !!!!!! DLCEQU WARNING : Electron drift velocity'// - ' or avalanche data missing; avalanche not treated.' RETURN ENDIF * Establish the flags. LTOWN=.FALSE. LATTA=.FALSE. IF(GASOK(4))LTOWN=.TRUE. IF(GASOK(6))LATTA=.TRUE. *** Check that a drift line exists. IF(IPTYPE.NE.1)THEN PRINT *,' !!!!!! DLCEQU WARNING : Current drift line is'// - ' not for an electron; avalanche not processed.' RETURN ELSEIF(NU.LT.2)THEN RETURN ENDIF *** See whether the drift line ends in a wire. IF(ISTAT.GT.0)THEN IRES=MOD(ISTAT,MXWIRE) DRES=D(IRES) D(IRES)=DRES/2 ELSE IRES=0 ENDIF *** Loop a first time over the drift line to check for returns. DO 100 I=1,NU-1 * Scaling factor for projected length. IF(LAVPRO)THEN VD(1)=0 VD(2)=0 VD(3)=0 DO 330 J=1,6 CALL DLCVEL( - XU(I)+(1+TG6(J))/2*(XU(I+1)-XU(I)), - YU(I)+(1+TG6(J))/2*(YU(I+1)-YU(I)), - ZU(I)+(1+TG6(J))/2*(ZU(I+1)-ZU(I)), - VTERM,QPCHAR,IPTYPE,ILOC) VD(1)=VD(1)+WG6(J)*VTERM(1) VD(2)=VD(2)+WG6(J)*VTERM(2) VD(3)=VD(3)+WG6(J)*VTERM(3) 330 CONTINUE IF(((XU(I+1)-XU(I))**2+ - (YU(I+1)-YU(I))**2+ - (ZU(I+1)-ZU(I))**2)* - (VD(1)**2+VD(2)**2+VD(3)**2).LE.0)THEN SCALE=0 ELSE SCALE=((XU(I+1)-XU(I))*VD(1)+ - (YU(I+1)-YU(I))*VD(2)+ - (ZU(I+1)-ZU(I))*VD(3))/ - SQRT(((XU(I+1)-XU(I))**2+ - (YU(I+1)-YU(I))**2+ - (ZU(I+1)-ZU(I))**2)* - (VD(1)**2+VD(2)**2+VD(3)**2)) ENDIF ELSE SCALE=1 ENDIF * Length of the step. XPOS1=REAL(XU(I)) YPOS1=REAL(YU(I)) IF(POLAR)CALL CFMRTC(XPOS1,YPOS1,XPOS1,YPOS1,1) XPOS2=REAL(XU(I+1)) YPOS2=REAL(YU(I+1)) IF(POLAR)CALL CFMRTC(XPOS2,YPOS2,XPOS2,YPOS2,1) STEP=SQRT((XPOS1-XPOS2)**2+(YPOS1-YPOS2)**2+(ZU(I+1)-ZU(I))**2) * Compute the mean Townsend and attachment coefficients. ALPHA(I)=0 ETA(I)=0 DO 320 J=1,6 CALL EFIELD( - REAL(XU(I)+(1+TG6(J))/2*(XU(I+1)-XU(I))), - REAL(YU(I)+(1+TG6(J))/2*(YU(I+1)-YU(I))), - REAL(ZU(I)+(1+TG6(J))/2*(ZU(I+1)-ZU(I))), - EX,EY,EZ,ETOT,VOLT,0,ILOC) CALL BFIELD( - REAL(XU(I)+(1+TG6(J))/2*(XU(I+1)-XU(I))), - REAL(YU(I)+(1+TG6(J))/2*(YU(I+1)-YU(I))), - REAL(ZU(I)+(1+TG6(J))/2*(ZU(I+1)-ZU(I))), - BX,BY,BZ,BTOT) IF(LTOWN)ALPHA(I)=ALPHA(I)+WG6(J)*GASTWN(EX,EY,EZ,BX,BY,BZ) IF(LATTA)ETA(I)=ETA(I)+WG6(J)*GASATT(EX,EY,EZ,BX,BY,BZ) 320 CONTINUE ALPHA(I)=ALPHA(I)*STEP*SCALE/2 ETA(I)=ETA(I)*STEP*SCALE/2 * Next point on the drift line. 100 CONTINUE *** Skip equilibration if there projection hasn't been requested. IF(.NOT.LAVPRO)THEN IFAIL=0 IF(IRES.GT.0)D(IRES)=DRES RETURN ENDIF *** Try to alpha-equilibrate the returning parts. DO 110 I=1,NU-1 IF(ALPHA(I).LT.0)THEN * Targets for subtracting. SUB1=-ALPHA(I)/2 SUB2=-ALPHA(I)/2 TRY1=.TRUE. TRY2=.TRUE. * Try to subtract half in earlier points. DO 120 J=1,I-1 IF(ALPHA(I-J).GT.SUB1)THEN ALPHA(I-J)=ALPHA(I-J)-SUB1 ALPHA(I)=ALPHA(I)+SUB1 SUB1=0 GOTO 130 ELSEIF(ALPHA(I-J).GT.0)THEN ALPHA(I)=ALPHA(I)+ALPHA(I-J) SUB1=SUB1-ALPHA(I-J) ALPHA(I-J)=0 ENDIF 120 CONTINUE TRY1=.FALSE. 130 CONTINUE * Try to subtract the other half in later points. DO 140 J=1,NU-I-1 IF(ALPHA(I+J).GT.SUB2)THEN ALPHA(I+J)=ALPHA(I+J)-SUB2 ALPHA(I)=ALPHA(I)+SUB2 SUB2=0 GOTO 150 ELSEIF(ALPHA(I+J).GT.0)THEN ALPHA(I)=ALPHA(I)+ALPHA(I+J) SUB2=SUB2-ALPHA(I+J) ALPHA(I+J)=0 ENDIF 140 CONTINUE TRY2=.FALSE. 150 CONTINUE * Done if both sides have margin left. DONE=.FALSE. IF(TRY1.AND.TRY2)THEN DONE=.TRUE. * Try lower side again. ELSEIF(TRY1)THEN SUB1=-ALPHA(I) DO 160 J=1,I-1 IF(ALPHA(I-J).GT.SUB1)THEN ALPHA(I-J)=ALPHA(I-J)-SUB1 ALPHA(I)=ALPHA(I)+SUB1 SUB1=0 DONE=.TRUE. GOTO 170 ELSEIF(ALPHA(I-J).GT.0)THEN ALPHA(I)=ALPHA(I)+ALPHA(I-J) SUB1=SUB1-ALPHA(I-J) ALPHA(I-J)=0 ENDIF 160 CONTINUE 170 CONTINUE * Try upper side again. ELSEIF(TRY2)THEN SUB2=-ALPHA(I) DO 180 J=1,NU-I-1 IF(ALPHA(I+J).GT.SUB2)THEN ALPHA(I+J)=ALPHA(I+J)-SUB2 ALPHA(I)=ALPHA(I)+SUB2 SUB2=0 DONE=.TRUE. GOTO 190 ELSEIF(ALPHA(I+J).GT.0)THEN ALPHA(I)=ALPHA(I)+ALPHA(I+J) SUB2=SUB2-ALPHA(I+J) ALPHA(I+J)=0 ENDIF 180 CONTINUE 190 CONTINUE ENDIF * See whether we succeeded. IF(.NOT.DONE)THEN PRINT *,' !!!!!! DLCEQU WARNING : Unable to even out'// - ' backwards alpha steps; inaccurate avalanche.' IF(IRES.GT.0)D(IRES)=DRES RETURN ENDIF ENDIF 110 CONTINUE *** Try to eta-equilibrate the returning parts. DO 210 I=1,NU-1 IF(ETA(I).LT.0)THEN * Targets for subtracting. SUB1=-ETA(I)/2 SUB2=-ETA(I)/2 TRY1=.TRUE. TRY2=.TRUE. * Try to subtract half in earlier points. DO 220 J=1,I-1 IF(ETA(I-J).GT.SUB1)THEN ETA(I-J)=ETA(I-J)-SUB1 ETA(I)=ETA(I)+SUB1 SUB1=0 GOTO 230 ELSEIF(ETA(I-J).GT.0)THEN ETA(I)=ETA(I)+ETA(I-J) SUB1=SUB1-ETA(I-J) ETA(I-J)=0 ENDIF 220 CONTINUE TRY1=.FALSE. 230 CONTINUE * Try to subtract the other half in later points. DO 240 J=1,NU-I-1 IF(ETA(I+J).GT.SUB2)THEN ETA(I+J)=ETA(I+J)-SUB2 ETA(I)=ETA(I)+SUB2 SUB2=0 GOTO 250 ELSEIF(ETA(I+J).GT.0)THEN ETA(I)=ETA(I)+ETA(I+J) SUB2=SUB2-ETA(I+J) ETA(I+J)=0 ENDIF 240 CONTINUE TRY2=.FALSE. 250 CONTINUE * Done if both sides have margin left. DONE=.FALSE. IF(TRY1.AND.TRY2)THEN DONE=.TRUE. * Try lower side again. ELSEIF(TRY1)THEN SUB1=-ETA(I) DO 260 J=1,I-1 IF(ETA(I-J).GT.SUB1)THEN ETA(I-J)=ETA(I-J)-SUB1 ETA(I)=ETA(I)+SUB1 SUB1=0 DONE=.TRUE. GOTO 270 ELSEIF(ETA(I-J).GT.0)THEN ETA(I)=ETA(I)+ETA(I-J) SUB1=SUB1-ETA(I-J) ETA(I-J)=0 ENDIF 260 CONTINUE 270 CONTINUE * Try upper side again. ELSEIF(TRY2)THEN SUB2=-ETA(I) DO 280 J=1,NU-I-1 IF(ETA(I+J).GT.SUB2)THEN ETA(I+J)=ETA(I+J)-SUB2 ETA(I)=ETA(I)+SUB2 SUB2=0 DONE=.TRUE. GOTO 290 ELSEIF(ETA(I+J).GT.0)THEN ETA(I)=ETA(I)+ETA(I+J) SUB2=SUB2-ETA(I+J) ETA(I+J)=0 ENDIF 280 CONTINUE 290 CONTINUE ENDIF * See whether we succeeded. IF(.NOT.DONE)THEN PRINT *,' !!!!!! DLCEQU WARNING : Unable to even out'// - ' backwards eta steps; inaccurate avalanche.' IF(IRES.GT.0)D(IRES)=DRES RETURN ENDIF ENDIF 210 CONTINUE *** Seems to have worked. IFAIL=0 IF(IRES.GT.0)D(IRES)=DRES END +DECK,DLCVAC. SUBROUTINE DLCVAC(X1,Y1,Z1,VX1,VY1,VZ1,Q,PMASS) *----------------------------------------------------------------------- * DLCVAC - Subroutine doing the actual drift line calculations in * vacuo. It communicates with the outside through sequence * DRIFTLINE. The calculations are based on a Runge Kutta * Nystroem method with step size control based on the * comparison of a 5th and a 2nd order estimate. * VARIABLES : H : Current stepsize (it is in fact a delta t). * HPREV : Stores the previous value of H (comparison) * INITCH : Used for checking initial stepsize (1 = ok) * (Last changed on 7/11/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,PARAMETERS. +SEQ,DRIFTLINE. +SEQ,PRINTPLOT. +SEQ,CONSTANTS. DOUBLE PRECISION TIME,VEL(3),POS(3),ACC(3),H,HPREV, - WORK(18),OLDPOS(3),OLDVEL(3),OLDACC(3),TRAPEZ(3) INTEGER ILOC,INITCH,ITYPE,ILOCVF,I,IOUT REAL Q,PMASS,X1,Y1,Z1,VX1,VY1,VZ1,EX,EY,EZ,ETOT,VOLT,EOVERM COMMON /VFUCOM/ EOVERM,ILOCVF EXTERNAL DLCVFU *** Identify the routine if requested. IF(LIDENT)PRINT *,' /// ROUTINE DLCVAC ///' *** Initialise the output position and time vectors. NU=1 XU(1)=DBLE(X1) YU(1)=DBLE(Y1) ZU(1)=DBLE(Z1) TU(1)=0.0D0 ISTAT=0 *** Set particle type according to mass and technique to vacuum. IF(ABS(PMASS-EMASS).LT.1E-4*(ABS(EMASS)+ABS(PMASS)))THEN IPTYPE=1 ELSE IPTYPE=2 ENDIF QPCHAR=Q IPTECH=3 *** Set the charge over mass ratio. EOVERM=Q/PMASS *** Check the initial position, setting a status code if appropriate. CALL EFIELD(X1,Y1,Z1,EX,EY,EZ,ETOT,VOLT,0,ILOC) * In a wire. IF(ILOC.GT.0.AND.ILOC.LE.MXWIRE)THEN IF((X(ILOC)-X1)**2+(Y(ILOC)-Y1)**2.LE.0.25*D(ILOC)**2)THEN ISTAT=ILOC ELSE ISTAT=ILOC+MXWIRE ENDIF * Outside the planes. ELSEIF(ILOC.EQ.-1.OR.ILOC.EQ.-4)THEN IF(YNPLAN(1).AND.X1.LE.COPLAN(1))THEN ISTAT=-11 ELSEIF(YNPLAN(2).AND.X1.GE.COPLAN(2))THEN ISTAT=-12 ELSEIF(YNPLAN(3).AND.Y1.LE.COPLAN(3))THEN ISTAT=-13 ELSEIF(YNPLAN(4).AND.Y1.GE.COPLAN(4))THEN ISTAT=-14 ELSEIF(TUBE)THEN CALL INTUBE(X1,Y1,COTUBE,NTUBE,IOUT) IF(IOUT.EQ.1)ISTAT=-15 ENDIF IF(ISTAT.EQ.0)THEN PRINT *,' !!!!!! DLCVAC WARNING : Field location'// - ' code does not match geometry; please report.' ISTAT=-4 ENDIF * In a material. ELSEIF(ILOC.EQ.-5)THEN ISTAT=-5 * Outside the mesh. ELSEIF(ILOC.EQ.-6)THEN ISTAT=-6 * Other bizarre codes. ELSEIF(ILOC.NE.0)THEN PRINT *,' ###### DLCVAC ERROR : Unexpected ILOC=',ILOC, - ' received from EFIELD ; program bug, please report.' ISTAT=-3 ENDIF * Always return if location code is non-zero. IF(ILOC.NE.0)RETURN *** Check the initial status, establishing eg the target wire. CALL DLCSTA(Q,ITYPE) IF(ISTAT.NE.0)RETURN *** Set the initial step-size, ensure that the particle will move. POS(1)=DBLE(X1) POS(2)=DBLE(Y1) POS(3)=DBLE(Z1) VEL(1)=DBLE(VX1) VEL(2)=DBLE(VY1) VEL(3)=DBLE(VZ1) CALL DLCVFU(0.0D0,POS,VEL,ACC) IF(ACC(1)**2+ACC(2)**2+ACC(3)**2.GT.0)THEN H=100*(-SQRT(VEL(1)**2+VEL(2)**2+VEL(3)**2)+ - SQRT(VEL(1)**2+VEL(2)**2+VEL(3)**2+ - 2*EPSDIF*SQRT(ACC(1)**2+ACC(2)**2+ACC(3)**2)))/ - SQRT(ACC(1)**2+ACC(2)**2+ACC(3)**2) ELSEIF(VEL(1)**2+VEL(2)**2+VEL(3)**2.GT.0)THEN H=100*EPSDIF/SQRT(VEL(1)**2+VEL(2)**2+VEL(3)**2) ELSE PRINT *,' !!!!!! DLCVAC WARNING : Drift line starts'// - ' with zero velocity and zero acceleration;'// - ' abandoned' ISTAT=-3 RETURN ENDIF IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCVAC DEBUG : Initial'', - '' step size set to '',E10.3)') H *** Allow INITCH cycles to adjust the initial step-size. INITCH=3 20 CONTINUE NU=1 *** Set the initial time, position, velocity and acceleration. TIME=0 POS(1)=DBLE(X1) POS(2)=DBLE(Y1) POS(3)=DBLE(Z1) VEL(1)=DBLE(VX1) VEL(2)=DBLE(VY1) VEL(3)=DBLE(VZ1) CALL DLCVFU(0.0D0,POS,VEL,ACC) *** Next step. 30 CONTINUE IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCVAC DEBUG : Step '', - I4/26X,''(x,y,z)='',3E12.5,'' t='',E12.5)') - NU,(POS(I),I=1,3),TIME * Reset location code. ILOCVF=0 * Save old position. DO 40 I=1,3 OLDPOS(I)=POS(I) OLDVEL(I)=VEL(I) OLDACC(I)=ACC(I) 40 CONTINUE *** Take a Runge-Kutta-Nystroem step. CALL DRKNYS(3,H,TIME,POS,VEL,DLCVFU,WORK) *** Make a trapezoid estimate of the same step. CALL DLCVFU(0.0D0,POS,VEL,ACC) DO 50 I=1,3 TRAPEZ(I)=OLDPOS(I)+H*(VEL(I)+OLDVEL(I))/2+ - H**2*(ACC(I)+OLDACC(I))/8 50 CONTINUE *** Check that the target wire is not crossed while exploring the field. IF(ITARG.GT.0.AND.ILOCVF.GT.0)THEN IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCVAC DEBUG :'', - '' DLCWIR entered from DLCVAC for ILOCVF='',I5)') - ILOCVF CALL DLCWIR(1,Q,ITYPE) RETURN ENDIF *** Check that no dielectric was entered nor that the mesh was left. IF(ICTYPE.EQ.0.AND.ILOCVF.NE.0)THEN CALL DLCFMP(OLDPOS(1),OLDPOS(2),OLDPOS(3), - POS(1),POS(2),POS(3),ILOCVF,Q,ITYPE) IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCVAC DEBUG :'', - '' Drift medium or mesh left at NU='',I4, - '' ILOC='',I5)') NU,ILOCVF RETURN ENDIF *** Check particle position for other termination conditions. CALL DLCSTA(Q,ITYPE) IF(ISTAT.NE.0)RETURN *** Check bending angle. IF(LKINK.AND.NU.GT.1)THEN IF(VEL(1)*(XU(NU)-XU(NU-1))+VEL(2)*(YU(NU)-YU(NU-1))+ - VEL(3)*(ZU(NU)-ZU(NU-1)).LT.0)THEN ISTAT=-3 IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCVAC DEBUG :'', - '' Step '',I3,'': bending angle exceeds pi/2.''/ - 26X,''Velocity vector: '',3E15.8/ - 26X,''Previous step: '',3E15.8/ - 26X,''Inner product: '',E15.8)') - NU+1,VEL(1),VEL(2),VEL(3),XU(NU)-XU(NU-1), - YU(NU)-YU(NU-1),ZU(NU)-ZU(NU-1), - VEL(1)*(XU(NU)-XU(NU-1))+ - VEL(2)*(YU(NU)-YU(NU-1))+ - VEL(3)*(ZU(NU)-ZU(NU-1)) RETURN ENDIF ENDIF *** Copy new X0 and Y0 to XU and YU, add new TU. NU=NU+1 XU(NU)=POS(1) YU(NU)=POS(2) ZU(NU)=POS(3) TU(NU)=TIME *** Adjust step size by comparing trapezoid rule and RKN estimates. HPREV=H IF(POS(1).NE.TRAPEZ(1).OR.POS(2).NE.TRAPEZ(2).OR. - POS(3).NE.TRAPEZ(3))THEN H=H*SQRT(EPSDIF/(ABS(POS(1)-TRAPEZ(1))+ - ABS(POS(2)-TRAPEZ(2))+ABS(POS(3)-TRAPEZ(3)))) ELSE IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCVAC DEBUG :'', - '' Step size increased by a factor 2 in step '',I4, - '' (1st order = RKN).'')') NU H=H*2.0D0 ENDIF IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCVAC DEBUG :'', - '' 1st order: '',3E12.5/26X,''RKN: '',3E12.5/26X, - ''Step size changed by a factor '',E12.5,'' to '',E12.5)') - (TRAPEZ(I),I=1,3),(POS(I),I=1,3),H/HPREV,H *** Don't allow H to become too large in view of the time resolution. IF(H*ABS(VEL(1)).GT.(DXMAX-DXMIN)/10.0.OR. - H*ABS(VEL(2)).GT.(DYMAX-DYMIN)/10.0.OR. - H*ABS(VEL(3)).GT.(DZMAX-DZMIN)/10.0)THEN H=H/2 IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCVAC DEBUG :'', - '' Step size reduced by a factor 2 in step '',I4, - '' (step too long).'')') NU ENDIF *** Make sure that H is different from zero; this should always be ok. IF(H.EQ.0.0D0)THEN PRINT *,' ###### DLCVAC ERROR : Step ',NU,' step size is', - ' zero (program bug) ; the calculation is abandoned.' ISTAT=-3 RETURN ENDIF *** Check the initial step size. IF(INITCH.GT.0.AND.(H.LT.HPREV/5.0))THEN IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCVAC DEBUG :'', - '' Step size reinitialised, current value is '', - E12.5)') H INITCH=INITCH-1 GOTO 20 ENDIF INITCH=0 *** Don't allow H to grow too quickly. IF(H.GT.10.0*HPREV)THEN H=10.0*HPREV IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCVAC DEBUG :'', - '' Step size restricted to 10 x previous in step '', - I4,''.'')') NU ENDIF *** Make sure we haven't got more than MXLIST points already. IF(NU.EQ.MXLIST)THEN ISTAT=-2 RETURN ENDIF *** Stop in case H tends to become too small. IF(H*(ABS(VEL(1))+ABS(VEL(2))+ABS(VEL(3))).LT.EPSDIF)THEN IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCVAC DEBUG :'', - '' Step size smaller than EPSDIF in step '',I4, - '' ; line abandoned.'')') NU ISTAT=-3 RETURN ENDIF GOTO 30 END +DECK,DLCVFU. SUBROUTINE DLCVFU(TIME,POS,VEL,ACC) *----------------------------------------------------------------------- * DLCVFU - Computes the acceleration of a particle at time TIME, * location POS and initial velocity VEL. * (Last changed on 5/ 2/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,BFIELD. +SEQ,PARAMETERS. +SEQ,DRIFTLINE. +SEQ,PRINTPLOT. +SEQ,CONSTANTS. DOUBLE PRECISION TIME,POS(3),VEL(3),ACC(3),FACTOR REAL EX,EY,EZ,ETOT,VOLT,BX,BY,BZ,BTOT,EOVERM INTEGER ILOCVF,ILOC C INTEGER I COMMON /VFUCOM/ EOVERM,ILOCVF *** Compute the E and B fields. CALL EFIELD(REAL(POS(1)),REAL(POS(2)),REAL(POS(3)), - EX,EY,EZ,ETOT,VOLT,0,ILOC) CALL BFIELD(REAL(POS(1)),REAL(POS(2)),REAL(POS(3)), - BX,BY,BZ,BTOT) * If the point is located outside the drift area, set a flag. IF(ILOC.NE.0)THEN ILOCVF=ILOC ACC(1)=0 ACC(2)=0 ACC(3)=0 RETURN ENDIF *** Compute the relativistic correction and other common factors. FACTOR=1E-8*EOVERM* - SQRT(1-(VEL(1)**2+VEL(2)**2+VEL(3)**2)/CLIGHT**2)**3 *** Compute the force/mass acting on the particle. ACC(1)=FACTOR*(EX+VEL(2)*BZ-VEL(3)*BY) ACC(2)=FACTOR*(EY+VEL(3)*BX-VEL(1)*BZ) ACC(3)=FACTOR*(EZ+VEL(1)*BY-VEL(2)*BX) C IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCVFU DEBUG : (x,y,z)='', C - 3E12.5/26X,''v ='',3E12.5/26X,''a ='',3E12.5)') C - (POS(I),I=1,3),(VEL(I),I=1,3),(ACC(I),I=1,3) END +DECK,DLCCAL. SUBROUTINE DLCCAL(INSTR,IFAIL) *----------------------------------------------------------------------- * DLCCAL - Processes drift line related procedure calls. * (Last changed on 5/ 1/01.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,DRIFTLINE. +SEQ,CELLDATA. +SEQ,GASDATA. +SEQ,SOLIDS. +SEQ,ALGDATA. +SEQ,MATDATA. +SEQ,CONSTANTS. +SEQ,PRINTPLOT. INTEGER MXAHIS PARAMETER(MXAHIS=20) INTEGER INPCMX,ISIZ(MXMDIM),IRX,IRY,IRZ,IRT,ISX,ISY,ISZ,IST, - NCOPT,ISTR,NARG,IPROC,INSTR,IFAIL,IFAIL1,IFAIL2,IFAIL3, - IFAIL4,NPAIR,I,J,MATSLT,IAUX,NC,NREXP,ITYPE(2,MXAHIS),NHIST, - NETOT,NITOT,IENTRY(MXAHIS),IHIST(MXAHIS),ISW,ICL,ILOC,NC1, - NC2,NC3,NC4 REAL XCLS,YCLS,ZCLS,ECLS,VXMIN,VYMIN,VXMAX,VYMAX DOUBLE PRECISION XPOS1,YPOS1,XPOS2,YPOS2,F0(3) LOGICAL DONE,USE(MXVAR),STAT(4) EXTERNAL INPCMX,MATSLT CHARACTER*(MXINCH) TITLE,OPT CHARACTER*15 AUX1,AUX2,AUX3,AUX4 CHARACTER*10 VARLIS(16) *** Assume the CALL will fail. IFAIL=1 *** Verify that we really have a cell and a gas. IF(.NOT.CELSET)THEN PRINT *,' !!!!!! DLCCAL WARNING : Cell data not available'// - ' ; call not executed.' RETURN ELSEIF(.NOT.GASSET)THEN PRINT *,' !!!!!! DLCCAL WARNING : Gas data not available'// - ' ; call not executed.' RETURN ENDIF *** Some easy reference variables. NARG=INS(INSTR,3) IPROC=INS(INSTR,1) *** Start a new track. IF(IPROC.EQ.-501)THEN * Warn if there are arguments. IF(NARG.NE.0)PRINT *,' !!!!!! DLCCAL WARNING : The'// - ' NEW_TRACK procedure has no arguments; ignored.' * Reinitialise the track. CALL TRACLI *** Get a new cluster. ELSEIF(IPROC.EQ.-502)THEN * Check the arguments. IF(NARG.NE.6.OR.ARGREF(1,1).GE.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.OR.ARGREF(6,1).GE.2)THEN PRINT *,' !!!!!! DLCCAL WARNING : Incorrect set of'// - ' arguments for GET_CLUSTER; no cluster.' RETURN ENDIF * Clean up space associated with the arguments. DO 40 ISTR=1,NARG CALL ALGREU(NINT(ARG(ISTR)),MODARG(ISTR),ARGREF(ISTR,1)) 40 CONTINUE * Ask for a new cluster. CALL TRACLS(XCLS,YCLS,ZCLS,ECLS,NPAIR,DONE,IFAIL1) * Return the cluster position. ARG(1)=XCLS ARG(2)=YCLS ARG(3)=ZCLS MODARG(1)=2 MODARG(2)=2 MODARG(3)=2 * Return the cluster size. ARG(4)=REAL(NPAIR) MODARG(4)=2 * Return the cluster energy. ARG(5)=ECLS MODARG(5)=2 * Set the flag whether to continue or not. IF(DONE)THEN ARG(6)=1 ELSE ARG(6)=0 ENDIF MODARG(6)=3 * Check the return flag for failure. IF(IFAIL1.EQ.0)THEN CALL LOGSAV(.TRUE.,'OK',IFAIL1) ELSE CALL LOGSAV(.FALSE.,'OK',IFAIL1) ENDIF *** Drift line calculation for electrons. ELSEIF(IPROC.EQ.-503)THEN * Check number of arguments. IF(NARG.LT.2.OR.NARG.GT.7)THEN PRINT *,' !!!!!! DLCCAL WARNING : Incorrect number'// - ' of arguments for DRIFT_ELECTRON.' RETURN * Check argument mode. ELSEIF(MODARG(1).NE.2.OR.MODARG(2).NE.2)THEN PRINT *,' !!!!!! DLCCAL WARNING : Some arguments of'// - ' DRIFT_ELECTRON are of incorrect type.' RETURN * Check the the results can be transferred back. ELSEIF((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))THEN PRINT *,' !!!!!! DLCCAL WARNING : Some arguments'// - ' of DRIFT_ELECTRON can not be modified.' RETURN * Make sure there are drift velocities. ELSEIF(.NOT.GASOK(1))THEN PRINT *,' !!!!!! DLCCAL WARNING : The drift velocity'// - ' for electrons is not defined ; not executed.' RETURN ENDIF * Variables already in use ? DO 270 ISTR=3,NARG CALL ALGREU(NINT(ARG(ISTR)),MODARG(ISTR),ARGREF(ISTR,1)) 270 CONTINUE * Carry out the calculation. CALL DLCALC(ARG(1),ARG(2),0.0,-1.0,1) * Return status code. IF(NARG.GE.3)THEN CALL DLCSTF(ISTAT,OPT,NCOPT) CALL STRBUF('STORE',IAUX,OPT,NCOPT,IFAIL1) ARG(3)=REAL(IAUX) MODARG(3)=1 IF(IFAIL1.NE.0)PRINT *,' !!!!!! DLCCAL WARNING :'// - ' Error storing the status for DRIFT_ELECTRON.' ENDIF * Compute and return requested numerical data. ARG(4)=TU(NU) IF(NARG.GE.5)CALL DLCDIF(ARG(5)) IF(NARG.GE.6)CALL DLCTWN(ARG(6)) IF(NARG.GE.7)CALL DLCATT(ARG(7)) MODARG(4)=2 MODARG(5)=2 MODARG(6)=2 MODARG(7)=2 *** Drift line calculation for positrons. ELSEIF(IPROC.EQ.-521)THEN * Check number of arguments. IF(NARG.LT.2.OR.NARG.GT.4)THEN PRINT *,' !!!!!! DLCCAL WARNING : Incorrect number'// - ' of arguments for DRIFT_POSITRON.' RETURN * Check argument mode. ELSEIF(MODARG(1).NE.2.OR.MODARG(2).NE.2)THEN PRINT *,' !!!!!! DLCCAL WARNING : Some arguments of'// - ' DRIFT_POSITRON are of incorrect type.' RETURN * Check the the results can be transferred back. ELSEIF((NARG.GE.3.AND.ARGREF(3,1).GE.2).OR. - (NARG.GE.4.AND.ARGREF(4,1).GE.2))THEN PRINT *,' !!!!!! DLCCAL WARNING : Some arguments'// - ' of DRIFT_POSITRON can not be modified.' RETURN * Make sure there are drift velocities. ELSEIF(.NOT.GASOK(1))THEN PRINT *,' !!!!!! DLCCAL WARNING : The drift velocity'// - ' for electrons is not defined ; not executed.' RETURN ENDIF * Variables already in use ? DO 300 ISTR=3,NARG CALL ALGREU(NINT(ARG(ISTR)),MODARG(ISTR),ARGREF(ISTR,1)) 300 CONTINUE * Carry out the calculation. CALL DLCALC(ARG(1),ARG(2),0.0,+1.0,1) * Return status code. IF(NARG.GE.3)THEN CALL DLCSTF(ISTAT,OPT,NCOPT) CALL STRBUF('STORE',IAUX,OPT,NCOPT,IFAIL1) ARG(3)=REAL(IAUX) MODARG(3)=1 IF(IFAIL1.NE.0)PRINT *,' !!!!!! DLCCAL WARNING :'// - ' Error storing the status for DRIFT_POSITRON.' ENDIF * Compute and return requested numerical data. ARG(4)=TU(NU) MODARG(4)=2 *** Drift line calculation for ions. ELSEIF(IPROC.EQ.-504.OR.IPROC.EQ.-514)THEN * Check number of arguments. IF(NARG.LT.2.OR.NARG.GT.4)THEN PRINT *,' !!!!!! DLCCAL WARNING : Incorrect number'// - ' of arguments for DRIFT_ION.' RETURN * Check argument mode. ELSEIF(MODARG(1).NE.2.OR.MODARG(2).NE.2)THEN PRINT *,' !!!!!! DLCCAL WARNING : Some arguments of'// - ' DRIFT_ION are of incorrect type.' RETURN * Check the the results can be transferred back. ELSEIF((NARG.GE.3.AND.ARGREF(3,1).GE.2).OR. - (NARG.GE.4.AND.ARGREF(4,1).GE.2))THEN PRINT *,' !!!!!! DLCCAL WARNING : Some arguments'// - ' of DRIFT_ION can not be modified.' RETURN * Make sure there are drift velocities. ELSEIF(.NOT.GASOK(2))THEN PRINT *,' !!!!!! DLCCAL WARNING : The mobility'// - ' for ions is not defined ; not executed.' RETURN ENDIF * Variables already in use ? IF(NARG.GE.3)CALL ALGREU(NINT(ARG(3)),MODARG(3),ARGREF(3,1)) IF(NARG.GE.4)CALL ALGREU(NINT(ARG(4)),MODARG(4),ARGREF(4,1)) * Carry out the calculation. IF(IPROC.EQ.-504)THEN CALL DLCALC(ARG(1),ARG(2),0.0,+1.0,2) ELSE CALL DLCALC(ARG(1),ARG(2),0.0,-1.0,2) ENDIF * Return status code. IF(NARG.GE.3)THEN CALL DLCSTF(ISTAT,OPT,NCOPT) CALL STRBUF('STORE',IAUX,OPT,NCOPT,IFAIL1) ARG(3)=REAL(IAUX) MODARG(3)=1 IF(IFAIL1.NE.0)PRINT *,' !!!!!! DLCCAL WARNING :'// - ' Error storing the status for DRIFT_ION.' ENDIF * Compute and return requested numerical data. ARG(4)=TU(NU) MODARG(4)=2 *** 3D Drift line calculation for electrons. ELSEIF(IPROC.EQ.-505)THEN * Check number of arguments. IF(NARG.LT.3.OR.NARG.GT.8)THEN PRINT *,' !!!!!! DLCCAL WARNING : Incorrect number'// - ' of arguments for DRIFT_ELECTRON_3.' RETURN * Check argument mode. ELSEIF(MODARG(1).NE.2.OR.MODARG(2).NE.2.OR. - MODARG(3).NE.2)THEN PRINT *,' !!!!!! DLCCAL WARNING : Some arguments of'// - ' DRIFT_ELECTRON_3 are of incorrect type.' RETURN * Check the the results can be transferred back. ELSEIF((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 *,' !!!!!! DLCCAL WARNING : Some arguments'// - ' of DRIFT_ELECTRON_3 can not be modified.' RETURN * Make sure there are drift velocities. ELSEIF(.NOT.GASOK(1))THEN PRINT *,' !!!!!! DLCCAL WARNING : The drift velocity'// - ' for electrons is not defined ; not executed.' RETURN ENDIF * Variables already in use ? DO 280 ISTR=4,NARG CALL ALGREU(NINT(ARG(ISTR)),MODARG(ISTR),ARGREF(ISTR,1)) 280 CONTINUE * Carry out the calculation. CALL DLCALC(ARG(1),ARG(2),ARG(3),-1.0,1) * Return status code. IF(NARG.GE.4)THEN CALL DLCSTF(ISTAT,OPT,NCOPT) CALL STRBUF('STORE',IAUX,OPT,NCOPT,IFAIL1) ARG(4)=REAL(IAUX) MODARG(4)=1 IF(IFAIL1.NE.0)PRINT *,' !!!!!! DLCCAL WARNING :'// - ' Error storing the status for DRIFT_ELECTRON_3.' ENDIF * Compute and return requested numerical data. ARG(5)=TU(NU) IF(NARG.GE.6)CALL DLCDIF(ARG(6)) IF(NARG.GE.7)CALL DLCTWN(ARG(7)) IF(NARG.GE.8)CALL DLCATT(ARG(8)) MODARG(5)=2 MODARG(6)=2 MODARG(7)=2 MODARG(8)=2 *** 3D Drift line calculation for positrons. ELSEIF(IPROC.EQ.-522)THEN * Check number of arguments. IF(NARG.LT.3.OR.NARG.GT.5)THEN PRINT *,' !!!!!! DLCCAL WARNING : Incorrect number'// - ' of arguments for DRIFT_POSITRON_3.' RETURN * Check argument mode. ELSEIF(MODARG(1).NE.2.OR.MODARG(2).NE.2.OR. - MODARG(3).NE.2)THEN PRINT *,' !!!!!! DLCCAL WARNING : Some arguments of'// - ' DRIFT_POSITRON_3 are of incorrect type.' RETURN * Check the the results can be transferred back. ELSEIF((NARG.GE.4.AND.ARGREF(4,1).GE.2).OR. - (NARG.GE.5.AND.ARGREF(5,1).GE.2))THEN PRINT *,' !!!!!! DLCCAL WARNING : Some arguments'// - ' of DRIFT_POSITRON_3 can not be modified.' RETURN * Make sure there are drift velocities. ELSEIF(.NOT.GASOK(1))THEN PRINT *,' !!!!!! DLCCAL WARNING : The drift velocity'// - ' for electrons is not defined ; not executed.' RETURN ENDIF * Variables already in use ? DO 310 ISTR=4,NARG CALL ALGREU(NINT(ARG(ISTR)),MODARG(ISTR),ARGREF(ISTR,1)) 310 CONTINUE * Carry out the calculation. CALL DLCALC(ARG(1),ARG(2),ARG(3),+1.0,1) * Return status code. IF(NARG.GE.4)THEN CALL DLCSTF(ISTAT,OPT,NCOPT) CALL STRBUF('STORE',IAUX,OPT,NCOPT,IFAIL1) ARG(4)=REAL(IAUX) MODARG(4)=1 IF(IFAIL1.NE.0)PRINT *,' !!!!!! DLCCAL WARNING :'// - ' Error storing the status for DRIFT_POSITRON_3.' ENDIF * Compute and return requested numerical data. ARG(5)=TU(NU) MODARG(5)=2 *** 3D Drift line calculation for ions. ELSEIF(IPROC.EQ.-506.OR.IPROC.EQ.-515)THEN * Check number of arguments. IF(NARG.LT.3.OR.NARG.GT.5)THEN PRINT *,' !!!!!! DLCCAL WARNING : Incorrect number'// - ' of arguments for DRIFT_ION_3.' RETURN * Check argument mode. ELSEIF(MODARG(1).NE.2.OR.MODARG(2).NE.2.OR. - MODARG(3).NE.2)THEN PRINT *,' !!!!!! DLCCAL WARNING : Some arguments of'// - ' DRIFT_ION_3 are of incorrect type.' RETURN * Check the the results can be transferred back. ELSEIF((NARG.GE.4.AND.ARGREF(4,1).GE.2).OR. - (NARG.GE.5.AND.ARGREF(5,1).GE.2))THEN PRINT *,' !!!!!! DLCCAL WARNING : Some arguments'// - ' of DRIFT_ION_3 can not be modified.' RETURN * Make sure there are drift velocities. ELSEIF(.NOT.GASOK(2))THEN PRINT *,' !!!!!! DLCCAL WARNING : The mobility'// - ' for ions is not defined ; not executed.' RETURN ENDIF * Variables already in use ? IF(NARG.GE.4)CALL ALGREU(NINT(ARG(4)),MODARG(4),ARGREF(4,1)) IF(NARG.GE.5)CALL ALGREU(NINT(ARG(5)),MODARG(5),ARGREF(5,1)) * Carry out the calculation. IF(IPROC.EQ.-506)THEN CALL DLCALC(ARG(1),ARG(2),ARG(3),+1.0,2) ELSE CALL DLCALC(ARG(1),ARG(2),ARG(3),-1.0,2) ENDIF * Return status code. IF(NARG.GE.4)THEN CALL DLCSTF(ISTAT,OPT,NCOPT) CALL STRBUF('STORE',IAUX,OPT,NCOPT,IFAIL1) ARG(4)=REAL(IAUX) MODARG(4)=1 IF(IFAIL1.NE.0)PRINT *,' !!!!!! DLCCAL WARNING :'// - ' Error storing the status for DRIFT_ION_3.' ENDIF * Compute and return requested numerical data. ARG(5)=TU(NU) MODARG(5)=2 *** Get the drift line. ELSEIF(IPROC.EQ.-507)THEN * Check the arguments. IF(NARG.LT.1.OR.NARG.GT.4.OR. - (NARG.GE.1.AND.ARGREF(1,1).GE.2).OR. - (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))THEN PRINT *,' !!!!!! DLCCAL WARNING : Incorrect argument'// - ' list for GET_DRIFT_LINE.' RETURN ELSEIF(ISTAT.EQ.0.OR.NU.LT.1)THEN PRINT *,' !!!!!! DLCCAL WARNING : No drift line in'// - ' memory currently.' RETURN ENDIF * Clear the arguments. IF(NARG.GE.1)CALL ALGREU(NINT(ARG(1)),MODARG(1),ARGREF(1,1)) IF(NARG.GE.2)CALL ALGREU(NINT(ARG(2)),MODARG(2),ARGREF(2,1)) IF(NARG.GE.3)CALL ALGREU(NINT(ARG(3)),MODARG(3),ARGREF(3,1)) IF(NARG.GE.4)CALL ALGREU(NINT(ARG(4)),MODARG(4),ARGREF(4,1)) * Allocate matrices. ISIZ(1)=NU IF(NARG.GE.1)THEN CALL MATADM('ALLOCATE',IRX,1,ISIZ,2,IFAIL1) ELSE IFAIL1=0 ENDIF IF(NARG.GE.2)THEN CALL MATADM('ALLOCATE',IRY,1,ISIZ,2,IFAIL2) ELSE IFAIL2=0 ENDIF IF(NARG.GE.3)THEN CALL MATADM('ALLOCATE',IRZ,1,ISIZ,2,IFAIL3) ELSE IFAIL3=0 ENDIF IF(NARG.GE.4)THEN CALL MATADM('ALLOCATE',IRT,1,ISIZ,2,IFAIL4) ELSE IFAIL4=0 ENDIF IF(NARG.GE.1)THEN ISX=MATSLT(IRX) ELSE ISX=1 ENDIF IF(NARG.GE.2)THEN ISY=MATSLT(IRY) ELSE ISY=1 ENDIF IF(NARG.GE.3)THEN ISZ=MATSLT(IRZ) ELSE ISZ=1 ENDIF IF(NARG.GE.4)THEN IST=MATSLT(IRT) ELSE IST=1 ENDIF IF(IFAIL1.NE.0.OR.ISX.LE.0.OR.IFAIL2.NE.0.OR.ISY.LE.0.OR. - IFAIL3.NE.0.OR.ISZ.LE.0.OR.IFAIL4.NE.0.OR.IST.LE.0)THEN PRINT *,' !!!!!! DLCCAL WARNING : Unable to allocate'// - ' output matrices for GET_DRIFT_LINE.' RETURN ENDIF * Copy the vectors. DO 10 I=1,NU IF(NARG.GE.1)MVEC(MORG(ISX)+I)=REAL(XU(I)) IF(NARG.GE.2)MVEC(MORG(ISY)+I)=REAL(YU(I)) IF(NARG.GE.3)MVEC(MORG(ISZ)+I)=REAL(ZU(I)) IF(NARG.GE.4)MVEC(MORG(IST)+I)=REAL(TU(I)) 10 CONTINUE * Save the vectors. IF(NARG.GE.1)THEN ARG(1)=IRX MODARG(1)=5 ENDIF IF(NARG.GE.2)THEN ARG(2)=IRY MODARG(2)=5 ENDIF IF(NARG.GE.3)THEN ARG(3)=IRZ MODARG(3)=5 ENDIF IF(NARG.GE.4)THEN ARG(4)=IRT MODARG(4)=5 ENDIF *** 3D MC drift line calculation for electrons. ELSEIF(IPROC.EQ.-508)THEN * Check number of arguments. IF(NARG.LT.3.OR.NARG.GT.7)THEN PRINT *,' !!!!!! DLCCAL WARNING : Incorrect number'// - ' of arguments for DRIFT_ELECTRON_MC.' RETURN * Check argument mode. ELSEIF(MODARG(1).NE.2.OR.MODARG(2).NE.2.OR. - MODARG(3).NE.2)THEN PRINT *,' !!!!!! DLCCAL WARNING : Some arguments of'// - ' DRIFT_ELECTRON_MC are of incorrect type.' RETURN * Check the the results can be transferred back. ELSEIF((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))THEN PRINT *,' !!!!!! DLCCAL WARNING : Some arguments'// - ' of DRIFT_ELECTRON_MC can not be modified.' RETURN * Make sure there are drift velocities. ELSEIF(.NOT.GASOK(1))THEN PRINT *,' !!!!!! DLCCAL WARNING : The drift velocity'// - ' for electrons is not defined ; not executed.' RETURN ENDIF * Variables already in use ? DO 20 ISTR=4,NARG CALL ALGREU(NINT(ARG(ISTR)),MODARG(ISTR),ARGREF(ISTR,1)) 20 CONTINUE * Carry out the calculation. CALL DLCMC(ARG(1),ARG(2),ARG(3),-1.0,1) * Return status code. IF(NARG.GE.4)THEN CALL DLCSTF(ISTAT,OPT,NCOPT) CALL STRBUF('STORE',IAUX,OPT,NCOPT,IFAIL1) ARG(4)=REAL(IAUX) MODARG(4)=1 IF(IFAIL1.NE.0)PRINT *,' !!!!!! DLCCAL WARNING :'// - ' Error storing the status for DRIFT_ELECTRON_MC.' ENDIF * Compute and return requested numerical data. ARG(5)=TU(NU) IF(NARG.GE.6)CALL DLCTWN(ARG(6)) IF(NARG.GE.7)CALL DLCATT(ARG(7)) MODARG(5)=2 MODARG(6)=2 MODARG(7)=2 *** 3D MC drift line calculation for electrons. ELSEIF(IPROC.EQ.-523)THEN * Check number of arguments. IF(NARG.LT.3.OR.NARG.GT.5)THEN PRINT *,' !!!!!! DLCCAL WARNING : Incorrect number'// - ' of arguments for DRIFT_MC_POSITRON.' RETURN * Check argument mode. ELSEIF(MODARG(1).NE.2.OR.MODARG(2).NE.2.OR. - MODARG(3).NE.2)THEN PRINT *,' !!!!!! DLCCAL WARNING : Some arguments of'// - ' DRIFT_MC_POSITRON are of incorrect type.' RETURN * Check the the results can be transferred back. ELSEIF((NARG.GE.4.AND.ARGREF(4,1).GE.2).OR. - (NARG.GE.5.AND.ARGREF(5,1).GE.2))THEN PRINT *,' !!!!!! DLCCAL WARNING : Some arguments'// - ' of DRIFT_MC_POSITRON can not be modified.' RETURN * Make sure there are drift velocities. ELSEIF(.NOT.GASOK(1))THEN PRINT *,' !!!!!! DLCCAL WARNING : The drift velocity'// - ' for electrons is not defined ; not executed.' RETURN ENDIF * Variables already in use ? DO 320 ISTR=4,NARG CALL ALGREU(NINT(ARG(ISTR)),MODARG(ISTR),ARGREF(ISTR,1)) 320 CONTINUE * Carry out the calculation. CALL DLCMC(ARG(1),ARG(2),ARG(3),+1.0,1) * Return status code. IF(NARG.GE.4)THEN CALL DLCSTF(ISTAT,OPT,NCOPT) CALL STRBUF('STORE',IAUX,OPT,NCOPT,IFAIL1) ARG(4)=REAL(IAUX) MODARG(4)=1 IF(IFAIL1.NE.0)PRINT *,' !!!!!! DLCCAL WARNING :'// - ' Error storing the status for DRIFT_MC_POSITRON.' ENDIF * Compute and return requested numerical data. ARG(5)=TU(NU) MODARG(5)=2 *** 3D MC drift line calculation for ions. ELSEIF(IPROC.EQ.-509.OR.IPROC.EQ.-516)THEN * Check number of arguments. IF(NARG.LT.3.OR.NARG.GT.5)THEN PRINT *,' !!!!!! DLCCAL WARNING : Incorrect number'// - ' of arguments for DRIFT_ION_MC.' RETURN * Check argument mode. ELSEIF(MODARG(1).NE.2.OR.MODARG(2).NE.2.OR. - MODARG(3).NE.2)THEN PRINT *,' !!!!!! DLCCAL WARNING : Some arguments of'// - ' DRIFT_ION_MC are of incorrect type.' RETURN * Check the the results can be transferred back. ELSEIF((NARG.GE.4.AND.ARGREF(4,1).GE.2).OR. - (NARG.GE.5.AND.ARGREF(5,1).GE.2))THEN PRINT *,' !!!!!! DLCCAL WARNING : Some arguments'// - ' of DRIFT_ION_MC can not be modified.' RETURN * Make sure there are drift velocities. ELSEIF(.NOT.GASOK(2))THEN PRINT *,' !!!!!! DLCCAL WARNING : The mobility'// - ' for ions is not defined ; not executed.' RETURN ENDIF * Variables already in use ? CALL ALGREU(NINT(ARG(4)),MODARG(4),ARGREF(4,1)) CALL ALGREU(NINT(ARG(5)),MODARG(5),ARGREF(5,1)) * Carry out the calculation. IF(IPROC.EQ.-509)THEN CALL DLCMC(ARG(1),ARG(2),ARG(3),+1.0,2) ELSE CALL DLCMC(ARG(1),ARG(2),ARG(3),-1.0,2) ENDIF * Return status code. IF(NARG.GE.4)THEN CALL DLCSTF(ISTAT,OPT,NCOPT) CALL STRBUF('STORE',IAUX,OPT,NCOPT,IFAIL1) ARG(4)=REAL(IAUX) MODARG(4)=1 IF(IFAIL1.NE.0)PRINT *,' !!!!!! DLCCAL WARNING :'// - ' Error storing the status for DRIFT_ION_MC.' ENDIF * Compute and return requested numerical data. ARG(5)=TU(NU) MODARG(5)=2 *** Drift line calculation in vacuum for electrons. ELSEIF(IPROC.EQ.-517)THEN * Check number of arguments. IF(NARG.LT.6.OR.NARG.GT.8)THEN PRINT *,' !!!!!! DLCCAL WARNING : Incorrect number'// - ' of arguments for DRIFT_VACUUM_ELECTRON.' 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. - MODARG(5).NE.2.OR.MODARG(6).NE.2)THEN PRINT *,' !!!!!! DLCCAL WARNING : Some arguments of'// - ' DRIFT_VACUUM_ELECTRON are of incorrect type.' RETURN * Check the the results can be transferred back. ELSEIF((NARG.GE.7.AND.ARGREF(7,1).GE.2).OR. - (NARG.GE.8.AND.ARGREF(8,1).GE.2))THEN PRINT *,' !!!!!! DLCCAL WARNING : Some arguments'// - ' of DRIFT_VACUUM_ELECTRON can not be modified.' RETURN ENDIF * Variables already in use ? DO 290 ISTR=7,NARG CALL ALGREU(NINT(ARG(ISTR)),MODARG(ISTR),ARGREF(ISTR,1)) 290 CONTINUE * Carry out the calculation. CALL DLCVAC(ARG(1),ARG(2),ARG(3),ARG(4),ARG(5),ARG(6), - -ECHARG,EMASS) * Return status code. IF(NARG.GE.7)THEN CALL DLCSTF(ISTAT,OPT,NCOPT) CALL STRBUF('STORE',IAUX,OPT,NCOPT,IFAIL1) ARG(7)=REAL(IAUX) MODARG(7)=1 IF(IFAIL1.NE.0)PRINT *,' !!!!!! DLCCAL WARNING :'// - ' Error storing a string for'// - ' DRIFT_VACUUM_ELECTRON.' ENDIF * Return drift time. IF(NARG.GE.8)THEN ARG(8)=TU(NU) MODARG(8)=2 ENDIF *** Plot the drift line. ELSEIF(IPROC.EQ.-510)THEN * There are no arguments for this procedure. IF(NARG.NE.0)PRINT *,' !!!!!! DLCCAL WARNING :'// - ' PLOT_DRIFT_LINE has no arguments; ignored.' * Save the drift line. CALL DLCBCK('SAVE') * Plot the requested projection. CALL DLCPLT * Restore the drift line. CALL DLCBCK('RESTORE') *** Plot the track. ELSEIF(IPROC.EQ.-511)THEN * Warn if there are arguments. IF(NARG.NE.0)PRINT *,' !!!!!! DLCCAL WARNING : The'// - ' PLOT_TRACK procedure has no arguments; ignored.' * Plot the track. CALL TRAPLT *** 3D MC drift line calculation for electrons with avalanche. ELSEIF(IPROC.EQ.-512)THEN ** Check number of arguments. IF(NARG.LT.3.OR. - (NARG.GE.4.AND.MODARG(4).NE.1).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.NARG.NE.2*(NARG/2)).OR. - NARG.GT.6+2*MXAHIS)THEN PRINT *,' !!!!!! DLCCAL WARNING : Incorrect list of'// - ' arguments for AVALANCHE; not executed' RETURN * Make sure there are drift velocities. ELSEIF(.NOT.GASOK(1))THEN PRINT *,' !!!!!! DLCCAL WARNING : The drift velocity'// - ' for electrons is not defined ; not executed.' RETURN * Make sure there are Townsend coefficients. ELSEIF(.NOT.GASOK(4))THEN PRINT *,' !!!!!! DLCCAL WARNING : The Townsend'// - ' coefficient is not defined ; not executed.' RETURN ENDIF ** Fetch the option string. IF(NARG.GE.4)THEN CALL STRBUF('READ',NINT(ARG(4)),OPT,NCOPT,IFAIL1) CALL CLTOU(OPT(1:NCOPT)) ELSE OPT=' ' NCOPT=1 ENDIF ** Liberate storage associated with the electron and ion count. 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)) ** Create the entry point for the histogram formulae. IF(NARG.GE.7)THEN * Initialise the usage list. STAT(1)=.FALSE. STAT(2)=.FALSE. STAT(3)=.FALSE. STAT(4)=.FALSE. * Establish the variable list. IF(POLAR)THEN VARLIS(1)= 'R_CREATED' VARLIS(5)= 'R_LOST' VARLIS(9)= 'R_E' VARLIS(13)='R_ION' VARLIS(2)= 'PHI_CREATED' VARLIS(6)= 'PHI_LOST' VARLIS(10)='PHI_E' VARLIS(14)='PHI_ION' ELSE VARLIS(1)= 'X_CREATED' VARLIS(5)= 'X_LOST' VARLIS(9)= 'X_E' VARLIS(13)='X_ION' VARLIS(2)= 'Y_CREATED' VARLIS(6)= 'Y_LOST' VARLIS(10)='Y_E' VARLIS(14)='Y_ION' ENDIF VARLIS(3)= 'Z_CREATED' VARLIS(7)= 'Z_LOST' VARLIS(11)='Z_E' VARLIS(15)='Z_ION' VARLIS(4)= 'T_CREATED' VARLIS(8)= 'T_LOST' VARLIS(12)='T_E' VARLIS(16)='T_ION' * Number of histograms. NHIST=NARG/2-3 * Loop over the histograms. DO 30 I=1,NHIST * Fetch the histogram string. CALL STRBUF('READ',NINT(ARG(5+2*I)),TITLE,NC,IFAIL1) IF(IFAIL1.NE.0.OR.NC.LT.1)THEN PRINT *,' !!!!!! DLCCAL WARNING : Unable to get'// - ' an histogram formula; no avalanche.' RETURN ENDIF CALL CLTOU(TITLE(1:NC)) * Translate the formula. CALL ALGPRE(TITLE(1:NC),NC,VARLIS,16,NREXP,USE, - IENTRY(I),IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! DLCCAL WARNING : The histogram'// - ' function '//TITLE(1:NC)//' can not be'// - ' translated; no avalanche.' CALL ALGCLR(IENTRY(I)) RETURN ELSEIF(NREXP.LT.1.OR.NREXP.GT.2)THEN PRINT *,' !!!!!! DLCCAL WARNING : The histogram'// - ' function '//TITLE(1:NC)//' does not'// - ' return 1 or 2 results; no avalanche.' CALL ALGCLR(IENTRY(I)) RETURN ENDIF ITYPE(2,I)=NREXP * Work out which quantities are to be computed. ITYPE(1,I)=0 IF((USE( 1).OR.USE( 2).OR.USE( 3).OR.USE( 4)).AND. - ITYPE(1,I).NE.0)THEN PRINT *,' !!!!!! DLCCAL WARNING : Histogram'// - ' function '//TITLE(1:NC)//' uses an'// - ' invalid mix of parameters; no avalanche.' CALL ALGCLR(IENTRY(I)) RETURN ELSEIF(USE( 1).OR.USE( 2).OR.USE( 3).OR.USE( 4))THEN ITYPE(1,I)=1 ENDIF IF((USE( 5).OR.USE( 6).OR.USE( 7).OR.USE( 8)).AND. - ITYPE(1,I).NE.0)THEN PRINT *,' !!!!!! DLCCAL WARNING : Histogram'// - ' function '//TITLE(1:NC)//' uses an'// - ' invalid mix of parameters; no avalanche.' CALL ALGCLR(IENTRY(I)) RETURN ELSEIF(USE( 5).OR.USE( 6).OR.USE( 7).OR.USE( 8))THEN ITYPE(1,I)=2 ENDIF IF((USE( 9).OR.USE(10).OR.USE(11).OR.USE(12)).AND. - ITYPE(1,I).NE.0)THEN PRINT *,' !!!!!! DLCCAL WARNING : Histogram'// - ' function '//TITLE(1:NC)//' uses an'// - ' invalid mix of parameters; no avalanche.' CALL ALGCLR(IENTRY(I)) RETURN ELSEIF(USE( 9).OR.USE(10).OR.USE(11).OR.USE(12))THEN ITYPE(1,I)=3 ENDIF IF((USE(13).OR.USE(14).OR.USE(15).OR.USE(16)).AND. - ITYPE(1,I).NE.0)THEN PRINT *,' !!!!!! DLCCAL WARNING : Histogram'// - ' function '//TITLE(1:NC)//' uses an'// - ' invalid mix of parameters; no avalanche.' CALL ALGCLR(IENTRY(I)) RETURN ELSEIF(USE(13).OR.USE(14).OR.USE(15).OR.USE(16))THEN ITYPE(1,I)=4 ENDIF IF(ITYPE(1,I).EQ.0)THEN PRINT *,' !!!!!! DLCCAL WARNING : Histogram'// - ' function '//TITLE(1:NC)//' uses no'// - ' variables; no avalanche.' CALL ALGCLR(IENTRY(I)) RETURN ENDIF STAT(1)=STAT(1).OR.(ITYPE(1,I).EQ.1) STAT(2)=STAT(2).OR.(ITYPE(1,I).EQ.2) STAT(3)=STAT(3).OR.(ITYPE(1,I).EQ.3) STAT(4)=STAT(4).OR.(ITYPE(1,I).EQ.4) * Generate the histogram index list and check the number. IF(ARGREF(6+2*I,1).GE.2)THEN PRINT *,' !!!!!! DLCCAL WARNING : Histogram'// - ' argument ',I,' can not be modified;'// - ' no avalanche.' CALL ALGCLR(IENTRY(I)) RETURN ELSEIF(MODARG(6+2*I).EQ.4)THEN IHIST(I)=NINT(ARG(6+2*I)) ELSE CALL ALGREU(NINT(ARG(6+2*I)),MODARG(6+2*I), - ARGREF(6+2*I,1)) CALL HISADM('ALLOCATE',IHIST(I),100,0.0,0.0, - .TRUE.,IFAIL1) ENDIF 30 CONTINUE * No histograms to be made. ELSE STAT(1)=.FALSE. STAT(2)=.FALSE. STAT(3)=.FALSE. STAT(4)=.FALSE. NHIST=0 ENDIF ** Carry out the calculation. CALL DLCMCA(ARG(1),ARG(2),ARG(3),NETOT,NITOT, - STAT,NHIST,IHIST,ITYPE,IENTRY,OPT(1:NCOPT)) * Print algebra errors if there were any. CALL ALGERR ** Return the arguments and delete the instruction lists. IF(NARG.GE.5)THEN ARG(5)=REAL(NETOT) MODARG(5)=2 ENDIF IF(NARG.GE.6)THEN ARG(6)=REAL(NITOT) MODARG(6)=2 ENDIF DO 50 I=1,NHIST ARG(6+2*I)=REAL(IHIST(I)) MODARG(6+2*I)=4 CALL ALGCLR(IENTRY(I)) 50 CONTINUE *** Plot the drift area. ELSEIF(IPROC.EQ.-513)THEN * Check arguments. IF((NARG.NE.0.AND.NARG.NE.1).OR. - (NARG.EQ.1.AND.MODARG(1).NE.1))THEN PRINT *,' !!!!!! DLCCAL WARNING : Incorrect list'// - ' of arguments for PLOT_DRIFT_AREA; no plot.' RETURN ENDIF * See whether there is a title. IF(NARG.EQ.1)THEN CALL STRBUF('READ',NINT(ARG(1)),TITLE,NC,IFAIL1) ELSEIF(CELLID.EQ.' ')THEN TITLE='Layout of the cell' NC=18 ELSE TITLE=CELLID NC=LEN(CELLID) ENDIF * Plot the frame. CALL GRASET(DXMIN,DYMIN,DZMIN,DXMAX,DYMAX,DZMAX) CALL GRCELL(VXMIN,VYMIN,VXMAX,VYMAX,TITLE(1:NC)) IF(GASID.NE.' ')CALL GRCOMM(2,'Gas: '//GASID) *** Return the status code and other pieces of information. ELSEIF(IPROC.EQ.-520)THEN IF(NARG.LT.2.OR.2*(NARG/2).NE.NARG)THEN PRINT *,' !!!!!! DLCCAL WARNING : DRIFT_INFORMATION'// - ' received an odd number of arguments;'// - ' procedure not called.' RETURN ELSEIF(NU.LT.1)THEN PRINT *,' !!!!!! DLCCAL WARNING : The current'// - ' drift line has no steps; DRIFT_INFORMATION'// - ' not executed.' RETURN ENDIF * Loop over the options. DO 80 I=1,NARG-1,2 * Check the argument type. IF(MODARG(I).NE.1)THEN PRINT *,' !!!!!! DLCCAL WARNING : Argument ',I,' of', - ' DRIFT_INFORMATION is not of type String; no', - ' value returned.' GOTO 80 ENDIF * Fetch option. CALL STRBUF('READ',NINT(ARG(I)),TITLE,NC,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! DLCCAL WARNING : Error retrieving'// - ' the DRIFT_INFORMATION option.' GOTO 80 ENDIF IF(NC.GE.1)CALL CLTOU(TITLE(1:NC)) * Check we can return a value. IF(ARGREF(I+1,1).GE.2)THEN PRINT *,' !!!!!! DLCCAL WARNING : Can not return'// - ' a value for '//TITLE(1:NC)//' because the'// - ' following argument is not modifiable.' GOTO 80 ENDIF * Delete old contents of return variable. CALL ALGREU(NINT(ARG(I+1)),MODARG(I+1),ARGREF(I+1,1)) * Total drift time. IF(INPCMX(TITLE(1:NC),'DR#IFT-T#IME')+ - INPCMX(TITLE(1:NC),'TIME').NE.0)THEN ARG(I+1)=REAL(TU(NU)) MODARG(I+1)=2 * Charge of the particle. ELSEIF(INPCMX(TITLE(1:NC),'CHA#RGE').NE.0)THEN ARG(I+1)=QPCHAR MODARG(I+1)=2 * Particle being drifted. ELSEIF(INPCMX(TITLE(1:NC),'PART#ICLE').NE.0)THEN IF(IPTYPE.EQ.1)THEN CALL STRBUF('STORE',IAUX,'electron',8,IFAIL1) ARG(I+1)=REAL(IAUX) MODARG(I+1)=1 ELSEIF(IPTYPE.EQ.2)THEN CALL STRBUF('STORE',IAUX,'ion',3,IFAIL1) ARG(I+1)=REAL(IAUX) MODARG(I+1)=1 ELSE CALL STRBUF('STORE',IAUX,'unknown',7,IFAIL1) ARG(I+1)=REAL(IAUX) MODARG(I+1)=1 ENDIF IF(IFAIL1.NE.0)PRINT *,' !!!!!! DLCCAL WARNING :'// - ' Error storing the DRIFT_INFORMATION result.' * Integration technique used. ELSEIF(INPCMX(TITLE(1:NC),'TECH#IQUE').NE.0)THEN IF(IPTECH.EQ.1)THEN CALL STRBUF('STORE',IAUX,'Runge-Kutta-Fehlberg', - 20,IFAIL1) ARG(I+1)=REAL(IAUX) MODARG(I+1)=1 ELSEIF(IPTECH.EQ.2)THEN CALL STRBUF('STORE',IAUX,'Monte-Carlo',11,IFAIL1) ARG(I+1)=REAL(IAUX) MODARG(I+1)=1 ELSEIF(IPTECH.EQ.3)THEN CALL STRBUF('STORE',IAUX,'vacuum',6,IFAIL1) ARG(I+1)=REAL(IAUX) MODARG(I+1)=1 ELSE CALL STRBUF('STORE',IAUX,'unknown',7,IFAIL1) ARG(I+1)=REAL(IAUX) MODARG(I+1)=1 ENDIF IF(IFAIL1.NE.0)PRINT *,' !!!!!! DLCCAL WARNING :'// - ' Error storing the DRIFT_INFORMATION result.' * Numeric status code. ELSEIF(INPCMX(TITLE(1:NC),'STAT#US-#CODE').NE.0)THEN ARG(I+1)=REAL(ISTAT) MODARG(I+1)=2 * Electrode group. ELSEIF(INPCMX(TITLE(1:NC),'ELEC#TRODE').NE.0)THEN CALL DLCISW(ISTAT,ISW) ARG(I+1)=REAL(ISW) MODARG(I+1)=2 * String status code. ELSEIF(INPCMX(TITLE(1:NC),'STAT#US-#STRING').NE.0)THEN CALL DLCSTF(ISTAT,OPT,NCOPT) CALL STRBUF('STORE',IAUX,OPT,NCOPT,IFAIL1) ARG(I+1)=REAL(IAUX) MODARG(I+1)=1 IF(IFAIL1.NE.0)PRINT *,' !!!!!! DLCCAL WARNING :'// - ' Error storing the DRIFT_INFORMATION result.' * Number of steps. ELSEIF(INPCMX(TITLE(1:NC),'STEP#S').NE.0)THEN ARG(I+1)=REAL(NU) MODARG(I+1)=2 * Path length. ELSEIF(INPCMX(TITLE(1:NC),'PATH-#LENGTH')+ - INPCMX(TITLE(1:NC),'LENGTH').NE.0)THEN ARG(I+1)=0.0 DO 70 J=2,NU IF(POLAR)THEN CALL CF2RTC(XU(J-1),YU(J-1),XPOS1,YPOS1,1) CALL CF2RTC(XU(J) ,YU(J) ,XPOS2,YPOS2,1) ARG(I+1)=ARG(I+1)+SQRT((XPOS2-XPOS1)**2+ - (YPOS2-YPOS1)**2+(ZU(J)-ZU(J-1))**2) ELSE ARG(I+1)=ARG(I+1)+SQRT((XU(J)-XU(J-1))**2+ - (YU(J)-YU(J-1))**2+(ZU(J)-ZU(J-1))**2) ENDIF 70 CONTINUE MODARG(I+1)=2 * Start/end points. ELSEIF(INPCMX(TITLE(1:NC),'X-ST#ART')+ - INPCMX(TITLE(1:NC),'X_ST#ART')+ - INPCMX(TITLE(1:NC),'XST#ART').NE.0)THEN ARG(I+1)=XU(1) MODARG(I+1)=2 ELSEIF(INPCMX(TITLE(1:NC),'X-END')+ - INPCMX(TITLE(1:NC),'X_END')+ - INPCMX(TITLE(1:NC),'XEND').NE.0)THEN ARG(I+1)=XU(NU) MODARG(I+1)=2 ELSEIF(INPCMX(TITLE(1:NC),'Y-START')+ - INPCMX(TITLE(1:NC),'Y_ST#ART')+ - INPCMX(TITLE(1:NC),'YST#ART').NE.0)THEN ARG(I+1)=YU(1) MODARG(I+1)=2 ELSEIF(INPCMX(TITLE(1:NC),'Y-END')+ - INPCMX(TITLE(1:NC),'Y_END')+ - INPCMX(TITLE(1:NC),'YEND').NE.0)THEN ARG(I+1)=YU(NU) MODARG(I+1)=2 ELSEIF(INPCMX(TITLE(1:NC),'Z-START')+ - INPCMX(TITLE(1:NC),'Z_ST#ART')+ - INPCMX(TITLE(1:NC),'ZST#ART').NE.0)THEN ARG(I+1)=ZU(1) MODARG(I+1)=2 ELSEIF(INPCMX(TITLE(1:NC),'Z-END')+ - INPCMX(TITLE(1:NC),'Z_END')+ - INPCMX(TITLE(1:NC),'ZEND').NE.0)THEN ARG(I+1)=ZU(NU) MODARG(I+1)=2 * Unknown things. ELSE PRINT *,' !!!!!! DLCCAL WARNING : Unknown item "'// - TITLE(1:NC)//'" received ; no return value.' ENDIF 80 CONTINUE *** Interpolate in a track. ELSEIF(IPROC.EQ.-524)THEN * Check the arguments. IF(NARG.LT.4.OR.NARG.GT.9.OR. - MODARG(1).NE.2.OR.MODARG(2).NE.2.OR.MODARG(3).NE.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))THEN PRINT *,' !!!!!! DLCCAL WARNING : Some arguments of'// - ' INTERPOLATE_TRACK of wrong type or not'// - ' modifiable; not executed.' RETURN ENDIF * Variables already in use ? DO 330 ISTR=4,NARG CALL ALGREU(NINT(ARG(ISTR)),MODARG(ISTR),ARGREF(ISTR,1)) 330 CONTINUE * Perform the interpolation. CALL DLCTRI(ARG(1),ARG(2),ARG(3), - ARG(5),ICL,ARG(6),ARG(7),ARG(8),ARG(9), - NARG.GE.6,NARG.GE.7,NARG.GE.8,IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! DLCCAL WARNING : Interpolating the'// - ' track failed; no values returned.' DO 340 ISTR=4,NARG MODARG(ISTR)=0 340 CONTINUE RETURN ENDIF * Return status code. IF(NARG.GE.4)THEN CALL DLCSTF(ICL,OPT,NCOPT) CALL STRBUF('STORE',IAUX,OPT,NCOPT,IFAIL1) ARG(4)=REAL(IAUX) MODARG(4)=1 IF(IFAIL1.NE.0)PRINT *,' !!!!!! DLCCAL WARNING :'// - ' Error storing the status for INTERPOLATE_TRACK.' ENDIF * Set the modes of the arguments. MODARG(5)=2 MODARG(6)=2 MODARG(7)=2 MODARG(8)=2 MODARG(9)=2 *** Avalanche. ELSEIF(IPROC.EQ.-525)THEN IF(NARG.LT.1.OR.NARG.GT.2.OR. - (NARG.GE.1.AND.ARGREF(1,1).GE.2).OR. - (NARG.GE.2.AND.ARGREF(2,1).GE.2))THEN PRINT *,' !!!!!! DLCCAL WARNING : Incorrect set of'// - ' arguments for RND_MULTIPLICATION; not executed.' RETURN ENDIF * Call the routine. CALL DLCMCT(NETOT,NITOT) * Clear the return space. DO 60 I=1,NARG CALL ALGREU(NINT(ARG(I)),MODARG(I),ARGREF(I,1)) 60 CONTINUE * Return the results. IF(NARG.GE.1)THEN ARG(1)=REAL(NETOT) MODARG(1)=2 ENDIF IF(NARG.GE.2)THEN ARG(2)=REAL(NITOT) MODARG(2)=2 ENDIF *** Velocity vector for electrons. ELSEIF(IPROC.EQ.-526)THEN IF(NARG.LT.6.OR.NARG.GT.7.OR. - MODARG(1).NE.2.OR.MODARG(2).NE.2.OR.MODARG(3).NE.2.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))THEN PRINT *,' !!!!!! DLCCAL WARNING : Incorrect set of'// - ' arguments for ELECTRON_VELOCITY; not executed.' RETURN * Make sure there are drift velocities. ELSEIF(.NOT.GASOK(1))THEN PRINT *,' !!!!!! DLCCAL WARNING : The drift velocity'// - ' for electrons is not defined ; not executed.' RETURN ENDIF * Clear the return space. 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)) * Evaluate the velocity. CALL DLCVEL(DBLE(ARG(1)),DBLE(ARG(2)),DBLE(ARG(3)), - F0,-1.0,1,ILOC) * Return the arguments. ARG(4)=REAL(F0(1)) ARG(5)=REAL(F0(2)) ARG(6)=REAL(F0(3)) MODARG(4)=2 MODARG(5)=2 MODARG(6)=2 IF(NARG.GE.7)THEN IF(ILOC.EQ.-10)THEN CALL STRBUF('STORE',IAUX, - 'Unknown potential',17,IFAIL1) ELSEIF(ILOC.EQ.-5)THEN CALL STRBUF('STORE',IAUX, - 'In a material',13,IFAIL1) ELSEIF(ILOC.EQ.-6)THEN CALL STRBUF('STORE',IAUX, - 'Outside mesh',12,IFAIL1) ELSEIF(ILOC.LT.0)THEN CALL STRBUF('STORE',IAUX, - 'Outside plane',13,IFAIL1) ELSEIF(ILOC.EQ.0)THEN CALL STRBUF('STORE',IAUX, - 'Normal',6,IFAIL1) ELSEIF(ILOC.LE.NWIRE)THEN CALL STRBUF('STORE',IAUX,'In an '// - WIRTYP(ILOC)//' wire',12,IFAIL1) ELSE CALL STRBUF('STORE',IAUX,'Unknown',7,IFAIL1) ENDIF ARG(7)=REAL(IAUX) MODARG(7)=1 IF(IFAIL1.NE.0)PRINT *,' !!!!!! DLCCAL WARNING : '// - 'Error storing a string for ELECTRON_VELOCITY.' ENDIF *** Velocity vector for ions. ELSEIF(IPROC.EQ.-527)THEN IF(NARG.LT.6.OR.NARG.GT.7.OR. - MODARG(1).NE.2.OR.MODARG(2).NE.2.OR.MODARG(3).NE.2.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))THEN PRINT *,' !!!!!! DLCCAL WARNING : Incorrect set of'// - ' arguments for ION_VELOCITY; not executed.' RETURN * Make sure there are drift velocities. ELSEIF(.NOT.GASOK(2))THEN PRINT *,' !!!!!! DLCCAL WARNING : The drift velocity'// - ' for ions is not defined ; not executed.' RETURN ENDIF * Clear the return space. 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)) * Evaluate the velocity. CALL DLCVEL(DBLE(ARG(1)),DBLE(ARG(2)),DBLE(ARG(3)), - F0,+1.0,2,ILOC) * Return the arguments. ARG(4)=REAL(F0(1)) ARG(5)=REAL(F0(2)) ARG(6)=REAL(F0(3)) MODARG(4)=2 MODARG(5)=2 MODARG(6)=2 IF(NARG.GE.7)THEN IF(ILOC.EQ.-10)THEN CALL STRBUF('STORE',IAUX, - 'Unknown potential',17,IFAIL1) ELSEIF(ILOC.EQ.-5)THEN CALL STRBUF('STORE',IAUX, - 'In a material',13,IFAIL1) ELSEIF(ILOC.EQ.-6)THEN CALL STRBUF('STORE',IAUX, - 'Outside mesh',12,IFAIL1) ELSEIF(ILOC.LT.0)THEN CALL STRBUF('STORE',IAUX, - 'Outside plane',13,IFAIL1) ELSEIF(ILOC.EQ.0)THEN CALL STRBUF('STORE',IAUX, - 'Normal',6,IFAIL1) ELSEIF(ILOC.LE.NWIRE)THEN CALL STRBUF('STORE',IAUX,'In an '// - WIRTYP(ILOC)//' wire',12,IFAIL1) ELSE CALL STRBUF('STORE',IAUX,'Unknown',7,IFAIL1) ENDIF ARG(7)=REAL(IAUX) MODARG(7)=1 IF(IFAIL1.NE.0)PRINT *,' !!!!!! DLCCAL WARNING : '// - 'Error storing a string for ION_VELOCITY.' ENDIF *** Print the current drift line. ELSEIF(IPROC.EQ.-528)THEN * Check arguments. IF(NARG.NE.0)PRINT *,' !!!!!! DLCCAL WARNING :'// - ' PRINT_DRIFT_LINE takes no arguments ; arguments'// - ' ignored.' * Print a header. WRITE(LUNOUT,'('' CURRENT DRIFT LINE: ''/)') IF(IPTYPE.EQ.1)THEN WRITE(LUNOUT,'('' Particle: electron'')') ELSEIF(IPTYPE.EQ.2)THEN WRITE(LUNOUT,'('' Particle: ion'')') ELSE WRITE(LUNOUT,'('' Particle: not set'')') ENDIF CALL OUTFMT(QPCHAR,2,AUX1,NC1,'LEFT') WRITE(LUNOUT,'('' Charge: '',A)') AUX1(1:NC1) IF(IPTECH.EQ.1)THEN WRITE(LUNOUT,'('' Technique: Runge Kutta Fehlberg'')') ELSEIF(IPTECH.EQ.2)THEN WRITE(LUNOUT,'('' Technique: Monte Carlo'')') ELSEIF(IPTECH.EQ.3)THEN WRITE(LUNOUT,'('' Technique: vacuum drift'')') ELSE WRITE(LUNOUT,'('' Technique: not set'')') ENDIF CALL DLCSTF(ISTAT,OPT,NCOPT) WRITE(LUNOUT,'('' Status: '',A)') OPT(1:NCOPT) CALL OUTFMT(REAL(NU),2,AUX1,NC1,'LEFT') WRITE(LUNOUT,'('' Steps: '',A)') AUX1(1:NC1) * Print also the path, if non-zero. IF(NU.GT.0.AND.POLAR)THEN WRITE(LUNOUT,'(/'' Path:''/ - 16X,''r'',14X,''phi'',16X,''z'',13X,''time''/ - 13X,''[cm]'',8X,''[degrees]'', - 13X,''[cm]'',7X,''[microsec]''/)') ELSEIF(NU.GT.0)THEN WRITE(LUNOUT,'(/'' Path:''/ - 16X,''x'',16X,''y'',16X,''z'',13X,''time''/ - 13X,''[cm]'',13X,''[cm]'', - 13X,''[cm]'',7X,''[microsec]''/)') ENDIF DO 100 I=1,NU IF(POLAR)THEN CALL CF2RTP(XU(I),YU(I),XPOS1,YPOS1,1) ELSE XPOS1=XU(I) YPOS1=YU(I) ENDIF CALL OUTFMT(REAL(XPOS1),2,AUX1,NC1,'RIGHT') CALL OUTFMT(REAL(YPOS1),2,AUX2,NC2,'RIGHT') CALL OUTFMT(REAL(ZU(I)),2,AUX3,NC3,'RIGHT') CALL OUTFMT(REAL(TU(I)),2,AUX4,NC4,'RIGHT') WRITE(LUNOUT,'(4(2X,A15))') AUX1,AUX2,AUX3,AUX4 100 CONTINUE *** Unknown drift line operation. ELSE PRINT *,' !!!!!! DLCCAL WARNING : Unknown procedure code'// - ' received; nothing done.' IFAIL=1 RETURN ENDIF *** Seems to have worked. IFAIL=0 END +DECK,DLCFMP. SUBROUTINE DLCFMP(XX0,YY0,ZZ0,XX1,YY1,ZZ1,ILOC,Q,ITYPE) *----------------------------------------------------------------------- * DLCFMP - Terminates drift line calculation by making a last step * to the boundary of the mesh or the drift medium. * VARIABLES : (XX0,YY0,ZZ0): Last point in drift medium. * (XX1,YY1,ZZ1): Estimated step, outside drift medium. * (X0,Y0,Z0) : Final point just inside medium * (X1,Y1,Z1) : Final point just outside medium * FF0 : Drift velocity at (XX0,YY0,ZZ0) * F0 : Drift velocity at (X0,Y0,Z0) * (Last changed on 3/10/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,DRIFTLINE. +SEQ,CELLDATA. +SEQ,PRINTPLOT. INTEGER NBISEC PARAMETER(NBISEC=20) INTEGER ILOC,ITYPE,ILOC0,ILOC1,ILOCM,ILOCS,I,ILOCVF,IFAIL,IVOL REAL Q,EX,EY,EZ,ETOT,VOLT,EOVERM DOUBLE PRECISION XX0,YY0,ZZ0,XX1,YY1,ZZ1,X0,Y0,Z0,X1,Y1,Z1, - XM,YM,ZM,POS(3),FF0(3),F0(3),ACC(3),SPEED,ACCEL,STEP, - XOLD,YOLD,ZOLD COMMON /VFUCOM/ EOVERM,ILOCVF *** Identify this routine if requested. IF(LIDENT)PRINT *,' /// ROUTINE DLCFMP ///' *** Ensure there is a previous stored step. IF(NU.LE.0)THEN PRINT *,' ###### DLCFMP ERROR : Called at first step;'// - ' program bug, please report.' ISTAT=-3 RETURN ENDIF *** Check we may still add points. IF(NU.GE.MXLIST)THEN ISTAT=-2 IF(LDEBUG)PRINT *,' ++++++ DLCFMP DEBUG : Last point'// - ' not added because MXLIST is reached.' RETURN ENDIF *** Ensure we got an appropriate location code. IF(ILOC.NE.-5.AND.ILOC.NE.-6)THEN PRINT *,' ###### DLCFMP ERROR : Called for location'// - ' code ',ILOC,'; program bug, please report.' ISTAT=-3 RETURN ENDIF *** Initialise the bisection loop. X0=XX0 Y0=YY0 Z0=ZZ0 X1=XX1 Y1=YY1 Z1=ZZ1 CALL EFIELD(REAL(X0),REAL(Y0),REAL(Z0),EX,EY,EZ,ETOT,VOLT,0, - ILOC0) CALL EFIELD(REAL(X1),REAL(Y1),REAL(Z1),EX,EY,EZ,ETOT,VOLT,0, - ILOC1) IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCFMP DEBUG : Starting'', - '' from (x,y,z)='',3E15.8,'' loc='',I5/34X, - '' to (x,y,z)='',3E15.8,'' loc='',I5)') X0,Y0,Z0,ILOC0, - X1,Y1,Z1,ILOC1 IF(ILOC0.NE.0.OR.ILOC1.EQ.0)THEN IF(LDEBUG)PRINT *,' ++++++ DLCFMP DEBUG : Called but'// - ' ILOC=',ILOC0,ILOC1,' returning ISTAT=-3.' ISTAT=-3 RETURN ENDIF *** Perform some bisections. ILOCS=ILOC1 DO 10 I=1,NBISEC * Quit bisection when interval becomes too small. IF(ABS(X1-X0).LE.1D-6*(ABS(X0)+ABS(X1)).AND. - ABS(Y1-Y0).LE.1D-6*(ABS(Y0)+ABS(Y1)).AND. - ABS(Z1-Z0).LE.1D-6*(ABS(Z0)+ABS(Z1)))THEN IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCFMP DEBUG :'', - '' Bisection ended at loop '',I5,'' (interval'', - '' too small).'')') I GOTO 20 ENDIF * Middle point. XM=0.5*(X0+X1) YM=0.5*(Y0+Y1) ZM=0.5*(Z0+Z1) * Evaluate field. CALL EFIELD(REAL(XM),REAL(YM),REAL(ZM),EX,EY,EZ,ETOT,VOLT,0, - ILOCM) IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCFMP DEBUG : Bisection'', - '' at (x,y,z)='',3E15.8,'' loc='',I5)') XM,YM,ZM,ILOCM * Shift limits of the bisection. IF(ILOCM.EQ.0)THEN X0=XM Y0=YM Z0=ZM ELSE X1=XM Y1=YM Z1=ZM ILOCS=ILOCM ENDIF 10 CONTINUE * Maximum number of iterations reached. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCFMP DEBUG :'', - '' Bisection ended at loop '',I5,'' (maximum number'', - '' of iterations).'')') NBISEC *** Calculate the drift velocity over the last step. 20 CONTINUE ** Normal drift, not in vacuum. IF(ITYPE.EQ.1.OR.ITYPE.EQ.2)THEN * Compute drift velocity at begin and end of the step. CALL DLCVEL(XX0,YY0,ZZ0,FF0,Q,ITYPE,ILOC0) CALL DLCVEL(X0,Y0,Z0,F0,Q,ITYPE,ILOC1) * Average if both are in a free area. IF(ILOC0.EQ.0.AND.ILOC1.EQ.0)THEN SPEED=SQRT((FF0(1)+F0(1))**2+(FF0(2)+F0(2))**2+ - (FF0(3)+F0(3))**2)/4 * Or approximate with the last step only. ELSEIF(ILOC0.EQ.0)THEN SPEED=SQRT(FF0(1)**2+FF0(2)**2+FF0(3)**2) PRINT *,' ------ DLCFMP MESSAGE : Unable to compute'// - ' mean drift speed at last step; approximated.' * At least one should be OK. ELSE PRINT *,' !!!!!! DLCFMP WARNING : Unable to compute'// - ' drift speed at last step; aborted.' ISTAT=-3 RETURN ENDIF ** Vacuum drift. ELSE * If there are already steps, estimate speed from the last step. IF(NU.GT.1)THEN IF(TU(NU)-TU(NU-1).GT.0)THEN FF0(1)=(XU(NU)-XU(NU-1))/(TU(NU)-TU(NU-1)) FF0(2)=(YU(NU)-YU(NU-1))/(TU(NU)-TU(NU-1)) FF0(3)=(ZU(NU)-ZU(NU-1))/(TU(NU)-TU(NU-1)) ELSE PRINT *,' !!!!!! DLCFMP WARNING : Drift speed'// - ' over previous step is 0; aborted.' ISTAT=-3 RETURN ENDIF * Otherwise set speed to 0. ELSE FF0(1)=0 FF0(2)=0 FF0(3)=0 ENDIF * Use speed and location to compute the acceleration. POS(1)=XX0 POS(2)=YY0 POS(3)=ZZ0 ILOCVF=0 CALL DLCVFU(0.0D0,POS,FF0,ACC) IF(ILOCVF.NE.0)THEN PRINT *,' !!!!!! DLCFMP WARNING : Unable to compute'// - ' acceleration over last step; aborted.' ISTAT=-3 RETURN ENDIF * Estimate from these what the average speed for the last step is. SPEED=SQRT(FF0(1)**2+FF0(2)**2+FF0(3)**2) ACCEL=SQRT(ACC(1)**2+ACC(2)**2+ACC(3)**2) STEP=SQRT((X0-XX0)**2+(Y0-YY0)**2+(Z0-ZZ0)**2) SPEED=SPEED/2+SQRT(SPEED**2+2*ACCEL*STEP)/2 ENDIF ** Check velocity. IF(SPEED.LE.0)THEN PRINT *,' !!!!!! DLCFMP WARNING : Drift line not properly'// - ' terminated because of zero drift field.' ISTAT=-3 RETURN ENDIF *** Add the last step to the boundary. NU=NU+1 XU(NU)=X0 YU(NU)=Y0 ZU(NU)=Z0 *** And fill in the time for the last step. TU(NU)=TU(NU-1)+SQRT((XU(NU)-XU(NU-1))**2+ - (YU(NU)-YU(NU-1))**2+(ZU(NU)-ZU(NU-1))**2)/SPEED *** Assign the status code. CALL DLCSOL(X0,Y0,Z0,IVOL) IF(IVOL.LE.0)THEN ISTAT=ILOCS ELSE ISTAT=2*MXWIRE+IVOL ENDIF *** Check that the particle is still inside the drift area, clip if not. IF(XU(NU).LT.DDXMIN)ISTAT=ISTAT1 IF(XU(NU).GT.DDXMAX)ISTAT=ISTAT2 IF(YU(NU).LT.DDYMIN)ISTAT=ISTAT3 IF(YU(NU).GT.DDYMAX)ISTAT=ISTAT4 IF(ZU(NU).LT.DDZMIN)ISTAT=ISTAT5 IF(ZU(NU).GT.DDZMAX)ISTAT=ISTAT6 IF(ISTAT.NE.ILOCS)THEN XOLD=XU(NU) YOLD=YU(NU) ZOLD=ZU(NU) CALL CLIP3D(XU(NU-1), YU(NU-1), ZU(NU-1), - XU(NU), YU(NU), ZU(NU), - DBLE(DDXMIN),DBLE(DDYMIN),DBLE(DDZMIN), - DBLE(DDXMAX),DBLE(DDYMAX),DBLE(DDZMAX),IFAIL) IF(IFAIL.NE.0.OR.(XOLD.EQ.XU(NU-1).AND. - YOLD.EQ.YU(NU-1).AND.ZOLD.EQ.ZU(NU-1)))THEN NU=NU-1 ELSE TU(NU)=TU(NU-1)+(TU(NU)-TU(NU-1))*SQRT( - ((XU(NU)-XU(NU-1))**2+(YU(NU)-YU(NU-1))**2+ - (ZU(NU)-ZU(NU-1))**2)/ - ((XOLD-XU(NU-1))**2+(YOLD-YU(NU-1))**2+ - (ZOLD-ZU(NU-1))**2)) ENDIF IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCFMP DEBUG : Area'', - '' left or solid entered, ISTAT='',I5)') ISTAT ENDIF *** Debugging output. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCFMP DEBUG : NU='',I5/ - 5X,''Old step: '',3E12.5,'' location: '',I10/ - 5X,''End : '',3E12.5,'' location: '',I10/ - 5X,''New step: '',3E12.5,'' status: '',I10/ - 5X,''Speed : '',E12.5)') - NU,XX0,YY0,ZZ0,ILOC0,XX1,YY1,ZZ1,ILOC1,X0,Y0,Z0,ISTAT,SPEED END +DECK,DLCISW. SUBROUTINE DLCISW(ISTAT,ISW) *----------------------------------------------------------------------- * DLCISW - Returns the sense wire number of the electrode that was hit * by a drift line with status code ISTAT. * (Last changed on 4/ 9/99.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,FIELDMAP. +SEQ,SOLIDS. INTEGER ISTAT,ISW,I *** Drift line left the area. IF(ISTAT.EQ.-1)THEN ISW=0 * Too many steps. ELSEIF(ISTAT.EQ.-2)THEN ISW=0 * Calculations failed. ELSEIF(ISTAT.EQ.-3)THEN ISW=0 * Plane hit (for backwards compatibility). ELSEIF(ISTAT.EQ.-4)THEN ISW=0 * Left drift medium. ELSEIF(ISTAT.EQ.-5)THEN ISW=0 * Left the mesh. ELSEIF(ISTAT.EQ.-6)THEN ISW=0 * Plane or tube hit (replaces the ISTAT = -4 code). ELSEIF(ISTAT.EQ.-11)THEN ISW=INDPLA(1) ELSEIF(ISTAT.EQ.-12)THEN ISW=INDPLA(2) ELSEIF(ISTAT.EQ.-13)THEN ISW=INDPLA(3) ELSEIF(ISTAT.EQ.-14)THEN ISW=INDPLA(4) ELSEIF(ISTAT.EQ.-15)THEN ISW=INDPLA(5) * Original copy of a wire. ELSEIF(ISTAT.GT.0.AND.ISTAT.LE.MXWIRE)THEN ISW=INDSW(ISTAT) * Wire replicas. ELSEIF(ISTAT.GT.MXWIRE.AND.ISTAT.LE.2*MXWIRE)THEN ISW=0 * Solids. ELSEIF(ISTAT.GT.2*MXWIRE.AND.ISTAT.LE.2*MXWIRE+MXSOLI)THEN ISW=0 DO 10 I=1,NWMAP IF(EWSTYP(I).EQ.SOLTYP(ISTAT-2*MXWIRE))ISW=INDEWS(I) 10 CONTINUE * Invalid status code. ELSE ISW=0 ENDIF END +DECK,DLCMIN. SUBROUTINE DLCMIN(XW,YW,X0,Y0,X1,Y1,DIST2,IFLAG) *----------------------------------------------------------------------- * DLCMIN - Minimizes the distance between a line segment and a point. * VARIABLES: (XW,YW) : Coordinates of the 'point' * (X0,Y0)-(X1,Y1): The track. * IFLAG : -1 minimum is located before (X0,Y0), * 0 " " " at an interior point, * +1 " " " behind (X1,Y1). * XINP0,XINP1 : Inner products. *----------------------------------------------------------------------- implicit none DOUBLE PRECISION X0,Y0,X1,Y1,DIST2,STEP2,XINP0,XINP1,XW,YW INTEGER IFLAG *** 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 DIST2=MAX(0.0D0,(X1-XW)**2+(Y1-YW)**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 END +DECK,DLCPAR. SUBROUTINE DLCPAR *----------------------------------------------------------------------- * DLCPAR - Routine taking care of drift line integration parameters. * VARIABLES : * (Last changed on 19/ 5/99.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,DRIFTLINE. +SEQ,PRINTPLOT. +SEQ,PARAMETERS. CHARACTER*40 STRDF2,STRMC INTEGER INPCMP,NMCR,INEXT,MXSTR,I,INPTYP,NWORD,IFAIL1,NINORR REAL TMCR,DMCR,EPSR,RDF2R,RTRAPR,STMAXR,EQTTRR,EQTASR,EQTCLR EXTERNAL INPCMP *** Get the number of words on the line. CALL INPNUM(NWORD) *** If there is only one argument. IF(NWORD.EQ.1)THEN IF(MDF2.EQ.0)THEN STRDF2='No special treatment' ELSEIF(MDF2.EQ.1)THEN STRDF2='Integrate distance/velocity' ELSEIF(MDF2.EQ.2)THEN STRDF2='Integrate distance/central velocity' ELSEIF(MDF2.EQ.3)THEN STRDF2='Take longitudinal size.' ELSEIF(MDF2.EQ.4)THEN STRDF2='Take largest cloud axis.' ELSE STRDF2='# Method not known #' ENDIF IF(MCMETH.EQ.0)THEN STRMC='Take constant time steps.' ELSEIF(MCMETH.EQ.1)THEN STRMC='Take constant distance steps.' ELSEIF(MCMETH.EQ.2)THEN STRMC='Simulate collisions.' ELSE STRMC='# Method not known #' ENDIF WRITE(LUNOUT,'(/ - '' RUNGE-KUTTA DRIFT LINE INTEGRATION PARAMETERS:''/ - '' Absolute accuracy for drift line'', - '' integration: '',E15.8,'' [cm]'')') EPSDIF IF(LSTMAX)THEN WRITE(LUNOUT,'( - '' Maximum length of an integration step:'', - '' '',E15.8,'' [cm]'')') STMAX ELSE WRITE(LUNOUT,'( - '' Maximum length of an integration'', - '' step: Unlimited'')') ENDIF WRITE(LUNOUT,'(/ - '' MONTE CARLO DRIFT LINE INTEGRATION PARAMETERS:''/ - '' Monte Carlo integration method: '', - '' '',A/ - '' Time interval between steps for'', - '' MC integration: '',E15.8,'' [microsec]''/ - '' Space interval between steps for'', - '' MC integration: '',E15.8,'' [cm]''/ - '' Number of collisions to be averaged'', - '' over: '',I15// - '' DRIFT LINE TERMINATION PARAMETERS:''/ - '' Distance at which particles are caught'', - '' (TRAP-RADIUS): '',F15.3,'' [wire radii]''/ - '' Skip the capture check for'', - '' repelling wires: '',L15/ - '' Abandon drift line at sharp kinks'', - '' (REJECT-KINKS): '',L15)') - STRMC,TMC,DMC,NMC,RTRAP,LREPSK,LKINK WRITE(LUNOUT,'(/ - '' DRIFT LINE INTERPOLATION PARAMETERS:''/ - '' Interpolation order: '', - '' '',I15/ - '' Compute (T) or abandon (F) if'', - '' interpolation fails: '',L15)') NINORD,LINCAL WRITE(LUNOUT,'(/ - '' DIFFUSION, AVALANCHE AND ATTACHMENT SUMMING'', - '' PARAMETERS:''/ - '' Cloud projection method for electrons'', - '' hitting a wire: '',A/ - '' Switch L+T diffusion integration method:'', - '' '',F15.3,'' [wire radii]''/ - '' Maximum stack depth for the diffusion'', - '' integration: '',I15/ - '' Maximum stack depth for the Townsend'', - '' integration: '',I15/ - '' Maximum stack depth for the attachment'', - '' integration: '',I15/ - '' Relative accuracy tolerance diffusion'', - '' integration: '',E15.8/ - '' Relative accuracy tolerance Townsend'', - '' integration: '',E15.8/ - '' Relative accuracy tolerance attachment'', - '' integration: '',E15.8/ - '' Compute multiplication over projected'', - '' drift line: '',L15)') - STRDF2,RDF2,MXDIFS,MXTWNS,MXATTS,EPSDFI,EPSTWI,EPSATI, - LAVPRO WRITE(LUNOUT,'(/ - '' ISOCHRONE PARAMETERS:''/ - '' Maximum relative distance to connect'', - '' isochrone parts: '',E15.8/ - '' Curves considered circular up to an'', - '' aspect ratio of: '',E15.8/ - '' Circular curves closed up to a relative'', - '' distance of: '',E15.8/ - '' Sort points on isochrones: '', - '' '',L15/ - '' Avoid crossings between isochrones and'', - '' drift lines: '',L15/ - '' Mark (T) or Draw (F) isochrones: '', - '' '',L15)') - EQTTHR,EQTASP,EQTCLS,LEQSRT,LEQCRS,LEQMRK ELSE INEXT=2 DO 10 I=2,NWORD IF(I.LT.INEXT)GOTO 10 * Diffusion stack size. IF(INPCMP(I,'DIFF#USION-ST#ACK-#DEPTH').NE.0)THEN IF(I+1.GT.NWORD.OR.INPTYP(I+1).NE.1)THEN CALL INPMSG(I,'Should have an integer as arg.') INEXT=I+1 ELSE CALL INPCHK(I+1,1,IFAIL1) CALL INPRDI(I+1,MXSTR,MXSTCK) IF(MXSTR.GE.1.AND.MXSTR.LE.MXSTCK)THEN MXDIFS=MXSTR ELSE CALL INPMSG(I+1, - 'Value not in range 1 -> MXSTCK') ENDIF INEXT=I+2 ENDIF * Townsend stack size. ELSEIF(INPCMP(I,'TOWN#SEND-ST#ACK-#DEPTH').NE.0)THEN IF(I+1.GT.NWORD.OR.INPTYP(I+1).NE.1)THEN CALL INPMSG(I,'Should have an integer as arg.') INEXT=I+1 ELSE CALL INPCHK(I+1,1,IFAIL1) CALL INPRDI(I+1,MXSTR,MXSTCK) IF(MXSTR.GE.1.AND.MXSTR.LE.MXSTCK)THEN MXTWNS=MXSTR ELSE CALL INPMSG(I+1, - 'Value not in range 1 -> MXSTCK') ENDIF INEXT=I+2 ENDIF * Attachment stack size. ELSEIF(INPCMP(I,'ATT#ACHMENT-ST#ACK-#DEPTH').NE.0)THEN IF(I+1.GT.NWORD.OR.INPTYP(I+1).NE.1)THEN CALL INPMSG(I,'Should have an integer as arg.') INEXT=I+1 ELSE CALL INPCHK(I+1,1,IFAIL1) CALL INPRDI(I+1,MXSTR,MXSTCK) IF(MXSTR.GE.1.AND.MXSTR.LE.MXSTCK)THEN MXATTS=MXSTR ELSE CALL INPMSG(I+1, - 'Value not in range 1 -> MXSTCK') ENDIF INEXT=I+2 ENDIF * Diffusion accuracy. ELSEIF(INPCMP(I,'DIFF#USION-ACC#URACY').NE.0)THEN IF(I+1.GT.NWORD.OR.INPTYP(I+1).LE.0)THEN CALL INPMSG(I,'Should have a numeric argument') INEXT=I+1 ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,EPSR,1.0E-3) IF(EPSR.GT.0.0.AND.IFAIL1.EQ.0)THEN EPSDFI=EPSR ELSE CALL INPMSG(I+1, - 'This value must be positive. ') ENDIF INEXT=I+2 ENDIF * Townsend accuracy. ELSEIF(INPCMP(I,'TOWN#SEND-ACC#URACY').NE.0)THEN IF(I+1.GT.NWORD.OR.INPTYP(I+1).LE.0)THEN CALL INPMSG(I,'Should have a numeric argument') INEXT=I+1 ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,EPSR,1.0E-3) IF(EPSR.GT.0.0.AND.IFAIL1.EQ.0)THEN EPSTWI=EPSR ELSE CALL INPMSG(I+1, - 'This value must be positive. ') ENDIF INEXT=I+2 ENDIF * Attachment accuracy. ELSEIF(INPCMP(I,'ATT#ACHMENT-ACC#URACY').NE.0)THEN IF(I+1.GT.NWORD.OR.INPTYP(I+1).LE.0)THEN CALL INPMSG(I,'Should have a numeric argument') INEXT=I+1 ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,EPSR,1.0E-3) IF(EPSR.GT.0.AND.IFAIL1.EQ.0)THEN EPSATI=EPSR ELSE CALL INPMSG(I+1, - 'This value must be positive.') ENDIF INEXT=I+2 ENDIF * Projected or true drift line. ELSEIF(INPCMP(I,'PROJ#ECTED-#PATH-#INTEGRATION').NE.0)THEN LAVPRO=.TRUE. ELSEIF(INPCMP(I,'TRUE-PATH-#INTEGRATION').NE.0)THEN LAVPRO=.FALSE. * Integration accuracy. ELSEIF(INPCMP(I,'INT#EGRATION-ACC#URACY')+ - INPCMP(I,'EPS#ILON').NE.0)THEN IF(I+1.GT.NWORD.OR.INPTYP(I+1).LE.0)THEN CALL INPMSG(I,'Should have a numeric argument') INEXT=I+1 ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,EPSR,1.0E-6) IF(IFAIL1.EQ.0.AND.EPSR.LE.0.0)THEN CALL INPMSG(I+1, - 'Integration accuracy not > 0. ') ELSEIF(IFAIL1.EQ.0)THEN EPSDIF=EPSR ENDIF INEXT=I+2 ENDIF * MC integration time interval. ELSEIF(INPCMP(I,'M#ONTE-C#ARLO-T#IME-#INTERVAL')+ - INPCMP(I,'MC-T#IME-#INTERVAL').NE.0)THEN IF(I+1.GT.NWORD.OR.INPTYP(I+1).LE.0)THEN CALL INPMSG(I,'Should have a numeric argument') INEXT=I+1 ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,TMCR,0.001) IF(IFAIL1.EQ.0.AND.TMCR.LE.0.0)THEN CALL INPMSG(I+1, - 'Integration interval not > 0. ') ELSEIF(IFAIL1.EQ.0)THEN TMC=TMCR ENDIF MCMETH=0 INEXT=I+2 ENDIF * MC integration distance interval. ELSEIF(INPCMP(I,'M#ONTE-C#ARLO-D#ISTANCE-#INTERVAL')+ - INPCMP(I,'M#ONTE-C#ARLO-SP#ACE-#INTERVAL')+ - INPCMP(I,'M#ONTE-C#ARLO-SP#ATIAL-#INTERVAL')+ - INPCMP(I,'MC-D#ISTANCE-#INTERVAL')+ - INPCMP(I,'MC-SP#ACE-#INTERVAL')+ - INPCMP(I,'MC-SP#ATIAL-#INTERVAL').NE.0)THEN IF(I+1.GT.NWORD.OR.INPTYP(I+1).LE.0)THEN CALL INPMSG(I,'Should have a numeric argument') INEXT=I+1 ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,DMCR,0.1) IF(IFAIL1.EQ.0.AND.DMCR.LE.0.0)THEN CALL INPMSG(I+1, - 'Integration interval not > 0. ') ELSEIF(IFAIL1.EQ.0)THEN DMC=DMCR ENDIF MCMETH=1 INEXT=I+2 ENDIF * MC integration step averaging. ELSEIF(INPCMP(I,'M#ONTE-C#ARLO-ST#EPS')+ - INPCMP(I,'M#ONTE-C#ARLO-C#OLLISIONS')+ - INPCMP(I,'MC-ST#EPS')+ - INPCMP(I,'MC-C#OLLISIONS').NE.0)THEN IF(I+1.GT.NWORD.OR.INPTYP(I+1).LE.0)THEN CALL INPMSG(I,'Should have an integer arg.') INEXT=I+1 ELSE CALL INPCHK(I+1,1,IFAIL1) CALL INPRDI(I+1,NMCR,100) IF(IFAIL1.EQ.0.AND.NMCR.LE.0)THEN CALL INPMSG(I+1, - 'Number of collisions not > 0.') ELSEIF(IFAIL1.EQ.0)THEN NMC=NMCR ENDIF MCMETH=2 INEXT=I+2 ENDIF * Trap radius. ELSEIF(INPCMP(I,'TRAP-#RADIUS').NE.0)THEN IF(I+1.GT.NWORD.OR.INPTYP(I+1).LE.0)THEN CALL INPMSG(I,'Should have a numeric argument') INEXT=I+1 ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,RTRAPR,0.0) IF(IFAIL1.EQ.0.AND.RTRAPR.LE.0.0)THEN CALL INPMSG(I+1, - 'Number of wire radii not > 0. ') ELSEIF(IFAIL1.EQ.0)THEN RTRAP=RTRAPR ENDIF INEXT=I+2 ENDIF * Maximum step length. ELSEIF(INPCMP(I,'MAX#IMUM-ST#EP-#LENGTH').NE.0)THEN IF(I+1.GT.NWORD.OR.INPTYP(I+1).LE.0)THEN CALL INPMSG(I,'Should have a numeric argument') INEXT=I+1 ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,STMAXR,0.0) IF(IFAIL1.EQ.0.AND.STMAXR.LE.0.0)THEN CALL INPMSG(I+1, - 'Step length must be > 0.') ELSEIF(IFAIL1.EQ.0)THEN STMAX=STMAXR LSTMAX=.TRUE. ENDIF INEXT=I+2 ENDIF ELSEIF(INPCMP(I,'NOMAX#IMUM-ST#EP-#LENGTH').NE.0)THEN LSTMAX=.FALSE. * Check of repelling wires. ELSEIF(INPCMP(I,'CH#ECK-ALL-#WIRES').NE.0)THEN LREPSK=.FALSE. ELSEIF(INPCMP(I,'CH#ECK-ATT#RACTING-#WIRES').NE.0)THEN LREPSK=.TRUE. * Check for kinks. ELSEIF(INPCMP(I,'CH#ECK-K#INKS')+ - INPCMP(I,'K#INKS-CH#ECK')+ - INPCMP(I,'REJ#ECT-K#INKS')+ - INPCMP(I,'K#INKS-REJ#ECT').NE.0)THEN LKINK=.TRUE. ELSEIF(INPCMP(I,'NOCH#ECK-K#INKS')+ - INPCMP(I,'NOK#INKS-CH#ECK')+ - INPCMP(I,'NOREJ#ECT-K#INKS')+ - INPCMP(I,'NOK#INKS-REJ#ECT').NE.0)THEN LKINK=.FALSE. * Interpolation order. ELSEIF(INPCMP(I,'INT#ERPOLATION-ORD#ER').NE.0)THEN IF(I+1.GT.NWORD)THEN CALL INPMSG(I,'Should have an argument') ELSEIF(INPCMP(I+1,'LIN#EAR').NE.0)THEN NINORD=1 INEXT=I+2 ELSEIF(INPCMP(I+1,'QUAD#RATIC')+ - INPCMP(I+1,'PARA#BOLIC').NE.0)THEN NINORD=2 INEXT=I+2 ELSEIF(INPCMP(I+1,'CUB#IC').NE.0)THEN NINORD=3 INEXT=I+2 ELSEIF(INPTYP(I+1).NE.1)THEN CALL INPMSG(I,'Should have 1 integer argument') ELSE CALL INPCHK(I+1,1,IFAIL1) CALL INPRDI(I+1,NINORR,NINORD) IF(IFAIL1.EQ.0.AND.(NINORR.LT.1.OR. - NINORR.GT.10))THEN CALL INPMSG(I+1,'Not in the range [1,10].') ELSEIF(IFAIL1.EQ.0)THEN NINORD=NINORR ENDIF INEXT=I+2 ENDIF * Compute or abandon drift lines which can't be interpolated. ELSEIF(INPCMP(I,'ABANDON-#IF-#INTERPOLATION-#FAILS').NE. - 0)THEN LINCAL=.FALSE. ELSEIF(INPCMP(I,'COMP#UTE-#IF-#INTERPOLATION-#FAILS').NE. - 0)THEN LINCAL=.TRUE. * Switch integration method. ELSEIF(INPCMP(I,'CL#OUD-PROJ#ECTION-DIST#ANCE').NE.0)THEN IF(I+1.GT.NWORD.OR.INPTYP(I+1).LE.0)THEN CALL INPMSG(I,'Should have a numeric argument') INEXT=I+1 ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,RDF2R,2.0) IF(IFAIL1.EQ.0.AND.RDF2R.LT.0.0)THEN CALL INPMSG(I+1, - 'Number of wire radii not > 0. ') ELSEIF(IFAIL1.EQ.0)THEN RDF2=RDF2R ENDIF INEXT=I+2 ENDIF * Cloud projection method. ELSEIF(INPCMP(I,'CL#OUD-PROJ#ECTION-METH#OD').NE.0)THEN INEXT=I+2 IF(I+1.GT.NWORD.OR.INPTYP(I+1).LE.0)THEN CALL INPMSG(I,'Should have a numeric argument.') INEXT=I+1 ELSEIF(INPCMP(I+1,'NO-#PROJECTION').NE.0)THEN MDF2=0 ELSEIF(INPCMP(I+1,'INT#EGRATION').NE.0)THEN MDF2=1 ELSEIF(INPCMP(I+1,'CENT#RAL-#VELOCITY-#INTEGRATION') - .NE.0)THEN MDF2=2 ELSEIF(INPCMP(I+1,'LONG#ITUDINAL-#DIMENSION').NE.0)THEN MDF2=3 ELSEIF(INPCMP(I+1,'LARG#EST-#DIMENSION').NE.0)THEN MDF2=4 ELSE CALL INPMSG(I+1,'Not a known method.') ENDIF * Isochrone connection threshold. ELSEIF(INPCMP(I,'ISO#CHRONE-CONN#ECTION-#THRESHOLD').NE. - 0)THEN IF(I+1.GT.NWORD)THEN CALL INPMSG(I,'Should have a numeric argument.') INEXT=I+1 ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,EQTTRR,EQTTHR) IF(EQTTRR.LE.0.0.OR.EQTTRR.GT.1)THEN CALL INPMSG(I+1, - 'Threshold not between 0 and 1.') ELSEIF(IFAIL1.EQ.0)THEN EQTTHR=EQTTRR ENDIF INEXT=I+2 ENDIF ELSEIF(INPCMP(I,'NOISO#CHRONE-CONN#ECTION-#THRESHOLD').NE. - 0)THEN EQTTHR=1.0 * Isochrone aspect ratio switch. ELSEIF(INPCMP(I,'ISO#CHRONE-ASP#ECT-#RATIO-#SWITCH').NE. - 0)THEN IF(I+1.GT.NWORD)THEN CALL INPMSG(I,'Should have a numeric argument.') INEXT=I+1 ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,EQTASR,EQTASP) IF(EQTASR.LE.0.0)THEN CALL INPMSG(I+1, - 'Ratio should be larger than 0.') ELSEIF(IFAIL1.EQ.0)THEN EQTASP=EQTASR ENDIF INEXT=I+2 ENDIF * Isochrone loop closing threshold. ELSEIF(INPCMP(I,'ISO#CHRONE-LOOP-#THRESHOLD').NE.0)THEN IF(I+1.GT.NWORD)THEN CALL INPMSG(I,'Should have a numeric argument.') INEXT=I+1 ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,EQTCLR,EQTCLS) IF(EQTCLR.LE.0.0.OR.EQTCLR.GT.1)THEN CALL INPMSG(I+1, - 'Threshold not between 0 and 1.') ELSEIF(IFAIL1.EQ.0)THEN EQTCLS=EQTCLR ENDIF INEXT=I+2 ENDIF * Sort isochrones or not. ELSEIF(INPCMP(I,'SORT-ISO#CHRONES').NE.0)THEN LEQSRT=.TRUE. ELSEIF(INPCMP(I,'NOSORT-ISO#CHRONES').NE.0)THEN LEQSRT=.FALSE. * Check crossings between isochrones and drift lines. ELSEIF(INPCMP(I,'CH#ECK-ISO#CHRONE-#CROSSINGS').NE.0)THEN LEQCRS=.TRUE. ELSEIF(INPCMP(I,'NOCH#ECK-ISO#CHRONE-#CROSSINGS').NE.0)THEN LEQCRS=.FALSE. * Mark isochrones. ELSEIF(INPCMP(I,'MARK-ISO#CHRONES').NE.0)THEN LEQMRK=.TRUE. ELSEIF(INPCMP(I,'DRAW-ISO#CHRONES').NE.0)THEN LEQMRK=.FALSE. * Anything else. ELSE CALL INPMSG(I,'Not a valid keyword; ignored. ') ENDIF 10 CONTINUE ENDIF CALL INPERR END +DECK,DLCPLA. SUBROUTINE DLCPLA(IPLANE,Q,ITYPE) *----------------------------------------------------------------------- * DLCPLA - Terminates drift line calculation by making a last linear * step to the boundary identified by IPLANE. * VARIABLES : F3 : Drift-velocity at the one but last point, * assumed to be constant over the step. * SPEED : Magitude of F3. * (Last changed on 10/11/90.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,DRIFTLINE. +SEQ,CELLDATA. +SEQ,PRINTPLOT. INTEGER ILOC,IFAIL,ITYPE,IPLANE REAL Q DOUBLE PRECISION F3(3),SPEED *** Identify this routine if requested. IF(LIDENT)PRINT *,' /// ROUTINE DLCPLA ///' *** Calculate the drift velocity at the current last point. CALL DLCVEL(XU(NU),YU(NU),ZU(NU),F3,Q,ITYPE,ILOC) SPEED=SQRT(F3(1)**2+F3(2)**2) IF(SPEED.EQ.0.0D0.OR.ILOC.NE.0)THEN PRINT *,' !!!!!! DLCPLA WARNING : Drift line not properly'// - ' terminated because of zero drift field.' ISTAT=-3 IF(ILOC.NE.0)ISTAT=ILOC RETURN ENDIF *** Check we may still add points. IF(NU.GE.MXLIST)THEN ISTAT=-2 IF(LDEBUG)PRINT *,' ++++++ DLCPLA DEBUG : Last point'// - ' not added because MXLIST is reached.' RETURN ENDIF *** Debugging output. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCPLA DEBUG : Entered'', - '' at NU='',I3,'' for IPLANE='',I2,''.'')') NU,IPLANE *** Check the components. IF((IPLANE.EQ.1.AND.F3(1).GE.0.0D0).OR. - (IPLANE.EQ.2.AND.F3(1).LE.0.0D0).OR. - (IPLANE.EQ.3.AND.F3(2).GE.0.0D0).OR. - (IPLANE.EQ.4.AND.F3(2).LE.0.0D0))THEN PRINT *,' !!!!!! DLCPLA WARNING : The particle moves away'// - ' from the boundary it is supposed to hit ; abandoned.' ISTAT=-3 RETURN ENDIF *** Add the last step towards the plane. NU=NU+1 IF(IPLANE.EQ.1)THEN XU(NU)=DBLE(DDXMIN) YU(NU)=YU(NU-1)+(F3(2)/F3(1))*(XU(NU)-XU(NU-1)) ZU(NU)=ZU(NU-1)+(F3(3)/F3(1))*(XU(NU)-XU(NU-1)) ISTAT=ISTAT1 ELSEIF(IPLANE.EQ.2)THEN XU(NU)=DBLE(DDXMAX) YU(NU)=YU(NU-1)+(F3(2)/F3(1))*(XU(NU)-XU(NU-1)) ZU(NU)=ZU(NU-1)+(F3(3)/F3(1))*(XU(NU)-XU(NU-1)) ISTAT=ISTAT2 ELSEIF(IPLANE.EQ.3)THEN YU(NU)=DBLE(DDYMIN) XU(NU)=XU(NU-1)+(F3(1)/F3(2))*(YU(NU)-YU(NU-1)) ZU(NU)=ZU(NU-1)+(F3(3)/F3(2))*(YU(NU)-YU(NU-1)) ISTAT=ISTAT3 ELSEIF(IPLANE.EQ.4)THEN YU(NU)=DBLE(DDYMAX) XU(NU)=XU(NU-1)+(F3(1)/F3(2))*(YU(NU)-YU(NU-1)) ZU(NU)=ZU(NU-1)+(F3(3)/F3(2))*(YU(NU)-YU(NU-1)) ISTAT=ISTAT4 ELSE PRINT *,' ###### DLCPLA ERROR : Unrecognised IPLANE=', - IPLANE,' received (program bug - please report).' ISTAT=-3 ENDIF *** Clip the step to the full set of boundaries. CALL CLIP2D(XU(NU-1),YU(NU-1),XU(NU),YU(NU), - DBLE(DDXMIN),DBLE(DDYMIN),DBLE(DDXMAX),DBLE(DDYMAX),IFAIL) *** And fill in the time for the last step. TU(NU)=TU(NU-1)+SQRT((XU(NU)-XU(NU-1))**2+ - (YU(NU)-YU(NU-1))**2)/SPEED END +DECK,DLCPLT. SUBROUTINE DLCPLT *----------------------------------------------------------------------- * DLCPLT - Plots a drift line. * (Last changed on 7/11/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,DRIFTLINE. *** Set the proper type of particle for plotting, first electron. IF(IPTYPE.EQ.1)THEN CALL GRATTS('E-DRIFT-LINE','POLYLINE') * And ion. ELSEIF(IPTYPE.EQ.2)THEN CALL GRATTS('ION-DRIFT-LINE','POLYLINE') * Anything else. ELSE PRINT *,' !!!!!! DLCPLT WARNING : Current drift line'// - ' is of unknown type; selecting FUNCTION-1'// - ' representation.' CALL GRATTS('FUNCTION-1','POLYLINE') ENDIF *** Plot the drift line. CALL PLAGPL(NU,XU,YU,ZU) END +DECK,DLCSOL. SUBROUTINE DLCSOL(XPOS,YPOS,ZPOS,IVOL) *----------------------------------------------------------------------- * PLASOL - Determines whether a point is located inside a solid. * (Last changed on 31/ 8/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CONSTANTS. +SEQ,SOLIDS. +SEQ,PRINTPLOT. DOUBLE PRECISION XPOS,YPOS,ZPOS INTEGER IVOL,I LOGICAL INSIDE *** Initial volume setting (not inside a solid). IVOL=0 *** Loop over the solids. DO 10 I=1,NSOLID * Cylinders. IF(ISOLTP(I).EQ.1)THEN CALL PLACYI(I,XPOS,YPOS,ZPOS,INSIDE) IF(INSIDE)THEN IVOL=I RETURN ENDIF * Holes. ELSEIF(ISOLTP(I).EQ.2)THEN CALL PLACHI(I,XPOS,YPOS,ZPOS,INSIDE) IF(INSIDE)THEN IVOL=I RETURN ENDIF * Boxes. ELSEIF(ISOLTP(I).EQ.3)THEN CALL PLABXI(I,XPOS,YPOS,ZPOS,INSIDE) IF(INSIDE)THEN IVOL=I RETURN ENDIF * Spheres. ELSEIF(ISOLTP(I).EQ.4)THEN CALL PLASPI(I,XPOS,YPOS,ZPOS,INSIDE) IF(INSIDE)THEN IVOL=I RETURN ENDIF * Other things. ELSE PRINT *,' !!!!!! DLCSOL WARNING : Found a solid of'// - ' unknown type; ignored.' ENDIF 10 CONTINUE END +DECK,DLCSTA. SUBROUTINE DLCSTA(Q,ITYPE) *----------------------------------------------------------------------- * DLCSTA - Subroutine returning the status of a drift line. It checks * that the particle is not inside or near a wire or a plane. * If that is the case however, the drift line is finished and * a non-zero status code is returned. * VARIABLES : XLAST,YLAST: Last particle position in basic cell. * SHIFT : .TRUE. if we are not in the basic period. * XW,YW : Wire position moved to the particle period. * DIST2 : Minimum distance of particle during the * last step to a given wire squared. * (Last changed on 17/11/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,PARAMETERS. +SEQ,DRIFTLINE. +SEQ,PRINTPLOT. DOUBLE PRECISION XOLD,YOLD,ZOLD,XW,YW,XDIST,YDIST,DIST2,DISMIN, - RAUX1,RAUX2 REAL DCXMIN,DCXMAX,DCYMIN,DCYMAX,Q INTEGER IFAIL,I,IOUT,IFLAG,ITYPE LOGICAL SHIFT *** Identify the routine if requested. IF(LIDENT)PRINT *,' /// ROUTINE DLCSTA ///' *** Preset ISTAT to 0 (normal situation). ISTAT=0 *** Handle the case NU=1 seperately. IF(NU.EQ.1)THEN * Define the area to be used for checks later on, when NU > 1 DDXMIN=DXMIN DDYMIN=DYMIN DDZMIN=DZMIN DDXMAX=DXMAX DDYMAX=DYMAX DDZMAX=DZMAX * Check position with respect to the planes. ISTAT1=-1 ISTAT2=-1 ISTAT3=-1 ISTAT4=-1 ISTAT5=-1 ISTAT6=-1 IF(YNPLAN(1))THEN DCXMIN=COPLAN(1) IF(PERX)THEN DCXMIN=DCXMIN+AINT((REAL(XU(1))-COPLAN(1))/SX)*SX IF(XU(1).LT.COPLAN(1))DCXMIN=DCXMIN-SX ENDIF IF(DCXMIN.GT.DXMIN)ISTAT1=-11 DDXMIN=MAX(DCXMIN,DXMIN) ENDIF IF(YNPLAN(2))THEN DCXMAX=COPLAN(2) IF(PERX)THEN DCXMAX=DCXMAX+AINT((REAL(XU(1))-COPLAN(2))/SX)*SX IF(XU(1).GT.COPLAN(2))DCXMAX=DCXMAX+SX ENDIF IF(DCXMAX.LT.DXMAX)ISTAT2=-12 DDXMAX=MIN(DCXMAX,DXMAX) ENDIF IF(YNPLAN(3))THEN DCYMIN=COPLAN(3) IF(PERY)THEN DCYMIN=DCYMIN+AINT((REAL(YU(1))-COPLAN(3))/SY)*SY IF(YU(1).LT.COPLAN(3))DCYMIN=DCYMIN-SY ENDIF IF(DCYMIN.GT.DYMIN)ISTAT3=-13 DDYMIN=MAX(DCYMIN,DYMIN) ENDIF IF(YNPLAN(4))THEN DCYMAX=COPLAN(4) IF(PERY)THEN DCYMAX=DCYMAX+AINT((REAL(YU(1))-COPLAN(4))/SY)*SY IF(YU(1).GT.COPLAN(4))DCYMAX=DCYMAX+SY ENDIF IF(DCYMAX.LT.DYMAX)ISTAT4=-14 DDYMAX=MIN(DCYMAX,DYMAX) ENDIF * Check position with respect to the tube, if it exists. IF(TUBE)THEN CALL INTUBE(REAL(XU(1)),REAL(YU(1)),COTUBE,NTUBE,IOUT) IF(IOUT.EQ.1)THEN ISTAT=-15 ELSEIF(IOUT.NE.0)THEN ISTAT=-3 ENDIF ENDIF * particle outside the drift area right at the start, IF(XU(1).LT.DDXMIN)ISTAT=ISTAT1 IF(XU(1).GT.DDXMAX)ISTAT=ISTAT2 IF(YU(1).LT.DDYMIN)ISTAT=ISTAT3 IF(YU(1).GT.DDYMAX)ISTAT=ISTAT4 IF(ZU(1).LT.DDZMIN)ISTAT=ISTAT5 IF(ZU(1).GT.DDZMAX)ISTAT=ISTAT6 IF(ISTAT.NE.0)RETURN ** Check whether the particle is already very near a wire. ITARG=0 DISMIN=0 DO 10 I=1,NWIRE * Skip wires with the wrong charge. IF(LREPSK.AND.Q*E(I).GT.0.0)GOTO 10 * First find the wire closest to where we are now. XW=DBLE(X(I)) YW=DBLE(Y(I)) SHIFT=.FALSE. IF(PERX)THEN XDIST=XU(1)-DBLE(X(I)) XW=DBLE(X(I))+SX*ANINT(XDIST/SX) IF(ABS(XDIST).GT.SX/2)SHIFT=.TRUE. ENDIF IF(PERY)THEN YDIST=YU(1)-DBLE(Y(I)) YW=DBLE(Y(I))+SY*ANINT(YDIST/SY) IF(ABS(YDIST).GT.SY/2)SHIFT=.TRUE. ENDIF DIST2=(XU(NU)-XW)**2+(YU(NU)-YW)**2 * Keep track of which one is closest. IF(ITARG.EQ.0.OR.DIST2.LT.DISMIN)THEN DISMIN=DIST2 IF(SHIFT)THEN ITARG=I+MXWIRE ELSE ITARG=I ENDIF XTARG=XW YTARG=YW DTARG=D(I) ENDIF * Next find out if we have to make some last step or not. IF(DIST2.LE.(0.5*RTRAP*D(I))**2)THEN IF(DIST2.LE.(0.5*D(I))**2)THEN IF(LDEBUG)PRINT *,' ++++++ DLCSTA DEBUG :', - ' Particle is inside the wire at NU=1.' ISTAT=I ELSE IF(LDEBUG)PRINT *,' ++++++ DLCSTA DEBUG :', - ' DLCWIR entered from DLCSTA at NU=1.' CALL DLCWIR(0,Q,ITYPE) ENDIF RETURN ENDIF 10 CONTINUE RETURN ENDIF *** Next handle the case of NU > 1, check crossing of a whole period. IF((PERX.AND.ABS(XU(NU)-XU(NU-1)).GE.SX).OR. - (PERY.AND.ABS(YU(NU)-YU(NU-1)).GE.SY))THEN PRINT *,' ###### DLCSTA ERROR : Particle crossed more'// - ' than one period ; calculation is abandoned.' ISTAT=-3 RETURN ENDIF *** Check that the particle is still inside the drift area, clip if not. IF(XU(NU).LT.DDXMIN)ISTAT=ISTAT1 IF(XU(NU).GT.DDXMAX)ISTAT=ISTAT2 IF(YU(NU).LT.DDYMIN)ISTAT=ISTAT3 IF(YU(NU).GT.DDYMAX)ISTAT=ISTAT4 IF(ZU(NU).LT.DDZMIN)ISTAT=ISTAT5 IF(ZU(NU).GT.DDZMAX)ISTAT=ISTAT6 IF(ISTAT.NE.0)THEN XOLD=XU(NU) YOLD=YU(NU) ZOLD=ZU(NU) CALL CLIP3D(XU(NU-1), YU(NU-1), ZU(NU-1), - XU(NU), YU(NU), ZU(NU), - DBLE(DDXMIN),DBLE(DDYMIN),DBLE(DDZMIN), - DBLE(DDXMAX),DBLE(DDYMAX),DBLE(DDZMAX),IFAIL) IF(IFAIL.NE.0.OR.(XOLD.EQ.XU(NU-1).AND. - YOLD.EQ.YU(NU-1).AND.ZOLD.EQ.ZU(NU-1)))THEN NU=NU-1 ELSE TU(NU)=TU(NU-1)+(TU(NU)-TU(NU-1))*SQRT( - ((XU(NU)-XU(NU-1))**2+(YU(NU)-YU(NU-1))**2+ - (ZU(NU)-ZU(NU-1))**2)/ - ((XOLD-XU(NU-1))**2+(YOLD-YU(NU-1))**2+ - (ZOLD-ZU(NU-1))**2)) ENDIF RETURN ENDIF *** Left the tube ? IF(TUBE)THEN CALL INTUBE(REAL(XU(NU)),REAL(YU(NU)),COTUBE,NTUBE,IOUT) IF(IOUT.NE.0)THEN RAUX1=SQRT(XU(NU-1)**2+YU(NU-1)**2) RAUX2=SQRT(XU(NU)**2+YU(NU)**2) IF(RAUX1.NE.RAUX2.AND.NTUBE.EQ.0)THEN XU(NU)=XU(NU-1)+(XU(NU)-XU(NU-1))* - (COTUBE-RAUX1)/(RAUX2-RAUX1) YU(NU)=YU(NU-1)+(YU(NU)-YU(NU-1))* - (COTUBE-RAUX1)/(RAUX2-RAUX1) ZU(NU)=ZU(NU-1)+(ZU(NU)-ZU(NU-1))* - (COTUBE-RAUX1)/(RAUX2-RAUX1) TU(NU)=TU(NU-1)+(TU(NU)-TU(NU-1))* - (COTUBE-RAUX1)/(RAUX2-RAUX1) ELSE NU=NU-1 ENDIF ISTAT=-15 IF(LDEBUG)PRINT *,' ++++++ DLCSTA DEBUG : Particle'// - ' is leaving the tube.' RETURN ENDIF ENDIF *** Find out whether a wire has been hit and remember the nearest wire. ITARG=0 DISMIN=0 DO 20 I=1,NWIRE * Skip wires with the wrong charge. IF(LREPSK.AND.Q*E(I).GT.0.0)GOTO 20 * First find the wire closest to where we are now. XW=X(I) YW=Y(I) SHIFT=.FALSE. IF(PERX)THEN XDIST=(XU(NU)+XU(NU-1))/2-XW XW=XW+SX*ANINT(XDIST/SX) IF(ABS(XDIST).GT.SX/2)SHIFT=.TRUE. ENDIF IF(PERY)THEN YDIST=(YU(NU)+YU(NU-1))/2-YW YW=YW+SY*ANINT(YDIST/SY) IF(ABS(YDIST).GT.SY/2)SHIFT=.TRUE. ENDIF IF(XW+0.5*D(I).LT.DDXMIN.OR.XW-0.5*D(I).GT.DDXMAX.OR. - YW+0.5*D(I).LT.DDYMIN.OR.YW-0.5*D(I).GT.DDYMAX)GOTO 20 * Compute distance of the last point to the (replica of) wire I. CALL DLCMIN(XW,YW,XU(NU-1),YU(NU-1),XU(NU),YU(NU),DIST2,IFLAG) * Keep track of which one is closest. IF(ITARG.EQ.0.OR.DIST2.LT.DISMIN)THEN DISMIN=DIST2 IF(SHIFT)THEN ITARG=I+MXWIRE ELSE ITARG=I ENDIF XTARG=XW YTARG=YW DTARG=D(I) ENDIF * Next find out if we have to make some last step or not. IF(DIST2.LE.(0.5*RTRAP*D(I))**2)THEN IF(LDEBUG)PRINT *,' ++++++ DLCSTA DEBUG : Particle hit', - ' wire ',I,' at ',XW,YW IF(LDEBUG)PRINT *,' distance from', - ' centre is ',SQRT(DIST2),', wire radius is ',D(I)/2.0 IF(DIST2.LE.(0.5*D(I))**2.OR.IFLAG.NE.+1)NU=NU-1 IF(LDEBUG)PRINT *,' ++++++ DLCSTA DEBUG : DLCWIR', - ' entered from DLCSTA because the wire is hit.' CALL DLCWIR(0,Q,ITYPE) RETURN ENDIF 20 CONTINUE END +DECK,DLCSTF. SUBROUTINE DLCSTF(ISTAT,STATUS,NCSTAT) *----------------------------------------------------------------------- * DLCSTF - Formats the status code into a string. * (Last changed on 23/ 2/01.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,SOLIDS. CHARACTER*(*) STATUS CHARACTER*80 AUX INTEGER ISTAT,NCSTAT,NC * Drift line left the area. IF(ISTAT.EQ.-1)THEN STATUS='Left the drift area' NCSTAT=19 * Too many curvature. ELSEIF(ISTAT.EQ.-2)THEN STATUS='Too many steps' NCSTAT=14 * Calculations failed. ELSEIF(ISTAT.EQ.-3)THEN STATUS='Calculations abandoned' NCSTAT=22 * Plane hit. ELSEIF(ISTAT.EQ.-4)THEN STATUS='Hit a plane' NCSTAT=11 * Left drift medium. ELSEIF(ISTAT.EQ.-5)THEN STATUS='Left the drift medium' NCSTAT=21 * Left the mesh. ELSEIF(ISTAT.EQ.-6)THEN STATUS='Left the mesh' NCSTAT=13 * Plane hit. ELSEIF(ISTAT.EQ.-11)THEN IF(POLAR)THEN STATUS='Hit the minimum r plane' ELSE STATUS='Hit the minimum x plane' ENDIF NCSTAT=23 ELSEIF(ISTAT.EQ.-12)THEN IF(POLAR)THEN STATUS='Hit the maximum r plane' ELSE STATUS='Hit the maximum x plane' ENDIF NCSTAT=23 ELSEIF(ISTAT.EQ.-13)THEN IF(POLAR)THEN STATUS='Hit the minimum phi plane' NCSTAT=25 ELSE STATUS='Hit the minimum y plane' NCSTAT=23 ENDIF ELSEIF(ISTAT.EQ.-14)THEN IF(POLAR)THEN STATUS='Hit the maximum phi plane' NCSTAT=25 ELSE STATUS='Hit the maximum y plane' NCSTAT=23 ENDIF ELSEIF(ISTAT.EQ.-15)THEN STATUS='Hit the tube' NCSTAT=12 ELSEIF(ISTAT.EQ.-20)THEN STATUS='Started from a line or an edge' NCSTAT=30 * Original copy of a wire. ELSEIF(ISTAT.GT.0.AND.ISTAT.LE.MXWIRE)THEN CALL OUTFMT(REAL(ISTAT),2,AUX,NC,'LEFT') STATUS='Hit '//WIRTYP(ISTAT)//' wire '//AUX(1:NC) NCSTAT=11+NC * Wire replicas. ELSEIF(ISTAT.GT.MXWIRE.AND.ISTAT.LE.2*MXWIRE)THEN CALL OUTFMT(REAL(ISTAT)-MXWIRE,2,AUX,NC,'LEFT') STATUS='Hit a replica of '//WIRTYP(ISTAT-MXWIRE)// - ' wire '//AUX(1:NC) NCSTAT=24+NC * Solids. ELSEIF(ISTAT.GT.2*MXWIRE.AND.ISTAT.LE.2*MXWIRE+MXSOLI)THEN CALL OUTFMT(REAL(ISTAT)-2*MXWIRE,2,AUX,NC,'LEFT') STATUS='Hit '//SOLTYP(ISTAT-2*MXWIRE)// - ' solid '//AUX(1:NC) NCSTAT=12+NC * Invalid status code. ELSE STATUS='Unknown' NCSTAT=7 ENDIF *** Ensure that the string length does not become invalid. IF(NCSTAT.GT.LEN(STATUS))THEN PRINT *,' !!!!!! DLCSTF WARNING : Status string has been'// - ' truncated.' NCSTAT=LEN(STATUS) ENDIF END +DECK,DLCVEL. SUBROUTINE DLCVEL(XPOS,YPOS,ZPOS,VD,Q,ITYPE,ILOC) *----------------------------------------------------------------------- * DLCVEL - Subroutine returning the (vector) speed of an electron or * ion, taking the electric (and magnetic) field into account. * VARIABLES : V : Speed of the electron or ion. * Q : Charge of the particle in units of E. * ITYPE : Particle type (1=e- ; else=ion). * PMU : Mobility of the electron/ion in the gas. * (Last changed on 5/ 3/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,GASDATA. +SEQ,BFIELD. +SEQ,CELLDATA. DOUBLE PRECISION XPOS,YPOS,ZPOS,VD(3),UB(3),UEXB(3),ENORM REAL EX,EY,EZ,BX,BY,BZ,VOLT,GASVEL,GASVT1,GASVT2,GASMOB,GASLOR, - PMU,ETOT,BTOT,ANGLE,Q,VE,VB,VEXB INTEGER ITYPE,ILOC EXTERNAL GASVEL,GASMOB,GASLOR *** Deal the with special case of vacuum drift - drift velocity unknown. IF(ITYPE.EQ.0)THEN PRINT *,' !!!!!! DLCVEL WARNING : Drift velocity for'// - ' vacuum drift requested ; not defined, set to 0.' VD(1)=0.0D0 VD(2)=0.0D0 VD(3)=0.0D0 ILOC=-11 RETURN ENDIF *** Calculate the electric field. CALL EFIELD(REAL(XPOS),REAL(YPOS),REAL(ZPOS), - EX,EY,EZ,ETOT,VOLT,0,ILOC) IF(POLAR)THEN EZ=0 ETOT=SQRT(EX**2+EY**2) ENDIF IF(ILOC.NE.0.OR.ETOT.LE.0)THEN VD(1)=0.0D0 VD(2)=0.0D0 VD(3)=0.0D0 RETURN ENDIF *** Electron without B field. IF(ITYPE.EQ.1.AND..NOT.MAGOK)THEN * Compute the mobility. IF(POLAR)THEN PMU=GASVEL(EX/EXP(REAL(XPOS)),EY/EXP(REAL(XPOS)),EZ, - BX,BY,BZ)/(EXP(XPOS)*ETOT) ELSE PMU=GASVEL(EX,EY,EZ,BX,BY,BZ)/ETOT ENDIF * Store the velocity vector. VD(1)=Q*PMU*EX VD(2)=Q*PMU*EY VD(3)=Q*PMU*EZ *** Electron with B field and velocity vector. ELSEIF(ITYPE.EQ.1.AND.GASOK(1).AND.GASOK(9).AND.GASOK(10))THEN * Compute the B field. CALL BFIELD(REAL(XPOS),REAL(YPOS),REAL(ZPOS),BX,BY,BZ,BTOT) * Compute unit vectors along Btrans and ExB. UEXB(1)=EY*BZ-EZ*BY UEXB(2)=EZ*BX-EX*BZ UEXB(3)=EX*BY-EY*BX ENORM=SQRT(UEXB(1)**2+UEXB(2)**2+UEXB(3)**2) IF(ENORM.GT.0)THEN UEXB(1)=UEXB(1)/ENORM UEXB(2)=UEXB(2)/ENORM UEXB(3)=UEXB(3)/ENORM ELSE UEXB(1)=EX/ETOT UEXB(2)=EY/ETOT UEXB(3)=EZ/ETOT ENDIF UB(1)=UEXB(2)*EZ-UEXB(3)*EY UB(2)=UEXB(3)*EX-UEXB(1)*EZ UB(3)=UEXB(1)*EY-UEXB(2)*EX ENORM=SQRT(UB(1)**2+UB(2)**2+UB(3)**2) IF(ENORM.GT.0)THEN UB(1)=UB(1)/ENORM UB(2)=UB(2)/ENORM UB(3)=UB(3)/ENORM ELSE UB(1)=EX/ETOT UB(2)=EY/ETOT UB(3)=EZ/ETOT ENDIF * Compute the velocities in all directions. IF(POLAR)THEN VE=GASVEL(EX/EXP(REAL(XPOS)),EY/EXP(REAL(XPOS)),EZ, - BX,BY,BZ)/EXP(XPOS) VB=GASVT1(EX/EXP(REAL(XPOS)),EY/EXP(REAL(XPOS)),EZ, - BX,BY,BZ)/EXP(XPOS) VEXB=GASVT2(EX/EXP(REAL(XPOS)),EY/EXP(REAL(XPOS)),EZ, - BX,BY,BZ)/EXP(XPOS) ELSE VE=GASVEL(EX,EY,EZ,BX,BY,BZ) VB=GASVT1(EX,EY,EZ,BX,BY,BZ) VEXB=GASVT2(EX,EY,EZ,BX,BY,BZ) ENDIF * Return the velocity vector. VD(1)=Q*(VE*EX/ETOT+VB*UB(1)+VEXB*UEXB(1)) VD(2)=Q*(VE*EY/ETOT+VB*UB(2)+VEXB*UEXB(2)) VD(3)=Q*(VE*EZ/ETOT+VB*UB(3)+VEXB*UEXB(3)) *** Electron with B field and Lorentz angle. ELSEIF(ITYPE.EQ.1.AND.GASOK(7))THEN * Compute the B field. CALL BFIELD(REAL(XPOS),REAL(YPOS),REAL(ZPOS),BX,BY,BZ,BTOT) * Compute a unit vector along ExB. UEXB(1)=EY*BZ-EZ*BY UEXB(2)=EZ*BX-EX*BZ UEXB(3)=EX*BY-EY*BX ENORM=SQRT(UEXB(1)**2+UEXB(2)**2+UEXB(3)**2) IF(ENORM.GT.0)THEN UEXB(1)=UEXB(1)/ENORM UEXB(2)=UEXB(2)/ENORM UEXB(3)=UEXB(3)/ENORM ELSE UEXB(1)=EX/ETOT UEXB(2)=EY/ETOT UEXB(3)=EZ/ETOT ENDIF * Compute the velocities and the angle. IF(POLAR)THEN VE=GASVEL(EX/EXP(REAL(XPOS)),EY/EXP(REAL(XPOS)),EZ, - BX,BY,BZ)/EXP(XPOS) ANGLE=GASLOR(EX/EXP(REAL(XPOS)),EY/EXP(REAL(XPOS)),EZ, - BX,BY,BZ) ELSE VE=GASVEL(EX,EY,EZ,BX,BY,BZ) ANGLE=GASLOR(EX,EY,EZ,BX,BY,BZ) ENDIF * Return the velocity. VD(1)=Q*VE*(COS(ANGLE)*EX/ETOT+SIN(ANGLE)*UEXB(1)) VD(2)=Q*VE*(COS(ANGLE)*EY/ETOT+SIN(ANGLE)*UEXB(2)) VD(3)=Q*VE*(COS(ANGLE)*EZ/ETOT+SIN(ANGLE)*UEXB(3)) *** Electron with B field and nothing else known. ELSEIF(ITYPE.EQ.1)THEN * Compute the B field. CALL BFIELD(REAL(XPOS),REAL(YPOS),REAL(ZPOS),BX,BY,BZ,BTOT) * Compute the velocity. IF(POLAR)THEN PMU=GASVEL(EX/EXP(REAL(XPOS)),EY/EXP(REAL(XPOS)),EZ, - BX,BY,BZ)/EXP(XPOS) ELSE PMU=GASVEL(EX,EY,EZ,BX,BY,BZ)/ETOT ENDIF * Return a velocity. VD(1)=Q*PMU*(EX+PMU*(EY*BZ-EZ*BY)+ - BX*((BX*EX+BY*EY+BZ*EZ)*PMU**2))/(1+(PMU*BTOT)**2) VD(2)=Q*PMU*(EY+PMU*(EZ*BX-EX*BZ)+ - BY*((BX*EX+BY*EY+BZ*EZ)*PMU**2))/(1+(PMU*BTOT)**2) VD(3)=Q*PMU*(EZ+PMU*(EX*BY-EY*BX)+ - BZ*((BX*EX+BY*EY+BZ*EZ)*PMU**2))/(1+(PMU*BTOT)**2) *** Ion without B field. ELSEIF(ITYPE.EQ.2.AND..NOT.MAGOK)THEN * Compute the mobility. IF(POLAR)THEN PMU=GASMOB(EX/EXP(REAL(XPOS)),EY/EXP(REAL(XPOS)),EZ, - BX,BY,BZ)/EXP(2*XPOS) ELSE PMU=GASMOB(EX,EY,EZ,BX,BY,BZ) ENDIF * Store the velocity vector. VD(1)=Q*PMU*EX VD(2)=Q*PMU*EY VD(3)=Q*PMU*EZ *** Ion with B field. ELSEIF(ITYPE.EQ.2)THEN * Compute the B field. CALL BFIELD(REAL(XPOS),REAL(YPOS),REAL(ZPOS),BX,BY,BZ,BTOT) * Compute the velocity. IF(POLAR)THEN PMU=GASMOB(EX/EXP(REAL(XPOS)),EY/EXP(REAL(XPOS)),EZ, - BX,BY,BZ)/EXP(2*XPOS) ELSE PMU=GASMOB(EX,EY,EZ,BX,BY,BZ) ENDIF * Return a velocity. VD(1)=Q*PMU*(EX+PMU*(EY*BZ-EZ*BY)+ - BX*((BX*EX+BY*EY+BZ*EZ)*PMU**2))/(1+(PMU*BTOT)**2) VD(2)=Q*PMU*(EY+PMU*(EZ*BX-EX*BZ)+ - BY*((BX*EX+BY*EY+BZ*EZ)*PMU**2))/(1+(PMU*BTOT)**2) VD(3)=Q*PMU*(EZ+PMU*(EX*BY-EY*BX)+ - BZ*((BX*EX+BY*EY+BZ*EZ)*PMU**2))/(1+(PMU*BTOT)**2) *** Other cases. ELSE PRINT *,' !!!!!! DLCVEL WARNING : Unable to deal with the'// - ' particle type / field combination; returning 0.' VD(1)=0.0D0 VD(2)=0.0D0 VD(3)=0.0D0 RETURN ENDIF END +DECK,DLCWIR. SUBROUTINE DLCWIR(ISKIP,Q,ITYPE) *----------------------------------------------------------------------- * DLCWIR - Terminates drift line calculation by making some last steps * towards the surface of the wire on which it is supposed to * end. The precision is controlled in order to obtain a * good estimate of the total remaining drift-time. * VARIABLES : (X1,Y1) : First point of an integration segment. * (XM,YM) : Middle point of an integration segment. * (X2,Y2) : Last point of an integration segment. * F1, FM, F2 : Velocities at (X1,Y1), (XM,YM), (X2,Y2). * ONWIRE : .TRUE. if the last point is on the wire. * ISKIP : Skip searching for the nearest wire and * use (XTARG,YTARG) instead. * (Last changed on 5/ 2/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,DRIFTLINE. +SEQ,PRINTPLOT. INTEGER MXSPLT PARAMETER (MXSPLT=10) DOUBLE PRECISION F1(3),FM(3),F2(3),X1,XM,X2,Y1,YM,Y2, - Z1,ZM,Z2,T1,T2,DIST2,TCRUDE,XDIST,YDIST,DISMIN REAL Q,EX,EY,EZ,ETOT,VOLT,XWAUX,YWAUX INTEGER ITYPE,IFLAG,ILOC,ILOC1,ILOC2,ILOCM,I,ISKIP,ISPLIT,IWEND LOGICAL ONWIRE,SHIFT *** Identify the routine if requested. IF(LIDENT)PRINT *,' /// ROUTINE DLCWIR ///' IF(LDEBUG)PRINT *,' ++++++ DLCWIR DEBUG : ITARG=',ITARG, - ' (x,y)=',XTARG,YTARG,', d=',DTARG *** Step backwards until we have a point where the field is non-zero. 10 CONTINUE CALL EFIELD(REAL(XU(NU)),REAL(YU(NU)),REAL(ZU(NU)), - EX,EY,EZ,ETOT,VOLT,0,ILOC) IF(ILOC.NE.0.OR.ETOT.EQ.0)THEN IF(LDEBUG)PRINT *,' ++++++ DLCWIR DEBUG : Last point at', - ' NU=',NU,' is at zero field ; NU lowered by 1.' IF(NU.GT.1)THEN NU=NU-1 GOTO 10 ELSE PRINT *,' !!!!!! DLCWIR WARNING : Unable to find a', - ' point on the drift-line where E is not zero.' ISTAT=-3 ENDIF ENDIF *** Make sure space is left for the steps to come. IF(NU.GE.MXLIST)THEN IF(LDEBUG)PRINT *,' ++++++ DLCWIR DEBUG : No storage', - ' left ; stepping to the wire not performed.' ISTAT=-2 NU=MXLIST RETURN ENDIF *** Skip finding the wire if ISKIP=1. IF(ISKIP.EQ.1)THEN IF(LDEBUG)PRINT *,' ++++++ DLCWIR DEBUG : Wire search', - ' is skipped due to ISKIP=',ISKIP IF(ITARG.GT.MXWIRE)THEN IWEND=ITARG-MXWIRE ELSE IWEND=ITARG ENDIF GOTO 1000 ENDIF *** Find out whether the diagnosis about the target wire is correct. ITARG=0 DISMIN=0 IWEND=0 DO 20 I=1,NWIRE * First find the wire closest to where we are now. XWAUX=X(I) YWAUX=Y(I) SHIFT=.FALSE. IF(PERX)THEN XDIST=XU(NU)-DBLE(X(I)) IF(ABS(XDIST).GT.SX/2)SHIFT=.TRUE. XWAUX=X(I)+SX*ANINT(XDIST/SX) ENDIF IF(PERY)THEN YDIST=YU(NU)-DBLE(Y(I)) IF(ABS(YDIST).GT.SY/2)SHIFT=.TRUE. YWAUX=Y(I)+SY*ANINT(YDIST/SY) ENDIF DIST2=(XU(NU)-XWAUX)**2+(YU(NU)-YWAUX)**2 * Keep track of which one is closest. IF(ITARG.EQ.0.OR.DIST2.LT.DISMIN)THEN DISMIN=DIST2 XTARG=XWAUX YTARG=YWAUX DTARG=D(I) IWEND=I IF(SHIFT)THEN ITARG=I+MXWIRE ELSE ITARG=I ENDIF ENDIF 20 CONTINUE IF(IWEND.EQ.0)THEN PRINT *,' ###### DLCWIR ERROR : No target wire found'// - ' ; program bug - please report.' ISTAT=-3 ENDIF *** Cheat with the target wire to avoid getting into it. 1000 CONTINUE D(IWEND)=DTARG/2 ** Final stepping towards the wire starts. IF(LDEBUG)PRINT *,' ++++++ DLCWIR DEBUG : Stepping towards'// - ' the wire ',IWEND,' started at NU= ',NU X1=XU(NU) Y1=YU(NU) Z1=ZU(NU) T1=TU(NU) ** Make an estimate for a full step towards the wire. CALL DLCVEL(X1,Y1,Z1,F1,Q,ITYPE,ILOC1) IF(SQRT(F1(1)**2+F1(2)**2).LE.0.0)THEN IF(LDEBUG)PRINT *,' ++++++ DLCWIR DEBUG : Initial'// - ' drift-velocity zero; quit on ISTAT=-3.' ISTAT=-3 D(IWEND)=DTARG RETURN ENDIF * Estimate the time needed to reach the wire. TCRUDE=(SQRT((X1-XTARG)**2+(Y1-YTARG)**2)-DTARG/2.0)/ - SQRT(F1(1)**2+F1(2)**2) IF(LDEBUG)PRINT *,' ++++++ DLCWIR DEBUG : Estimated time'// - ' needed to reach the wire: ',TCRUDE * Special handling for small TCRUDE. IF(TCRUDE.LT.1.0E-6*TU(NU))THEN IF(LDEBUG)PRINT *,' ++++++ DLCWIR DEBUG : Small TCRUDE'// - ' exception handling; no further processing.' ISTAT=ITARG D(IWEND)=DTARG RETURN ENDIF *** Iteration starts here: set the number of integration divisions to 0. ISPLIT=0 100 CONTINUE * Estimate where the drift-line will end up after this time. X2=X1+F1(1)*TCRUDE Y2=Y1+F1(2)*TCRUDE Z2=Z1+F1(3)*TCRUDE * Set the flag for being in the wire to .FALSE. ONWIRE=.FALSE. ** Take action depending on where we end up, first moving away. CALL DLCMIN(XTARG,YTARG,X1,Y1,X2,Y2,DIST2,IFLAG) IF(IFLAG.EQ.-1)THEN IF(LDEBUG)PRINT *,' ++++++ DLCWIR DEBUG : Particle moves', - ' away from the wire ; quit on ISTAT=-3.' ISTAT=-3 D(IWEND)=DTARG RETURN * Next the case the wire has been crossed. ELSEIF(IFLAG.EQ.0.OR.DIST2.LE.(DTARG/2)**2)THEN X2=XTARG-0.5*DTARG*(XTARG-X1)/ - SQRT((X1-XTARG)**2+(Y1-YTARG)**2) Y2=YTARG-0.5*DTARG*(YTARG-Y1)/ - SQRT((X1-XTARG)**2+(Y1-YTARG)**2) TCRUDE=SQRT(((X2-X1)**2+(Y2-Y1)**2)/(F1(1)**2+F1(2)**2)) Z2=Z1+TCRUDE*F1(3) ONWIRE=.TRUE. ENDIF ** Calculate the drift-velocity at the end point. CALL DLCVEL(X2,Y2,Z2,F2,Q,ITYPE,ILOC2) ** Set a point halfway between 1 and 2 for an accuracy check. XM=0.5*(X1+X2) YM=0.5*(Y1+Y2) ZM=0.5*(Z1+Z2) CALL DLCVEL(XM,YM,ZM,FM,Q,ITYPE,ILOCM) ** Check the location codes. IF(ILOC1.NE.0.OR.ILOCM.NE.0.OR.ILOC2.NE.0)THEN IF(LDEBUG)PRINT *,' ++++++ DLCWIR DEBUG : ILOC position'// - ' codes cause ISTAT=-3 quit: ',ILOC1,ILOCM,ILOC2 ISTAT=-3 D(IWEND)=DTARG RETURN ENDIF * Check the non-zeroness of the velocities. IF(SQRT(F1(1)**2+F1(2)**2).LE.0.0.OR. - SQRT(FM(1)**2+FM(2)**2).LE.0.0.OR. - SQRT(F2(1)**2+F2(2)**2).LE.0.0)THEN IF(LDEBUG)PRINT *,' ++++++ DLCWIR DEBUG : Intermediate'// - ' drift-velocity zero; quit on ISTAT=-3.' ISTAT=-3 D(IWEND)=DTARG RETURN ENDIF ** Compare first and second order estimates. IF(ISPLIT.GE.MXSPLT.OR.SQRT((X2-X1)**2+(Y2-Y1)**2)* - ABS(1.0/SQRT(F1(1)**2+F1(2)**2)-2.0/SQRT(FM(1)**2+FM(2)**2)+ - 1.0/SQRT(F2(1)**2+F2(2)**2))/3.0.LT.1.0D-4*(1+ABS(T1)))THEN * Accurate enough: integrate the drift-time over this segment. T2=T1+SQRT((X2-X1)**2+(Y2-Y1)**2)* - (1.0/SQRT(F1(1)**2+F1(2)**2)+ - 4.0/SQRT(FM(1)**2+FM(2)**2)+ - 1.0/SQRT(F2(1)**2+F2(2)**2))/6.0 * Add to the drift-line if there is space left. IF(NU.GE.MXLIST)THEN IF(LDEBUG)PRINT *,' ++++++ DLCWIR DEBUG : No space'// - ' left for ; ISTAT=-2 return.' ISTAT=-2 NU=MXLIST RETURN ELSE NU=NU+1 XU(NU)=X2 YU(NU)=Y2 ZU(NU)=Z2 TU(NU)=T2 IF(LDEBUG)PRINT *,' ++++++ DLCWIR DEBUG : Adding'// - ' point ',NU,' at ',XU(NU),YU(NU),ZU(NU),TU(NU) IF(ONWIRE)THEN ISTAT=ITARG D(IWEND)=DTARG IF(LDEBUG)PRINT *,' ++++++ DLCWIR DEBUG :'// - ' This was the last step.' RETURN ENDIF IF(LDEBUG.AND.ISPLIT.GT.0)PRINT *,' ++++++ DLCWIR', - ' DEBUG : Adding at ISPLIT=',ISPLIT ENDIF * Proceed with the next step. X1=X2 Y1=Y2 Z1=Z2 T1=T2 ILOC1=ILOC2 F1(1)=F2(1) F1(2)=F2(2) F1(3)=F2(3) GOTO 100 ** Halve the step-size if the accuracy is insufficient. ELSE TCRUDE=TCRUDE/2 ISPLIT=ISPLIT+1 GOTO 100 ENDIF END +DECK,DLCATT. SUBROUTINE DLCATT(FACTOR) *----------------------------------------------------------------------- * DLCATT - Routine returning the attachment losses for the current * drift line. Uses either DLCAT11 for drift lines that have * been computed with RKF or DLCAT22 for MC drift lines. * integration. * VARIABLES : FACTOR : The attachment losses. * (Last changed on 17/ 9/99.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,DRIFTLINE. +SEQ,CELLDATA. +SEQ,PRINTPLOT. REAL FACTOR *** Projected integration ... IF(LAVPRO)THEN CALL DLCAT2(FACTOR) *** Integration over the true step length ... ELSE CALL DLCAT1(FACTOR) ENDIF END +DECK,DLCAT1. SUBROUTINE DLCAT1(FACTOR) *----------------------------------------------------------------------- * DLCAT1 - Routine returning the attachment losses for the current * drift line. The routine uses an adaptive Simpson style * integration. * VARIABLES : BETA. : Attachment coefficients (1,2 end; M middle) * BETINT : Integral of the attachment coefficient. * FACTOR : The attachment losses * (Last changed on 5/ 2/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,DRIFTLINE. +SEQ,CELLDATA. +SEQ,PRINTPLOT. REAL ATTVEC(MXLIST),BETA1,BETA2,BETAM,FACTOR,EXM,EYM,EZM,ETOTM, - EX,EY,EZ,ETOT,VOLT,BX,BY,BZ,BTOT,BXM,BYM,BZM,BTOTM,GASATT, - DRES DOUBLE PRECISION XAUX1,XAUX2,YAUX1,YAUX2,STEP,BETINT, - XPOS1,XPOS2,XPOSM,YPOS1,YPOS2,YPOSM,ZPOSM,ZPOS1,ZPOS2, - TOTSTP,CRUDE,STACK(MXSTCK,4) INTEGER LOCVEC(MXLIST),ISTACK,NSTACK,ILOCRS,NFC,ILOCM,IU,ILOC EXTERNAL GASATT *** Identify the routine IF(LIDENT)PRINT *,' /// ROUTINE DLCAT1 ///' *** Return straight away if there is only one data point. IF(NU.LE.1)THEN FACTOR=1.0 RETURN ENDIF *** Obtain a very rough estimate of the result. CRUDE=0.0 DO 100 IU=1,NU CALL EFIELD(REAL(XU(IU)),REAL(YU(IU)),REAL(ZU(IU)), - EX,EY,EZ,ETOT,VOLT,0,ILOC) CALL BFIELD(REAL(XU(IU)),REAL(YU(IU)),REAL(ZU(IU)), - BX,BY,BZ,BTOT) * Cheat in case the point is located inside a wire. IF(ILOC.GT.0.AND.ILOC.LE.MXWIRE)THEN DRES=D(ILOC) ILOCRS=ILOC D(ILOCRS)=0.0 CALL EFIELD(REAL(XU(IU)),REAL(YU(IU)),REAL(ZU(IU)), - EX,EY,EZ,ETOT,VOLT,0,ILOC) CALL BFIELD(REAL(XU(IU)),REAL(YU(IU)),REAL(ZU(IU)), - BX,BY,BZ,BTOT) D(ILOCRS)=DRES IF(LDEBUG)PRINT *,' ++++++ DLCAT1 DEBUG : Drift-line', - ' data point in wire ',ILOCRS,' detected; d=0 fix.' ENDIF * In case this didn't help, just log the failure. LOCVEC(IU)=ILOC IF(POLAR)THEN ATTVEC(IU)=GASATT(EX/EXP(REAL(XU(IU))),EY/EXP(REAL(XU(IU))), - EZ,BX,BY,BZ) IF(IU.GT.1)THEN CALL CF2RTC(XU(IU),YU(IU),XAUX1,YAUX1,1) CALL CF2RTC(XU(IU-1),YU(IU-1),XAUX2,YAUX2,1) STEP=SQRT((XAUX2-XAUX1)**2+(YAUX2-YAUX1)**2+ - (ZU(IU)-ZU(IU-1))**2) ENDIF ELSE ATTVEC(IU)=GASATT(EX,EY,EZ,BX,BY,BZ) IF(IU.GT.1)STEP=SQRT((XU(IU)-XU(IU-1))**2+ - (YU(IU)-YU(IU-1))**2+(ZU(IU)-ZU(IU-1))**2) ENDIF IF(IU.GT.1)CRUDE=CRUDE+STEP*(ATTVEC(IU)+ATTVEC(IU-1))/2.0 100 CONTINUE NFC=NU *** Print a heading for the debugging output. IF(LDEBUG)THEN PRINT *,' ++++++ DLCAT1 DEBUG : Attachment integration', - ' debugging output follows:' PRINT *,' ' PRINT *,' IU loc XU(IU)'// - ' YU(IU)'// - ' ZU(IU)'// - ' number of electrons' PRINT *,' [cm]'// - ' [cm]'// - ' [cm]'// - ' [numeric]' PRINT *,' ' PRINT '(2(2X,I3),3(5X,E15.8))',1,LOCVEC(1),XU(1),YU(1),ZU(1) ENDIF *** Initialise the sum BETINT BETINT=0.0 *** Loop over the whole drift-line. ISTACK=0 DO 10 IU=1,NU-1 IF(LOCVEC(IU).NE.0.OR.LOCVEC(IU+1).NE.0)GOTO 30 * Initial values for the position. XPOS1=XU(IU) YPOS1=YU(IU) ZPOS1=ZU(IU) BETA1=ATTVEC(IU) XPOS2=XU(IU+1) YPOS2=YU(IU+1) ZPOS2=ZU(IU+1) BETA2=ATTVEC(IU+1) * Calculate the total steplength, in Cartesian coordinates. IF(POLAR)THEN CALL CF2RTC(XPOS1,YPOS1,XAUX1,YAUX1,1) CALL CF2RTC(XPOS2,YPOS2,XAUX2,YAUX2,1) TOTSTP=SQRT((XAUX2-XAUX1)**2+(YAUX2-YAUX1)**2+ - (ZPOS2-ZPOS1)**2) ELSE TOTSTP=SQRT((XPOS2-XPOS1)**2+(YPOS2-YPOS1)**2+ - (ZPOS2-ZPOS1)**2) ENDIF * Return at this point of further refinement is needed. NSTACK=0 20 CONTINUE * Set the new middle point, to be used for comparison. XPOSM=0.5*(XPOS1+XPOS2) YPOSM=0.5*(YPOS1+YPOS2) ZPOSM=0.5*(ZPOS1+ZPOS2) * Compute the field and the attachment coeff. at the middle point. CALL EFIELD(REAL(XPOSM),REAL(YPOSM),REAL(ZPOSM), - EXM,EYM,EZM,ETOTM,VOLT,0,ILOCM) CALL BFIELD(REAL(XPOSM),REAL(YPOSM),REAL(ZPOSM), - BXM,BYM,BZM,BTOTM) NFC=NFC+1 * Cheat in case the point is located inside a wire. IF(ILOCM.GT.0.AND.ILOCM.LE.MXWIRE)THEN DRES=D(ILOCM) ILOCRS=ILOCM D(ILOCRS)=0.0 CALL EFIELD(REAL(XPOSM),REAL(YPOSM),REAL(ZPOSM), - EXM,EYM,EZM,ETOTM,VOLT,0,ILOCM) CALL BFIELD(REAL(XPOSM),REAL(YPOSM),REAL(ZPOSM), - BXM,BYM,BZM,BTOTM) NFC=NFC+1 D(ILOCRS)=DRES IF(LDEBUG)PRINT *,' ++++++ DLCAT1 DEBUG : Intermediate', - ' point in wire ',ILOCRS,' detected; d=0 fix.' ENDIF * Skip this step in case the ILOC is not due to a wire. IF(ILOCM.NE.0)GOTO 30 IF(POLAR)THEN BETAM=GASATT(EXM/EXP(REAL(XPOSM)),EYM/EXP(REAL(XPOSM)),EZM, - BXM,BYM,BZM) ELSE BETAM=GASATT(EXM,EYM,EZM,BXM,BYM,BZM) ENDIF * Compare first and second order estimates, divide if too large. IF(NSTACK.LT.MIN(MXSTCK,MXATTS).AND.EPSATI*CRUDE.LT. - TOTSTP*ABS(BETA1-2.0*BETAM+BETA2)/3.0)THEN NSTACK=NSTACK+1 ISTACK=MAX(ISTACK,NSTACK) STACK(NSTACK,1)=XPOS2 STACK(NSTACK,2)=YPOS2 STACK(NSTACK,3)=ZPOS2 STACK(NSTACK,4)=BETA2 XPOS2=XPOSM YPOS2=YPOSM ZPOS2=ZPOSM BETA2=BETAM GOTO 20 * No further subdevision is required, transform polar coordinates. ELSE * Make sure the distances are measured in cartesian coordinates. IF(POLAR)THEN CALL CF2RTC(XPOS1,YPOS1,XAUX1,YAUX1,1) CALL CF2RTC(XPOS2,YPOS2,XAUX2,YAUX2,1) STEP=SQRT((XAUX2-XAUX1)**2+(YAUX2-YAUX1)**2+ - (ZPOS2-ZPOS1)**2) ELSE STEP=SQRT((XPOS2-XPOS1)**2+(YPOS2-YPOS1)**2+ - (ZPOS2-ZPOS1)**2) ENDIF * Add the new term to the integral. BETINT=BETINT+STEP*(BETA1+4.0*BETAM+BETA2)/6.0 * Continue with the next segment (if complete) or the next subsegment. XPOS1=XPOS2 YPOS1=YPOS2 ZPOS1=ZPOS2 BETA1=BETA2 IF(NSTACK.GT.0)THEN XPOS2=STACK(NSTACK,1) YPOS2=STACK(NSTACK,2) ZPOS2=STACK(NSTACK,3) BETA2=STACK(NSTACK,4) NSTACK=NSTACK-1 GOTO 20 ENDIF ENDIF * Continue with the next segment. 30 CONTINUE * Print some debugging output. IF(LDEBUG)PRINT '(2I5,4(5X,E15.8))',IU+1,LOCVEC(IU+1),XU(IU+1), - YU(IU+1),ZU(IU+1),EXP(-MIN(46.0D0,BETINT)) 10 CONTINUE *** Finally take the exponential. IF(BETINT.LT.0.0.OR.BETINT.GT.46.0)THEN FACTOR=1.0 ELSE FACTOR=EXP(-BETINT) ENDIF IF(LDEBUG)THEN PRINT *,' ++++++ DLCAT2 DEBUG : EFIELD calls: ',NFC, - ', deepest stack: ',ISTACK PRINT *,' Final log estimate: ', - BETINT,' (crude estimate: ',CRUDE,').' ENDIF END +DECK,DLCAT2. SUBROUTINE DLCAT2(FACTOR) *----------------------------------------------------------------------- * DLCAT2 - Routine returning the attachment losses for the current * drift line. The routine uses an adaptive Simpson style * integration. * VARIABLES : BETA. : Attachment coefficients (1,2 end; M middle) * BETINT : Integral of the attachment coefficient. * FACTOR : The attachment losses * (Last changed on 5/ 2/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,DRIFTLINE. +SEQ,CELLDATA. +SEQ,PRINTPLOT. REAL ATTVEC(MXLIST),BETA1,BETA2,BETAM,FACTOR,EXM,EYM,EZM,ETOTM, - EX,EY,EZ,ETOT,VOLT,GASATT,DRES,SCALE,BX,BY,BZ,BTOT, - BXM,BYM,BZM,BTOTM DOUBLE PRECISION XAUX1,XAUX2,YAUX1,YAUX2,STEP,BETINT, - XPOS1,XPOS2,XPOSM,YPOS1,YPOS2,YPOSM,ZPOSM,ZPOS1,ZPOS2, - TOTSTP,CRUDE,STACK(MXSTCK,4),VD(3) INTEGER LOCVEC(MXLIST),ISTACK,NSTACK,ILOCRS,NFC,ILOCM,IU,ILOC EXTERNAL GASATT *** Identify the routine IF(LIDENT)PRINT *,' /// ROUTINE DLCAT2 ///' *** Return straight away if there is only one data point. IF(NU.LE.1)THEN FACTOR=1.0 RETURN ENDIF *** Obtain a very rough estimate of the result. CRUDE=0.0 DO 100 IU=1,NU CALL EFIELD(REAL(XU(IU)),REAL(YU(IU)),REAL(ZU(IU)), - EX,EY,EZ,ETOT,VOLT,0,ILOC) CALL BFIELD(REAL(XU(IU)),REAL(YU(IU)),REAL(ZU(IU)), - BX,BY,BZ,BTOT) * Cheat in case the point is located inside a wire. IF(ILOC.GT.0.AND.ILOC.LE.MXWIRE)THEN DRES=D(ILOC) ILOCRS=ILOC D(ILOCRS)=0.0 CALL EFIELD(REAL(XU(IU)),REAL(YU(IU)),REAL(ZU(IU)), - EX,EY,EZ,ETOT,VOLT,0,ILOC) CALL BFIELD(REAL(XU(IU)),REAL(YU(IU)),REAL(ZU(IU)), - BX,BY,BZ,BTOT) D(ILOCRS)=DRES IF(LDEBUG)PRINT *,' ++++++ DLCAT2 DEBUG : Drift-line', - ' data point in wire ',ILOCRS,' detected; d=0 fix.' ENDIF * In case this didn't help, just log the failure. LOCVEC(IU)=ILOC * Compute projection of the path. IF(IU.GT.1)THEN CALL DLCVEL((XU(IU-1)+XU(IU))/2,(YU(IU-1)+YU(IU))/2, - (ZU(IU-1)+ZU(IU))/2,VD,QPCHAR,IPTYPE,ILOC) IF(((XU(IU)-XU(IU-1))**2+(YU(IU)-YU(IU-1))**2+ - (ZU(IU)-ZU(IU-1))**2)* - (VD(1)**2+VD(2)**2+VD(3)**2).LE.0)THEN SCALE=0 ELSE SCALE=((XU(IU)-XU(IU-1))*VD(1)+ - (YU(IU)-YU(IU-1))*VD(2)+(ZU(IU)-ZU(IU-1))*VD(3))/ - SQRT(((XU(IU)-XU(IU-1))**2+(YU(IU)-YU(IU-1))**2+ - (ZU(IU)-ZU(IU-1))**2)* - (VD(1)**2+VD(2)**2+VD(3)**2)) ENDIF C print *,' Scale = ',scale C print *,' x: ',xu(iu-1),xu(iu),vd(1) C print *,' y: ',yu(iu-1),yu(iu),vd(2) C print *,' z: ',zu(iu-1),zu(iu),vd(3) ENDIF * Compute attachment coefficients and step length. IF(POLAR)THEN ATTVEC(IU)=GASATT(EX/EXP(REAL(XU(IU))),EY/EXP(REAL(XU(IU))), - EZ,BX,BY,BZ) IF(IU.GT.1)THEN CALL CF2RTC(XU(IU),YU(IU),XAUX1,YAUX1,1) CALL CF2RTC(XU(IU-1),YU(IU-1),XAUX2,YAUX2,1) STEP=SQRT((XAUX2-XAUX1)**2+(YAUX2-YAUX1)**2+ - (ZU(IU)-ZU(IU-1))**2) ENDIF ELSE ATTVEC(IU)=GASATT(EX,EY,EZ,BX,BY,BZ) IF(IU.GT.1)STEP=SQRT((XU(IU)-XU(IU-1))**2+ - (YU(IU)-YU(IU-1))**2+(ZU(IU)-ZU(IU-1))**2) ENDIF IF(IU.GT.1)CRUDE=CRUDE+STEP*SCALE*(ATTVEC(IU)+ATTVEC(IU-1))/2.0 100 CONTINUE NFC=NU *** Ensure that the crude sum is positive. IF(CRUDE.LT.0)THEN PRINT *,' !!!!!! DLCAT2 WARNING : Negative attachment sum'// - ' in 1st order ; multiplication set to 1.' FACTOR=1 RETURN ELSEIF(CRUDE.EQ.0)THEN FACTOR=1 RETURN ENDIF *** Print a heading for the debugging output. IF(LDEBUG)THEN PRINT *,' ++++++ DLCAT2 DEBUG : Attachment integration', - ' debugging output follows:' PRINT *,' ' PRINT *,' IU loc XU(IU)'// - ' YU(IU)'// - ' ZU(IU)'// - ' number of electrons' PRINT *,' [cm]'// - ' [cm]'// - ' [cm]'// - ' [numeric]' PRINT *,' ' PRINT '(2(2X,I3),3(5X,E15.8))',1,LOCVEC(1),XU(1),YU(1),ZU(1) ENDIF *** Initialise the sum BETINT BETINT=0.0 *** Loop over the whole drift-line. ISTACK=0 DO 10 IU=1,NU-1 IF(LOCVEC(IU).NE.0.OR.LOCVEC(IU+1).NE.0)GOTO 30 * Initial values for the position. XPOS1=XU(IU) YPOS1=YU(IU) ZPOS1=ZU(IU) BETA1=ATTVEC(IU) XPOS2=XU(IU+1) YPOS2=YU(IU+1) ZPOS2=ZU(IU+1) BETA2=ATTVEC(IU+1) * Calculate the total steplength, in Cartesian coordinates. IF(POLAR)THEN CALL CF2RTC(XPOS1,YPOS1,XAUX1,YAUX1,1) CALL CF2RTC(XPOS2,YPOS2,XAUX2,YAUX2,1) TOTSTP=SQRT((XAUX2-XAUX1)**2+(YAUX2-YAUX1)**2+ - (ZPOS2-ZPOS1)**2) ELSE TOTSTP=SQRT((XPOS2-XPOS1)**2+(YPOS2-YPOS1)**2+ - (ZPOS2-ZPOS1)**2) ENDIF * Compute projection of the path. CALL DLCVEL((XU(IU+1)+XU(IU))/2,(YU(IU+1)+YU(IU))/2, - (ZU(IU+1)+ZU(IU))/2,VD,QPCHAR,IPTYPE,ILOC) IF(((XU(IU+1)-XU(IU))**2+(YU(IU+1)-YU(IU))**2+ - (ZU(IU+1)-ZU(IU))**2)* - (VD(1)**2+VD(2)**2+VD(3)**2).LE.0)THEN SCALE=0 ELSE SCALE=((XU(IU+1)-XU(IU))*VD(1)+ - (YU(IU+1)-YU(IU))*VD(2)+(ZU(IU+1)-ZU(IU))*VD(3))/ - SQRT(((XU(IU+1)-XU(IU))**2+(YU(IU+1)-YU(IU))**2+ - (ZU(IU+1)-ZU(IU))**2)* - (VD(1)**2+VD(2)**2+VD(3)**2)) ENDIF C print *,' Scale = ',scale * Return at this point of further refinement is needed. NSTACK=0 20 CONTINUE * Set the new middle point, to be used for comparison. XPOSM=0.5*(XPOS1+XPOS2) YPOSM=0.5*(YPOS1+YPOS2) ZPOSM=0.5*(ZPOS1+ZPOS2) * Compute the field and the attachment coeff. at the middle point. CALL EFIELD(REAL(XPOSM),REAL(YPOSM),REAL(ZPOSM), - EXM,EYM,EZM,ETOTM,VOLT,0,ILOCM) CALL BFIELD(REAL(XPOSM),REAL(YPOSM),REAL(ZPOSM), - BXM,BYM,BZM,BTOTM) NFC=NFC+1 * Cheat in case the point is located inside a wire. IF(ILOCM.GT.0.AND.ILOCM.LE.MXWIRE)THEN DRES=D(ILOCM) ILOCRS=ILOCM D(ILOCRS)=0.0 CALL EFIELD(REAL(XPOSM),REAL(YPOSM),REAL(ZPOSM), - EXM,EYM,EZM,ETOTM,VOLT,0,ILOCM) CALL BFIELD(REAL(XPOSM),REAL(YPOSM),REAL(ZPOSM), - BXM,BYM,BZM,BTOTM) NFC=NFC+1 D(ILOCRS)=DRES IF(LDEBUG)PRINT *,' ++++++ DLCAT2 DEBUG : Intermediate', - ' point in wire ',ILOCRS,' detected; d=0 fix.' ENDIF * Skip this step in case the ILOC is not due to a wire. IF(ILOCM.NE.0)GOTO 30 IF(POLAR)THEN BETAM=GASATT(EXM/EXP(REAL(XPOSM)),EYM/EXP(REAL(XPOSM)),EZM, - BXM,BYM,BZM) ELSE BETAM=GASATT(EXM,EYM,EZM,BXM,BYM,BZM) ENDIF * Compare first and second order estimates, divide if too large. IF(NSTACK.LT.MIN(MXSTCK,MXATTS).AND.EPSATI*CRUDE.LT. - TOTSTP*ABS(BETA1-2.0*BETAM+BETA2)/3.0)THEN NSTACK=NSTACK+1 ISTACK=MAX(ISTACK,NSTACK) STACK(NSTACK,1)=XPOS2 STACK(NSTACK,2)=YPOS2 STACK(NSTACK,3)=ZPOS2 STACK(NSTACK,4)=BETA2 XPOS2=XPOSM YPOS2=YPOSM ZPOS2=ZPOSM BETA2=BETAM GOTO 20 * No further subdevision is required, transform polar coordinates. ELSE * Make sure the distances are measured in cartesian coordinates. IF(POLAR)THEN CALL CF2RTC(XPOS1,YPOS1,XAUX1,YAUX1,1) CALL CF2RTC(XPOS2,YPOS2,XAUX2,YAUX2,1) STEP=SQRT((XAUX2-XAUX1)**2+(YAUX2-YAUX1)**2+ - (ZPOS2-ZPOS1)**2) ELSE STEP=SQRT((XPOS2-XPOS1)**2+(YPOS2-YPOS1)**2+ - (ZPOS2-ZPOS1)**2) ENDIF * Add the new term to the integral. BETINT=BETINT+STEP*SCALE*(BETA1+4.0*BETAM+BETA2)/6.0 * Continue with the next segment (if complete) or the next subsegment. XPOS1=XPOS2 YPOS1=YPOS2 ZPOS1=ZPOS2 BETA1=BETA2 IF(NSTACK.GT.0)THEN XPOS2=STACK(NSTACK,1) YPOS2=STACK(NSTACK,2) ZPOS2=STACK(NSTACK,3) BETA2=STACK(NSTACK,4) NSTACK=NSTACK-1 GOTO 20 ENDIF ENDIF * Continue with the next segment. 30 CONTINUE * Print some debugging output. IF(LDEBUG)PRINT '(2I5,4(5X,E15.8))',IU+1,LOCVEC(IU+1),XU(IU+1), - YU(IU+1),ZU(IU+1),EXP(-MIN(46.0D0,BETINT)) 10 CONTINUE *** Finally take the exponential. IF(BETINT.LT.0.0.OR.BETINT.GT.46.0)THEN FACTOR=1.0 ELSE FACTOR=EXP(-BETINT) ENDIF IF(LDEBUG)THEN PRINT *,' ++++++ DLCAT2 DEBUG : EFIELD calls: ',NFC, - ', deepest stack: ',ISTACK PRINT *,' Final log estimate: ', - BETINT,' (crude estimate: ',CRUDE,').' ENDIF END +DECK,DLCDIF. SUBROUTINE DLCDIF(SIGMA) *----------------------------------------------------------------------- * DLCDIF - Returns the diffusion. * (Last changed on 7/ 2/97.) *----------------------------------------------------------------------- C implicit none +SEQ,DIMENSIONS. +SEQ,GASDATA. +SEQ,DRIFTLINE. REAL SIGMA *** If the particle is an electron, compute as usual. IF(IPTYPE.EQ.1)THEN IF(GASOK(3).AND.GASOK(8))THEN CALL DLCDF2(SIGMA) ELSEIF(GASOK(3))THEN CALL DLCDF1(SIGMA) ELSE SIGMA=0.0 ENDIF *** If the particle is an ion, return 0. ELSE SIGMA=0 ENDIF END +DECK,DLCDF1. SUBROUTINE DLCDF1(SIGMA) *----------------------------------------------------------------------- * DLCDF1 - Routine returning the integrated diffusion coefficient of * the current drift line. The routine uses an adaptive * Simpson integration. * VARIABLES : SIGMA. : Diffusion coefficients (1,2 end; M middle). * V. : Drift velocity (1,2: end points; M middle). * CRUDE : Crude estimate of SIGMA. * (Last changed on 4/ 2/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,DRIFTLINE. +SEQ,CELLDATA. +SEQ,PRINTPLOT. REAL SIGVEC(MXLIST),VELVEC(MXLIST),SIGMA,SIGMA1,SIGMA2, - SIGMAM,V1,V2,VM,EX,EY,EZ,ETOT,EXM,EYM,EZM,ETOTM,VOLT, - BX,BY,BZ,BTOT,BXM,BYM,BZM,BTOTM,DRES,GASDFL DOUBLE PRECISION XAUX1,XAUX2,YAUX1,YAUX2,STEP,SUM,XPOS1,XPOS2, - XPOSM,YPOS1,YPOS2,YPOSM,ZPOS1,ZPOS2,ZPOSM,TOTSTP,CRUDE, - STACK(MXSTCK,5),F1(3) INTEGER LOCVEC(MXLIST),ILOC,ILOC2,ILOCM,IU,ILOCRS,NSTACK,ISTACK, - NFC EXTERNAL GASDFL *** Identify the routine IF(LIDENT)PRINT *,' /// ROUTINE DLCDF1 ///' *** Return straight away if there is only one data point. IF(NU.LE.1)THEN SIGMA=0.0 RETURN ENDIF *** Obtain a rough estimate of the result. CRUDE=0.0 DO 100 IU=1,NU CALL EFIELD(REAL(XU(IU)),REAL(YU(IU)),REAL(ZU(IU)), - EX,EY,EZ,ETOT,VOLT,0,ILOC) CALL BFIELD(REAL(XU(IU)),REAL(YU(IU)),REAL(ZU(IU)), - BX,BY,BZ,BTOT) CALL DLCVEL(XU(IU),YU(IU),ZU(IU),F1,-1.0,1,ILOC2) * Cheat in case the point is located inside a wire. IF(ILOC.GT.0.AND.ILOC.LE.MXWIRE)THEN DRES=D(ILOC) ILOCRS=ILOC D(ILOCRS)=0.0 CALL EFIELD(REAL(XU(IU)),REAL(YU(IU)),REAL(ZU(IU)), - EX,EY,EZ,ETOT,VOLT,0,ILOC) CALL BFIELD(REAL(XU(IU)),REAL(YU(IU)),REAL(ZU(IU)), - BX,BY,BZ,BTOT) CALL DLCVEL(XU(IU),YU(IU),ZU(IU),F1,-1.0,1,ILOC2) D(ILOCRS)=DRES IF(LDEBUG)PRINT *,' ++++++ DLCDF1 DEBUG : Drift-line', - ' data point in wire ',ILOCRS,' detected; d=0 fix.' ENDIF * Store the information for this point of the drift line. LOCVEC(IU)=ILOC IF(POLAR)THEN VELVEC(IU)=SQRT(F1(1)**2+F1(2)**2+F1(3)**2)*EXP(XU(IU)) SIGVEC(IU)=GASDFL(EX/EXP(REAL(XU(IU))), - EY/EXP(REAL(XU(IU))),EZ,BX,BY,BZ) IF(IU.GT.1)THEN CALL CF2RTC(XU(IU),YU(IU),XAUX1,YAUX1,1) CALL CF2RTC(XU(IU-1),YU(IU-1),XAUX2,YAUX2,1) STEP=SQRT((XAUX2-XAUX1)**2+(YAUX2-YAUX1)**2+ - (ZU(IU)-ZU(IU-1))**2) ENDIF ELSE VELVEC(IU)=SQRT(F1(1)**2+F1(2)**2+F1(3)**2) SIGVEC(IU)=GASDFL(EX,EY,EZ,BX,BY,BZ) IF(IU.GT.1)STEP=SQRT((XU(IU)-XU(IU-1))**2+ - (YU(IU)-YU(IU-1))**2+(ZU(IU)-ZU(IU-1))**2) ENDIF IF(IU.GT.1)THEN IF(VELVEC(IU)*VELVEC(IU-1).GT.0) - CRUDE=CRUDE+STEP*((SIGVEC(IU)/VELVEC(IU))**2+ - (SIGVEC(IU-1)/VELVEC(IU-1))**2)/2.0 ENDIF 100 CONTINUE NFC=NU CRUDE=SQRT(CRUDE) *** Initialise the double precision copy of SIGMA: SUM. SUM=0.0 *** Loop over the whole drift-line. ISTACK=0 DO 10 IU=1,NU-1 IF(LOCVEC(IU).NE.0.OR.LOCVEC(IU+1).NE.0)GOTO 10 * Initial values for the position. XPOS1=XU(IU) YPOS1=YU(IU) ZPOS1=ZU(IU) V1=VELVEC(IU) SIGMA1=SIGVEC(IU) XPOS2=XU(IU+1) YPOS2=YU(IU+1) ZPOS2=ZU(IU+1) V2=VELVEC(IU+1) SIGMA2=SIGVEC(IU+1) * Calculate the total steplength, in Cartesian coordinates. IF(POLAR)THEN CALL CF2RTC(XPOS1,YPOS1,XAUX1,YAUX1,1) CALL CF2RTC(XPOS2,YPOS2,XAUX2,YAUX2,1) TOTSTP=SQRT((XAUX2-XAUX1)**2+(YAUX2-YAUX1)**2+ - (ZPOS2-ZPOS1)**2) ELSE TOTSTP=SQRT((XPOS2-XPOS1)**2+(YPOS2-YPOS1)**2+ - (ZPOS2-ZPOS1)**2) ENDIF ** Return at this point of further refinement is needed. NSTACK=0 20 CONTINUE * Set the new middle point, to be used for comparison. XPOSM=0.5*(XPOS1+XPOS2) YPOSM=0.5*(YPOS1+YPOS2) ZPOSM=0.5*(ZPOS1+ZPOS2) * Compute field, diffusion and velocity at the middle point. CALL EFIELD(REAL(XPOSM),REAL(YPOSM),REAL(ZPOSM), - EXM,EYM,EZM,ETOTM,VOLT,0,ILOCM) CALL BFIELD(REAL(XPOSM),REAL(YPOSM),REAL(ZPOSM), - BXM,BYM,BZM,BTOTM) CALL DLCVEL(XPOSM,YPOSM,ZPOSM,F1,-1.0,1,ILOC2) NFC=NFC+1 * Cheat in case the point is located inside a wire. IF(ILOCM.GT.0.AND.ILOCM.LE.MXWIRE)THEN DRES=D(ILOCM) ILOCRS=ILOCM D(ILOCRS)=0.0 CALL EFIELD(REAL(XPOSM),REAL(YPOSM),REAL(ZPOSM), - EXM,EYM,EZM,ETOTM,VOLT,0,ILOCM) CALL BFIELD(REAL(XPOSM),REAL(YPOSM),REAL(ZPOSM), - BXM,BYM,BZM,BTOTM) CALL DLCVEL(XPOSM,YPOSM,ZPOSM,F1,-1.0,1,ILOC2) NFC=NFC+1 D(ILOCRS)=DRES IF(LDEBUG)PRINT *,' ++++++ DLCDF1 DEBUG : Intermediate', - ' point in wire ',ILOCRS,' detected; d=0 fix.' ENDIF * In case this still didn't help, skip this step. IF(ILOCM.NE.0)GOTO 10 * Otherwise compute drift speed and diffusion at intermediate point. IF(POLAR)THEN VM=SQRT(F1(1)**2+F1(2)**2+F1(3)**2)*EXP(XPOSM) SIGMAM=GASDFL(EXM/EXP(REAL(XPOSM)),EYM/EXP(REAL(XPOSM)),EZM, - BXM,BYM,BZM) ELSE VM=SQRT(F1(1)**2+F1(2)**2+F1(3)**2) SIGMAM=GASDFL(EXM,EYM,EZM,BXM,BYM,BZM) ENDIF * Prevent division by zero in the strange case the speed is 0. IF(V1*V2*VM.EQ.0.0.OR.SIGMA1*SIGMAM*SIGMA2.EQ.0.0)THEN PRINT *,' !!!!!! DLCDF1 WARNING : Drift velocity or', - ' diffusion = 0 detected; some points skipped.' GOTO 10 ENDIF *** Compare first and second order estimates, divide if too large. IF(NSTACK.LT.MIN(MXSTCK,MXDIFS).AND.EPSDFI*CRUDE.LT. - ABS((SIGMA1/V1)**2-2.0*(SIGMAM/VM)**2+(SIGMA2/V2)**2)* - SQRT(TOTSTP*2.0/((SIGMA1/V1)**2+(SIGMA2/V2)**2))/6.0)THEN NSTACK=NSTACK+1 ISTACK=MAX(ISTACK,NSTACK) STACK(NSTACK,1)=XPOS2 STACK(NSTACK,2)=YPOS2 STACK(NSTACK,5)=ZPOS2 STACK(NSTACK,3)=V2 STACK(NSTACK,4)=SIGMA2 XPOS2=XPOSM YPOS2=YPOSM ZPOS2=ZPOSM V2=VM SIGMA2=SIGMAM GOTO 20 ** No further subdevision is required, transform polar coordinates. ELSE * Make sure the distances are measured in cartesian coordinates. IF(POLAR)THEN CALL CF2RTC(XPOS1,YPOS1,XAUX1,YAUX1,1) CALL CF2RTC(XPOS2,YPOS2,XAUX2,YAUX2,1) STEP=SQRT((XAUX2-XAUX1)**2+(YAUX2-YAUX1)**2+ - (ZPOS2-ZPOS1)**2) ELSE STEP=SQRT((XPOS2-XPOS1)**2+(YPOS2-YPOS1)**2+ - (ZPOS2-ZPOS1)**2) ENDIF * Add the new term to the integral. SUM=SUM+STEP* - ((SIGMA1/V1)**2+4.0*(SIGMAM/VM)**2+(SIGMA2/V2)**2)/6.0 * Continue with the next segment (if complete) or the next subsegment. XPOS1=XPOS2 YPOS1=YPOS2 ZPOS1=ZPOS2 V1=V2 SIGMA1=SIGMA2 IF(NSTACK.GT.0)THEN XPOS2=STACK(NSTACK,1) YPOS2=STACK(NSTACK,2) ZPOS2=STACK(NSTACK,5) V2=STACK(NSTACK,3) SIGMA2=STACK(NSTACK,4) NSTACK=NSTACK-1 GOTO 20 ENDIF ENDIF * Continue with the next segment. 10 CONTINUE *** Remember: we calculated the square of the diffusion coefficient. SIGMA=REAL(SQRT(SUM)) IF(LDEBUG)THEN PRINT *,' ++++++ DLCDF1 DEBUG : EFIELD calls: ',NFC, - ', deepest stack: ',ISTACK PRINT *,' Final estimate: ',SIGMA, - ' (crude estimate: ',CRUDE,').' ENDIF END +DECK,DLCDF2. SUBROUTINE DLCDF2(DIFF) *----------------------------------------------------------------------- * DLCDF2 - Integrates both transverse and longitudinal diffusion over * the current drift line. * (Last changed on 4/ 2/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,DRIFTLINE. +SEQ,CONSTANTS. +SEQ,PRINTPLOT. +SEQ,CELLDATA. DOUBLE PRECISION COV(2,2),SUM(2,2),STEP,C,S,F1(3),F2(3),F3(3), - F4(3),SCL,SCT,EPS,TEMP,DL,DT,RHO2,SIZE,SLAST,SNOW,VLAST, - VNOW,SIGMA C double precision fl(3),templ REAL GASDFL,GASDFT,XWIRE,YWIRE,DWIRE,EX1,EY1,EZ1,E1, - BX1,BY1,BZ1,BTOT1,BX,BY,BZ,BTOT,DIFF, - EX2,EY2,EZ2,E2,BX2,BY2,BZ2,B2,EX,EY,EZ,ETOT,VOLT INTEGER ILOC,ILOC1,ILOC2,IWIRE,ILAST,I,IFAIL EXTERNAL GASDFL,GASDFT *** Identify the routine IF(LIDENT)PRINT *,' /// ROUTINE DLCDF2 ///' IF(LDEBUG)PRINT *,' ++++++ DLCDF2 DEBUG : Starting to sum'// - ' L&T diffusion, NU=',NU,' ISTAT=',ISTAT *** Assume the routine will fail. IFAIL=1 *** Initialise some variables. DIFF=0 TEMP=0 SIZE=0 ILAST=1 F2(1)=0 F2(2)=0 F2(3)=0 *** Verify that there are some steps. IF(NU.LT.2)THEN IF(LDEBUG)PRINT *,' ++++++ DLCDF2 DEBUG :'// - ' The drift line has no steps ; diffusion=0.' RETURN ENDIF *** Initialise the covariance matrix. SUM(1,1)=0 SUM(1,2)=0 SUM(2,1)=0 SUM(2,2)=0 *** Initialise the various quantities that are shifted through. CALL EFIELD(REAL(XU(1)),REAL(YU(1)),REAL(ZU(1)), - EX1,EY1,EZ1,E1,VOLT,0,ILOC1) CALL BFIELD(REAL(XU(1)),REAL(YU(1)),REAL(ZU(1)), - BX1,BY1,BZ1,BTOT1) CALL DLCVEL(XU(1),YU(1),ZU(1),F1,-1.0,1,ILOC2) IF(ILOC1.NE.0.OR.ILOC2.NE.0)THEN PRINT *,' !!!!!! DLCDF2 WARNING : Initial point on drift'// - ' line has unusual location codes ',ILOC1,ILOC2 RETURN ENDIF *** Set the radius to zero temporarily for a drift line going to a wire. IF(ISTAT.GE.1.AND.ISTAT.LE.MXWIRE+NWIRE)THEN * Obtain the wire number. IF(ISTAT.GT.MXWIRE)THEN IWIRE=ISTAT-MXWIRE ELSE IWIRE=ISTAT ENDIF * Store the wire diameter and set temporarily to zero. DWIRE=D(IWIRE) D(IWIRE)=0.0 IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCDF2 DEBUG :'', - '' Temporarily setting the diameter of wire '',I4, - '' to 0.'')') IWIRE * Locate the nearest replica of the wire. at the end point. XWIRE=X(IWIRE) IF(PERX)XWIRE=XWIRE-SX*ANINT((XWIRE-XU(NU))/SX) YWIRE=Y(IWIRE) IF(PERY)YWIRE=YWIRE-SY*ANINT((YWIRE-YU(NU))/SY) IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCDF2 DEBUG :'', - '' Wire replica nearest to end point: ('',E15.8,'','', - E15.8,'').'')') XWIRE,YWIRE ELSE IWIRE=0 DWIRE=0 XWIRE=0 YWIRE=0 ENDIF *** Loop over the steps C templ=0.0 C call efield(real(xu(1)),real(yu(1)),real(zu(1)), C - ex,ey,ez,etot,volt,0,iloc) C call bfield(real(xu(1)),real(yu(1)),real(zu(1)), C - bx,by,bz,btot) C call dlcvel(xu(1),yu(1),zu(1),fl,-1.0,1,iloc2) C vlast=sqrt(fl(1)**2+fl(2)**2+fl(3)**2) C slast=gasdfl(ex,ey,ez,bx,by,bz) DO 10 I=1,NU-1 * Get pure longitudinal diffusion. C call efield(real(xu(i+1)),real(yu(i+1)),real(zu(i+1)), C - ex,ey,ez,etot,volt,0,iloc) C call bfield(real(xu(i+1)),real(yu(i+1)),real(zu(i+1)), C - bx,by,bz,btot) C call dlcvel(xu(i+1),yu(i+1),zu(i+1),fl,-1.0,1,iloc2) C vnow=sqrt(fl(1)**2+fl(2)**2+fl(3)**2) C snow=gasdfl(ex,ey,ez,bx,by,bz) C step=sqrt((xu(i+1)-xu(i))**2+(yu(i+1)-yu(i))**2+ C - (zu(i+1)-zu(i))**2) C templ=templ+step*((snow/vnow)**2+(slast/vlast)**2)/2 C vlast=vnow C slast=snow * Stop this integration if the cloud is less than n radii from a wire. IF(IWIRE.GT.0.AND.MDF2.NE.0.AND.RDF2*SIZE.GT.MAX(0.0D0, - SQRT((XU(I+1)-XWIRE)**2+(YU(I+1)-YWIRE)**2)-DWIRE/2))THEN IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCDF2 DEBUG :'', - '' n * Size > Distance at IU='',I3,''/'',I3/25X, - '' Size = '',E15.8,'' [cm],''/25X, - '' Distance = '',E15.8,'' [cm].'')') - I+1,NU,SIZE,SQRT((XU(I+1)-XWIRE)**2+(YU(I+1)-YWIRE)**2) GOTO 20 ENDIF * Length and orientation of the step. STEP=SQRT((XU(I+1)-XU(I))**2+(YU(I+1)-YU(I))**2+ - (ZU(I+1)-ZU(I))**2) IF(STEP.LE.0.0.OR.STEP.LE.1.0E-6*DWIRE)THEN IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCDF2 DEBUG :'', - '' Skipping step '',I3,'' of length '',E15.8)') - I,STEP GOTO 10 ENDIF C=(XU(I+1)-XU(I))/STEP S=(YU(I+1)-YU(I))/STEP * Transverse diffusion scaling factor. EPS=1.0E-3*(1+ABS(XU(I))+ABS(YU(I))) CALL DLCVEL(XU(I)-S*EPS,YU(I)+C*EPS,ZU(I),F3,-1.0,1,ILOC1) CALL DLCVEL(XU(I)+S*EPS,YU(I)-C*EPS,ZU(I),F4,-1.0,1,ILOC2) IF(ILOC1.NE.0.OR.ILOC2.NE.0)THEN PRINT *,' !!!!!! DLCDF2 WARNING : Unable to compute'// - ' transverse scaling factor; set to 1.' SCT=1.0 ELSE SCT=1+(TU(I+1)-TU(I))*(-S*F3(1)+C*F3(2)+S*F4(1)-C*F4(2))/ - (2*EPS) ENDIF IF(SCT.LE.0)THEN PRINT *,' !!!!!! DLCDF2 WARNING : Transverse scaling'// - ' factor < 0 detected; set to 1.' SCT=1.0 ENDIF * Longitudinal scaling factor. CALL DLCVEL(XU(I+1),YU(I+1),ZU(I+1),F2,-1.0,1,ILOC2) IF(ILOC2.NE.0)THEN PRINT *,' !!!!!! DLCDF2 WARNING : Final point has unusual'// - ' location code; summing terminated.' GOTO 20 ELSEIF(SQRT(F1(1)**2+F1(2)**2+F1(3)**2).EQ.0.OR. - SQRT(F2(1)**2+F2(2)**2+F2(3)**2).EQ.0)THEN PRINT *,' !!!!!! DLCDF2 WARNING : Longitudinal velocity'// - ' of 0 detected.' SCL=1.0 ELSE SCL=SQRT(F2(1)**2+F2(2)**2+F2(3)**2)/ - SQRT(F1(1)**2+F1(2)**2+F1(3)**2) ENDIF * Compute the field at the end point in view of getting diffusions. CALL EFIELD(REAL(XU(I+1)),REAL(YU(I+1)),REAL(ZU(I+1)), - EX2,EY2,EZ2,E2,VOLT,0,ILOC) CALL BFIELD(REAL(XU(I+1)),REAL(YU(I+1)),REAL(ZU(I+1)), - BX2,BY2,BZ2,B2) IF(ILOC.NE.0)THEN IF(I.EQ.NU-1)THEN GOTO 20 ELSE PRINT *,' !!!!!! DLCDF2 WARNING : Intermediate point'// - ' has unusual location code ',ILOC GOTO 20 ENDIF ENDIF * Obtain longitudinal and transverse diffusion at this step. DL=SQRT(0.5*(GASDFL(EX1,EY1,EZ1,BX1,BY1,BZ1)**2+ - (GASDFL(EX2,EY2,EZ2,BX2,BY2,BZ2)/SCL)**2)) DT=(GASDFT(EX1,EY1,EZ1,BX1,BY1,BZ1)+ - GASDFT(EX2,EY2,EZ2,BX2,BY2,BZ2))/2 * Compensate diffusion for step length. DL=DL*SQRT(STEP) DT=DT*SQRT(STEP) * Add this step to the sum. SUM(1,1)=SUM(1,1)+C**2*DL**2+S**2*DT**2 SUM(1,2)=SUM(1,2)+C*S*(DT**2-DL**2) SUM(2,1)=SUM(2,1)+C*S*(DT**2-DL**2) SUM(2,2)=SUM(2,2)+C**2*DT**2+S**2*DL**2 * Align with the drift line, rotating inverted matrix. COV(1,1)=C**2*SUM(1,1)-C*S*SUM(1,2)-C*S*SUM(2,1)+S**2*SUM(2,2) COV(1,2)=C**2*SUM(2,1)-C*S*SUM(2,2)+C*S*SUM(1,1)-S**2*SUM(1,2) COV(2,1)=C**2*SUM(1,2)-C*S*SUM(2,2)+C*S*SUM(1,1)-S**2*SUM(2,1) COV(2,2)=C**2*SUM(2,2)+C*S*SUM(1,2)+C*S*SUM(2,1)+S**2*SUM(1,1) * Debugging output. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCDF2 DEBUG :'', - '' Transverse scaling: '',E15.8/ - 26X,''Longitudinal scaling: '',E15.8)') SCT,SCL * Update the covariance matrix. COV(1,1)=COV(1,1)*SCL**2 COV(1,2)=COV(1,2)*SCL*SCT COV(2,1)=COV(2,1)*SCT*SCL COV(2,2)=COV(2,2)*SCT**2 * Evaluate the correlation coefficient. IF(COV(1,1)*COV(2,2).LT.COV(1,2)*COV(2,1))THEN RHO2=1.0 PRINT *,' !!!!!! DLCDF2 WARNING : Correlation > 1 ; set'// - ' to 1.' ELSEIF(COV(1,1)*COV(2,2).EQ.0)THEN RHO2=0.0 ELSE RHO2=(COV(1,2)*COV(2,1))/(COV(1,1)*COV(2,2)) ENDIF * Keep continuously track of longitudinal component. TEMP=COV(1,1)*(1-RHO2)/(F2(1)**2+F2(2)**2+F2(3)**2) * Realign the matrix with the coordinate system. SUM(1,1)=C**2*COV(1,1)+C*S*COV(1,2)+C*S*COV(2,1)+S**2*COV(2,2) SUM(1,2)=C**2*COV(2,1)+C*S*COV(2,2)-C*S*COV(1,1)-S**2*COV(1,2) SUM(2,1)=C**2*COV(1,2)+C*S*COV(2,2)-C*S*COV(1,1)-S**2*COV(2,1) SUM(2,2)=C**2*COV(2,2)-C*S*COV(1,2)-C*S*COV(2,1)+S**2*COV(1,1) * And monitor the size of the cloud. SIZE=SQRT(MAX(0.0D0,COV(1,1)*(1-RHO2),COV(2,2)*(1-RHO2))) * Debugging output: C IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCDF2 DEBUG : Matrix'', C - '' at (x,y,z)='',3(E12.5,1X),'' step '',I3,'':''/ C - 26X,2E15.8/26X,2E15.8/ C - 26X,''Longitudinal size = '',E15.8,'' [cm]''/ C - 26X,''Transverse size = '',E15.8,'' [cm]''/ C - 26X,''Correlation = '',E15.8/ C - 26X,''Start speed = '',E15.8,'' [cm/microsec]''/ C - 26X,''End speed = '',E15.8,'' [cm/microsec]''/ C - 26X,''Diffusion L + T = '',E15.8,'' [microsec]''/ C - 26X,''Diffusion L only = '',E15.8,'' [microsec]'')') C - XU(I),YU(I),ZU(I),I,SUM(1,1),SUM(1,2),SUM(2,1),SUM(2,2), C - SQRT(MAX(0.0D0,COV(1,1)*(1-RHO2))), C - SQRT(MAX(0.0D0,COV(2,2)*(1-RHO2))), C - SQRT(RHO2),SQRT(F1(1)**2+F1(2)**2+F1(3)**2), C - SQRT(F2(1)**2+F2(2)**2+F2(3)**2),SQRT(TEMP),SQRT(TEMPL) * Shift some parameters for next iteration. EX1=EX2 EY1=EY2 EZ1=EZ2 F1(1)=F2(1) F1(2)=F2(2) F1(3)=F2(3) * Remember that we carried this step out. ILAST=I+1 10 CONTINUE *** Continue here in case of aborted integration. 20 CONTINUE *** Drift line hits the wire, first no treatment (longitudinal). IF(IWIRE.GT.0.AND.(MDF2.EQ.0.OR.MDF2.EQ.3))THEN * Restore wire diameter. D(IWIRE)=DWIRE ** Integration over the cloud, either full or with constant velocity. ELSEIF(IWIRE.GT.0.AND.(MDF2.EQ.1.OR.MDF2.EQ.2))THEN * Output estimate sofar. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCDF2 DEBUG :'', - '' Diffusion estimates before wire stepping''/25X, - '' Longitudinal component only: '',E15.8, - '' [microsec]'')') SQRT(MAX(0.0D0,TEMP)) * Estimate the spread in distances from the cloud. CALL DLCDIW(SUM,XU(ILAST),YU(ILAST),ZU(ILAST), - XWIRE,YWIRE,DWIRE,SIGMA,IFAIL) TEMP=SIGMA**2 IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCDF2 DEBUG :'', - '' Diffusion estimates during wire stepping''/25X, - '' Standard deviation cloud size: '',E15.8, - '' [microsec]'')') SQRT(MAX(0.0D0,TEMP)) * Add the purely longitudinal term for the last step. CALL EFIELD(REAL(XU(ILAST)),REAL(YU(ILAST)),REAL(ZU(ILAST)), - EX,EY,EZ,ETOT,VOLT,0,ILOC) CALL BFIELD(REAL(XU(ILAST)),REAL(YU(ILAST)),REAL(ZU(ILAST)), - BX,BY,BZ,BTOT) CALL DLCVEL(XU(ILAST),YU(ILAST),ZU(ILAST),F1,-1.0,1,ILOC1) VLAST=SQRT(MAX(0.0D0,F1(1)**2+F1(2)**2+F1(3)**2)) SLAST=GASDFL(EX,EY,EZ,BX,BY,BZ) DO 30 I=ILAST,NU-1 CALL EFIELD(REAL(XU(I+1)),REAL(YU(I+1)),REAL(ZU(I+1)), - EX,EY,EZ,ETOT,VOLT,0,ILOC) CALL BFIELD(REAL(XU(I+1)),REAL(YU(I+1)),REAL(ZU(I+1)), - BX,BY,BZ,BTOT) CALL DLCVEL(XU(I+1),YU(I+1),ZU(I+1),F2,-1.0,1,ILOC2) VNOW=SQRT(MAX(0.0D0,F2(1)**2+F2(2)**2+F2(3)**2)) SNOW=GASDFL(EX,EY,EZ,BX,BY,BZ) STEP=SQRT((XU(I+1)-XU(I))**2+(YU(I+1)-YU(I))**2+ - (ZU(I+1)-ZU(I))**2) IF(VNOW.GT.0.AND.VLAST.GT.0) - TEMP=TEMP+STEP*((SNOW/VNOW)**2+(SLAST/VLAST)**2)/2 VLAST=VNOW SLAST=SNOW 30 CONTINUE IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCDF2 DEBUG :'', - '' Diffusion estimates after wire stepping''/25X, - '' Including long diff last step: '',E15.8, - '' [microsec]'')') SQRT(MAX(0.0D0,TEMP)) * Restore the wire diameter. D(IWIRE)=DWIRE ** Take the largest axis (useful if there is a B field). ELSEIF(IWIRE.GT.0.AND.MDF2.EQ.4)THEN * Output estimate sofar. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCDF2 DEBUG :'', - '' Diffusion estimate from longitudinal''/25X, - '' component only: '',E15.8, - '' [microsec]'')') SQRT(MAX(0.0D0,TEMP)) * Compute largest dimension of the cloud, first align the cloud. IF((SUM(2,2)-SUM(1,1))**2+(SUM(1,2)+SUM(2,1))**2.GT.0)THEN C=SQRT(0.5*(1+(SUM(2,2)-SUM(1,1))/ - SQRT((SUM(2,2)-SUM(1,1))**2+ - (SUM(1,2)+SUM(2,1))**2))) S=SIGN(SQRT(1-C**2),SUM(1,2)+SUM(2,1)) ELSE C=1 S=0 ENDIF * Determine maximum cloud cross section. SIZE=MAX(SQRT(MAX(0.0D0,C**2*SUM(1,1)-C*S*SUM(1,2)- - C*S*SUM(2,1)+S**2*SUM(2,2))), - SQRT(MAX(0.0D0,C**2*SUM(2,2)+C*S*SUM(1,2)+ - C*S*SUM(2,1)+S**2*SUM(1,1)))) * Compute the drift velocity at the last point. CALL EFIELD(REAL(XU(ILAST)),REAL(YU(ILAST)),REAL(ZU(ILAST)), - EX,EY,EZ,ETOT,VOLT,0,ILOC) CALL BFIELD(REAL(XU(ILAST)),REAL(YU(ILAST)),REAL(ZU(ILAST)), - BX,BY,BZ,BTOT) CALL DLCVEL(XU(ILAST),YU(ILAST),ZU(ILAST),F1,-1.0,1,ILOC1) VLAST=SQRT(MAX(0.0D0,F1(1)**2+F1(2)**2+F1(3)**2)) SLAST=GASDFL(EX,EY,EZ,BX,BY,BZ) * Compensate size for speed. IF(VLAST.LE.0.0)THEN PRINT *,' !!!!!! DLCDF2 WARNING : End point speed'// - ' before wire stepping zero; diffusion=0.' TEMP=0 ELSE TEMP=(SIZE/VLAST)**2 ENDIF IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCDF2 DEBUG :'', - '' Diffusion estimates from largest cloud''/25X, - '' dimension: '',E15.8,'' [microsec]'')') - SQRT(MAX(0.0D0,TEMP)) * Add the purely longitudinal term for the last step. DO 40 I=ILAST,NU-1 CALL EFIELD(REAL(XU(I+1)),REAL(YU(I+1)),REAL(ZU(I+1)), - EX,EY,EZ,ETOT,VOLT,0,ILOC) CALL BFIELD(REAL(XU(I+1)),REAL(YU(I+1)),REAL(ZU(I+1)), - BX,BY,BZ,BTOT) CALL DLCVEL(XU(I+1),YU(I+1),ZU(I+1),F2,-1.0,1,ILOC2) VNOW=SQRT(MAX(0.0D0,F2(1)**2+F2(2)**2+F2(3)**2)) SNOW=GASDFL(EX,EY,EZ,BX,BY,BZ) STEP=SQRT((XU(I+1)-XU(I))**2+(YU(I+1)-YU(I))**2+ - (ZU(I+1)-ZU(I))**2) IF(VNOW.GT.0.AND.VLAST.GT.0) - TEMP=TEMP+STEP*((SNOW/VNOW)**2+(SLAST/VLAST)**2)/2 VLAST=VNOW SLAST=SNOW 40 CONTINUE IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCDF2 DEBUG :'', - '' Diffusion estimates after wire stepping''/25X, - '' Including long diff last step: '',E15.8, - '' [microsec]'')') SQRT(MAX(0.0D0,TEMP)) * Restore the wire diameter. D(IWIRE)=DWIRE ** Other termination codes, not valid. ELSEIF(IWIRE.GT.0)THEN * Issue warning. PRINT *,' !!!!!! DLCDF2 WARNING : Unknown integration'// - ' code (',MDF2,') received; program bug.' * Restore wire diameter. D(IWIRE)=DWIRE ENDIF *** Integration done, retrieve the result we accumulated. IF(TEMP.LT.0.0)THEN PRINT *,' !!!!!! DLCDF2 WARNING : Final longitudinal'// - ' component < 0 ; diffusion=0.' RETURN ENDIF DIFF=SQRT(TEMP) *** Things seem to have worked. IFAIL=0 END +DECK,DLCDIW. SUBROUTINE DLCDIW(COV,XC1,YC1,ZC1,XW1,YW1,DW1,SIGMA,IFAIL) *----------------------------------------------------------------------- * DLCDIW - Integration of the time a cloud needs to reach a wire. * (Last changed on 8/11/95.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. +SEQ,DRIFTLINE. DOUBLE PRECISION X(2),COV(2,2),MAT(2,2),XW,YW,DW,XC,YC,ZC,SIGMA, - XC1,YC1,ZC1,C,S,FCENT,FC(3),ST0,ST1,ST2,DGMLT2,SIG1,SIG2,DET INTEGER IFAIL,ILOC REAL XW1,YW1,DW1 EXTERNAL DGMLT2,FDIF2N,FDIF2L,FDIF2Q COMMON /DF2DAT/ MAT,SIG1,SIG2,DET,XW,YW,DW,XC,YC,ZC,C,S,FCENT *** Assume the routine will work. IFAIL=0 *** Determine a rotation that aligns the cloud with the axes. IF(ABS(COV(1,2)+COV(2,1)).LE.1E-8*ABS(COV(2,2)-COV(1,1)))THEN C=1 S=0 ELSEIF((COV(2,2)-COV(1,1))**2+(COV(1,2)+COV(2,1))**2.GT.0)THEN C=SQRT(0.5*(1+(COV(2,2)-COV(1,1))/ - SQRT((COV(2,2)-COV(1,1))**2+(COV(1,2)+COV(2,1))**2))) S=SIGN(SQRT(1-C**2),COV(1,2)+COV(2,1)) ELSE C=1 S=0 ENDIF *** Rotate the covariance matrix. MAT(1,1)=C**2*COV(1,1)-C*S*COV(1,2)-C*S*COV(2,1)+S**2*COV(2,2) MAT(1,2)=C**2*COV(2,1)-C*S*COV(2,2)+C*S*COV(1,1)-S**2*COV(1,2) MAT(2,1)=C**2*COV(1,2)-C*S*COV(2,2)+C*S*COV(1,1)-S**2*COV(2,1) MAT(2,2)=C**2*COV(2,2)+C*S*COV(1,2)+C*S*COV(2,1)+S**2*COV(1,1) IF(MAT(1,1).LE.0.0.OR.MAT(2,2).LE.0.0)THEN PRINT *,' !!!!!! DLCDIW WARNING : Covariance matrix'// - ' (see below) is 1-dimensional; zero time spread.' PRINT *,' Aligned matrix: ',MAT(1,1),MAT(1,2) PRINT *,' ',MAT(2,1),MAT(2,2) print *,' Raw matrix: ',cov(1,1),cov(1,2) print *,' ',cov(2,1),cov(2,2) print *,' cos/sin: ',c,s print *,' Wire (x,y,d): ',xw1,yw1,dw1 print *,' Cloud (x,y,z): ',xc1,yc1,zc1 SIGMA=0 IFAIL=1 RETURN ENDIF *** Shift wire position to the rotated frame with cloud at (0,0), XW=+C*(XW1-XC1)+S*(YW1-YC1) YW=-S*(XW1-XC1)+C*(YW1-YC1) * simply transfer the wire diameter, DW=DW1 * but keep the original cluster location for speed calculations. XC=XC1 YC=YC1 ZC=ZC1 *** Prepare correlation and marginal distribution. SIG1=SQRT(MAT(1,1)) SIG2=SQRT(MAT(2,2)) DET=MAT(2,2)*MAT(1,1)-MAT(1,2)*MAT(2,1) IF(DET.EQ.0.0)THEN PRINT *,' DLCDIW WARNING : Covariance matrix is singular'// - ' ; time spread set to zero.' SIGMA=0 IFAIL=1 RETURN ENDIF IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCDIW DEBUG : Rotation'', - '' angles: cos='',F10.3,'', sin='',F10.3/25X, - '' Cloud dimensions: ('',E15.8,'','',E15.8,'').'')') - C,S,SIG1,SIG2 *** Compute central velocity. CALL DLCVEL(XC,YC,ZC,FC,-1.0,1,ILOC) FCENT=SQRT(FC(1)**2+FC(2)**2) IF(MDF2.EQ.2.AND.FCENT.LE.0)THEN PRINT *,' DLCDIW WARNING : Central velocity is zero;'// - ' time spread set to zero.' SIGMA=0 IFAIL=1 RETURN ENDIF *** Perform integration. ST0=DGMLT2(FDIF2N,-5*SIG2,+5*SIG2,5,6,X) ST1=DGMLT2(FDIF2L,-5*SIG2,+5*SIG2,5,6,X) ST2=DGMLT2(FDIF2Q,-5*SIG2,+5*SIG2,5,6,X) IF(LDEBUG)THEN WRITE(LUNOUT,'('' ++++++ DLCDIW DEBUG : S0='',E15.8, - '' S1='',E15.8,'' S2='',E15.8)') ST0,ST1,ST2 ENDIF IF(ST1**2.LE.ST2*ST0)THEN SIGMA=SQRT(ST2-ST1**2/ST0)/ST0 ELSE PRINT *,' DLCDIW WARNING : Time variance < 0'// - ' ; time spread set to zero.' SIGMA=0 IFAIL=1 ENDIF END +DECK,FDIF2N. SUBROUTINE FDIF2N(M,U2,F2,X) *----------------------------------------------------------------------- * FDIF2N - One of 2 auxiliary routines for integrating W * (Last changed on 26/ 2/95.) *----------------------------------------------------------------------- C implicit none IMPLICIT DOUBLE PRECISION(A-H,O-Z) DOUBLE PRECISION U2(*),F2(*),X(2),MAT(2,2) COMMON /DF2DAT/ MAT,SIG1,SIG2,DET,XW,YW,DW,XC,YC,ZC,C,S,FCENT EXTERNAL FDIF1N,DGMLT1 *** Loop over the positions. DO 10 L=1,M X(2)=U2(L) F2(L)=DGMLT1(FDIF1N,-5*SIG1,5*SIG1,5,6,X) 10 CONTINUE END +DECK,FDIF1N. SUBROUTINE FDIF1N(M,U1,F1,X) *----------------------------------------------------------------------- * FDIF1N - One of 2 auxiliary routines for integrating t_mean * (Last changed on 26/ 2/95.) *----------------------------------------------------------------------- C implicit none IMPLICIT DOUBLE PRECISION(A-H,O-Z) +SEQ,CONSTANTS. DOUBLE PRECISION U1(*),F1(*),X(2),MAT(2,2) COMMON /DF2DAT/ MAT,SIG1,SIG2,DET,XW,YW,DW,XC,YC,ZC,C,S,FCENT *** Loop over the positions. DO 10 L=1,M X(1)=U1(L) ARG=-0.5*(X(1)**2*MAT(2,2)+X(2)**2*MAT(1,1)- - 2*X(1)*X(2)*MAT(1,2))/DET IF(ARG.LT.-50)THEN W=0.0 ELSE W=EXP(ARG)/(2*PI*SQRT(DET)) ENDIF F1(L)=W 10 CONTINUE END +DECK,FDIF2L. SUBROUTINE FDIF2L(M,U2,F2,X) *----------------------------------------------------------------------- * FDIF2L - One of 2 auxiliary routines for integrating t_mean * (Last changed on 25/ 2/95.) *----------------------------------------------------------------------- C implicit none IMPLICIT DOUBLE PRECISION(A-H,O-Z) DOUBLE PRECISION U2(*),F2(*),X(2),MAT(2,2) COMMON /DF2DAT/ MAT,SIG1,SIG2,DET,XW,YW,DW,XC,YC,ZC,C,S,FCENT EXTERNAL FDIF1L,DGMLT1 *** Loop over the positions. DO 10 L=1,M * Copy the y component of the position. X(2)=U2(L) * Evaluate the integral over x. F2(L)=DGMLT1(FDIF1L,-5*SIG1,5*SIG1,5,6,X) 10 CONTINUE END +DECK,FDIF1L. SUBROUTINE FDIF1L(M,U1,F1,X) *----------------------------------------------------------------------- * FDIF1L - One of 2 auxiliary routines for integrating t_mean * (Last changed on 23/ 5/95.) *----------------------------------------------------------------------- C implicit none IMPLICIT DOUBLE PRECISION(A-H,O-Z) +SEQ,DIMENSIONS. +SEQ,CONSTANTS. +SEQ,PRINTPLOT. +SEQ,DRIFTLINE. DOUBLE PRECISION U1(*),F1(*),X(2),MAT(2,2),FD(3) COMMON /DF2DAT/ MAT,SIG1,SIG2,DET,XW,YW,DW,XC,YC,ZC,C,S,FCENT *** Loop over the positions. DO 10 L=1,M * Copy the x component of the position. X(1)=U1(L) * Evaluate the Gaussian weight factor. ARG=-0.5*(X(1)**2*MAT(2,2)+X(2)**2*MAT(1,1)- - X(2)*X(1)*MAT(1,2)-X(1)*X(2)*MAT(2,1))/DET IF(ARG.LT.-50)THEN W=0.0 ELSE W=EXP(ARG)/(2*PI*SQRT(DET)) ENDIF * Evaluate the drift velocity. IF(MDF2.EQ.1)THEN CALL DLCVEL(XC+C*X(1)-S*X(2),YC+S*X(1)+C*X(2),ZC, - FD,-1.0,1,ILOC) VD=SQRT(FD(1)**2+FD(2)**2) ELSE ILOC=0 VD=FCENT ENDIF * Evaluate distance to the wire surface. DD=SQRT((X(1)-XW)**2+(X(2)-YW)**2)-DW/2 * Evaluate the weighting function. IF(VD.GT.0.AND.DD.GT.0)THEN F1(L)=W*DD/VD ELSE IF(VD.LE.0.AND.LDEBUG)WRITE(LUNOUT,'('' ++++++ FDIF1L'', - '' DEBUG : (x,y)=('',E15.8,'','',E15.8,''), Vd='', - E15.8,'', loc='',I3)') - XC+C*X(1)-S*X(2),YC+S*X(1)+C*X(2),VD,ILOC IF(DD.LE.0.AND.LDEBUG)WRITE(LUNOUT,'('' ++++++ FDIF1L'', - '' DEBUG : (x,y)=('',E15.8,'','',E15.8,''), d='', - E15.8)') XC+C*X(1)-S*X(2),YC+S*X(1)+C*X(2),DD F1(L)=0 ENDIF 10 CONTINUE END +DECK,FDIF2Q. SUBROUTINE FDIF2Q(M,U2,F2,X) *----------------------------------------------------------------------- * FDIF2Q - One of 2 auxiliary routines for integrating t**2_mean * (Last changed on 25/ 2/95.) *----------------------------------------------------------------------- C implicit none IMPLICIT DOUBLE PRECISION(A-H,O-Z) DOUBLE PRECISION U2(*),F2(*),X(2),MAT(2,2) COMMON /DF2DAT/ MAT,SIG1,SIG2,DET,XW,YW,DW,XC,YC,ZC,C,S,FCENT EXTERNAL FDIF1Q,DGMLT1 *** Loop over the positions. DO 10 L=1,M * Copy the y component of the position. X(2)=U2(L) * Evaluate the integral over x. F2(L)=DGMLT1(FDIF1Q,-5*SIG1,5*SIG1,5,6,X) 10 CONTINUE END +DECK,FDIF1Q. SUBROUTINE FDIF1Q(M,U1,F1,X) *----------------------------------------------------------------------- * FDIF1Q - One of 2 auxiliary routines for integrating t**2_mean * (Last changed on 26/ 2/95.) *----------------------------------------------------------------------- C implicit none IMPLICIT DOUBLE PRECISION(A-H,O-Z) +SEQ,DIMENSIONS. +SEQ,CONSTANTS. +SEQ,PRINTPLOT. +SEQ,DRIFTLINE. DOUBLE PRECISION U1(*),F1(*),X(2),MAT(2,2),FD(3) COMMON /DF2DAT/ MAT,SIG1,SIG2,DET,XW,YW,DW,XC,YC,ZC,C,S,FCENT *** Loop over the positions. DO 10 L=1,M * Copy the x component of the position. X(1)=U1(L) * Evaluate the Gaussian weight factor. ARG=-0.5*(X(1)**2*MAT(2,2)+X(2)**2*MAT(1,1)- - X(2)*X(1)*MAT(1,2)-X(1)*X(2)*MAT(2,1))/DET IF(ARG.LT.-50)THEN W=0.0 ELSE W=EXP(ARG)/(2*PI*SQRT(DET)) ENDIF * Evaluate the drift velocity. IF(MDF2.EQ.1)THEN CALL DLCVEL(XC+C*X(1)-S*X(2),YC+S*X(1)+C*X(2),ZC, - FD,-1.0,1,ILOC) VD=SQRT(FD(1)**2+FD(2)**2) ELSE VD=FCENT ILOC=0 ENDIF * Evaluate distance to the wire surface. DD=SQRT((X(1)-XW)**2+(X(2)-YW)**2)-DW/2 * Evaluate the weighting function. IF(VD.GT.0.AND.DD.GT.0)THEN F1(L)=W*(DD/VD)**2 ELSE IF(VD.LE.0.AND.LDEBUG)WRITE(LUNOUT,'('' ++++++ FDIF1Q'', - '' DEBUG : (x,y)=('',E15.8,'','',E15.8,''), Vd='', - E15.8,'', loc='',I3)') - XC+C*X(1)-S*X(2),YC+S*X(1)+C*X(2),VD,ILOC IF(DD.LE.0.AND.LDEBUG)WRITE(LUNOUT,'('' ++++++ FDIF1Q'', - '' DEBUG : (x,y)=('',E15.8,'','',E15.8,''), d='', - E15.8)') XC+C*X(1)-S*X(2),YC+S*X(1)+C*X(2),DD F1(L)=0 ENDIF 10 CONTINUE END +DECK,DLCTWN. SUBROUTINE DLCTWN(FACTOR) *----------------------------------------------------------------------- * DLCTWN - Routine returning the multiplication factor for the current * drift line. Uses either DLCDF1 for drift lines that have * been computed with RKF or DLCDF2 for MC drift lines. * integration. * VARIABLES : FACTOR : The multiplication factor. * (Last changed on 22/ 8/99.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,DRIFTLINE. +SEQ,CELLDATA. +SEQ,PRINTPLOT. REAL FACTOR *** Projected integration ... IF(LAVPRO)THEN CALL DLCTW2(FACTOR) *** Integration over the true step length ... ELSE CALL DLCTW1(FACTOR) ENDIF END +DECK,DLCTW1. SUBROUTINE DLCTW1(FACTOR) *----------------------------------------------------------------------- * DLCTW1 - Routine returning the multiplication factor for the current * drift line. The routine uses an adaptive Simpson style * integration. * VARIABLES : ALFA. : Townsend coefficients (1,2 end; M middle). * ALFINT : Integral of the Townsend coefficient. * FACTOR : The multiplication factor. * (Last changed on 5/ 2/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,DRIFTLINE. +SEQ,CELLDATA. +SEQ,PRINTPLOT. REAL TWNVEC(MXLIST),ALFA1,ALFA2,ALFAM,FACTOR,EXM,EYM,EZM,ETOTM, - EX,EY,EZ,ETOT,BX,BY,BZ,BTOT,VOLT,GASTWN,DRES, - BXM,BYM,BZM,BTOTM DOUBLE PRECISION XAUX1,XAUX2,YAUX1,YAUX2,STEP,ALFINT, - XPOS1,XPOS2,XPOSM,YPOS1,YPOS2,YPOSM,ZPOSM,ZPOS1,ZPOS2, - TOTSTP,CRUDE,STACK(MXSTCK,4) INTEGER LOCVEC(MXLIST),ISTACK,NSTACK,ILOCRS,NFC,ILOCM,IU,ILOC EXTERNAL GASTWN *** Identify the routine IF(LIDENT)PRINT *,' /// ROUTINE DLCTW1 ///' *** Return straight away if there is only one data point. IF(NU.LE.1)THEN FACTOR=1.0 RETURN ENDIF *** Obtain a very rough estimate of the result. CRUDE=0.0 DO 100 IU=1,NU CALL EFIELD(REAL(XU(IU)),REAL(YU(IU)),REAL(ZU(IU)), - EX,EY,EZ,ETOT,VOLT,0,ILOC) CALL BFIELD(REAL(XU(IU)),REAL(YU(IU)),REAL(ZU(IU)), - BX,BY,BZ,BTOT) * Cheat in case the point is located inside a wire. IF(ILOC.GT.0.AND.ILOC.LE.MXWIRE)THEN DRES=D(ILOC) ILOCRS=ILOC D(ILOCRS)=0.0 CALL EFIELD(REAL(XU(IU)),REAL(YU(IU)),REAL(ZU(IU)), - EX,EY,EZ,ETOT,VOLT,0,ILOC) CALL BFIELD(REAL(XU(IU)),REAL(YU(IU)),REAL(ZU(IU)), - BX,BY,BZ,BTOT) D(ILOCRS)=DRES IF(LDEBUG)PRINT *,' ++++++ DLCTW1 DEBUG : Drift-line', - ' data point in wire ',ILOCRS,' detected; d=0 fix.' ENDIF * In case this didn't help, just log the failure. LOCVEC(IU)=ILOC IF(POLAR)THEN TWNVEC(IU)=GASTWN(EX/EXP(REAL(XU(IU))),EY/EXP(REAL(XU(IU))), - EZ,BX,BY,BZ) IF(IU.GT.1)THEN CALL CF2RTC(XU(IU),YU(IU),XAUX1,YAUX1,1) CALL CF2RTC(XU(IU-1),YU(IU-1),XAUX2,YAUX2,1) STEP=SQRT((XAUX2-XAUX1)**2+(YAUX2-YAUX1)**2+ - (ZU(IU)-ZU(IU-1))**2) ENDIF ELSE TWNVEC(IU)=GASTWN(EX,EY,EZ,BX,BY,BZ) IF(IU.GT.1)STEP=SQRT((XU(IU)-XU(IU-1))**2+ - (YU(IU)-YU(IU-1))**2+(ZU(IU)-ZU(IU-1))**2) ENDIF IF(IU.GT.1)CRUDE=CRUDE+STEP*(TWNVEC(IU)+TWNVEC(IU-1))/2.0 100 CONTINUE NFC=NU *** Print a heading for the debugging output. IF(LDEBUG)THEN PRINT *,' ++++++ DLCTW1 DEBUG : Townsend integration', - ' debugging output follows:' PRINT *,' ' PRINT *,' IU loc XU(IU)'// - ' YU(IU)'// - ' ZU(IU)'// - ' number of electrons' PRINT *,' [cm]'// - ' [cm]'// - ' [cm]'// - ' [numeric]' PRINT *,' ' PRINT '(2(2X,I3),3(5X,E15.8))',1,LOCVEC(1),XU(1),YU(1),ZU(1) ENDIF *** Initialise the sum ALFINT ALFINT=0.0 *** Loop over the whole drift-line. ISTACK=0 DO 10 IU=1,NU-1 IF(LOCVEC(IU).NE.0.OR.LOCVEC(IU+1).NE.0)GOTO 30 * Initial values for the position. XPOS1=XU(IU) YPOS1=YU(IU) ZPOS1=ZU(IU) ALFA1=TWNVEC(IU) XPOS2=XU(IU+1) YPOS2=YU(IU+1) ZPOS2=ZU(IU+1) ALFA2=TWNVEC(IU+1) * Calculate the total steplength, in Cartesian coordinates. IF(POLAR)THEN CALL CF2RTC(XPOS1,YPOS1,XAUX1,YAUX1,1) CALL CF2RTC(XPOS2,YPOS2,XAUX2,YAUX2,1) TOTSTP=SQRT((XAUX2-XAUX1)**2+(YAUX2-YAUX1)**2+ - (ZPOS2-ZPOS1)**2) ELSE TOTSTP=SQRT((XPOS2-XPOS1)**2+(YPOS2-YPOS1)**2+ - (ZPOS2-ZPOS1)**2) ENDIF * Return at this point of further refinement is needed. NSTACK=0 20 CONTINUE * Set the new middle point, to be used for comparison. XPOSM=0.5*(XPOS1+XPOS2) YPOSM=0.5*(YPOS1+YPOS2) ZPOSM=0.5*(ZPOS1+ZPOS2) * Compute the field and the Townsend coeff. at the middle point. CALL EFIELD(REAL(XPOSM),REAL(YPOSM),REAL(ZPOSM), - EXM,EYM,EZM,ETOTM,VOLT,0,ILOCM) CALL BFIELD(REAL(XPOSM),REAL(YPOSM),REAL(ZPOSM), - BXM,BYM,BZM,BTOTM) NFC=NFC+1 * Cheat in case the point is located inside a wire. IF(ILOCM.GT.0.AND.ILOCM.LE.MXWIRE)THEN DRES=D(ILOCM) ILOCRS=ILOCM D(ILOCRS)=0.0 CALL EFIELD(REAL(XPOSM),REAL(YPOSM),REAL(ZPOSM), - EXM,EYM,EZM,ETOTM,VOLT,0,ILOCM) CALL BFIELD(REAL(XPOSM),REAL(YPOSM),REAL(ZPOSM), - BXM,BYM,BZM,BTOTM) NFC=NFC+1 D(ILOCRS)=DRES IF(LDEBUG)PRINT *,' ++++++ DLCTW1 DEBUG : Intermediate', - ' point in wire ',ILOCRS,' detected; d=0 fix.' ENDIF * Skip this step in case the ILOC is not due to a wire. IF(ILOCM.NE.0)GOTO 30 IF(POLAR)THEN ALFAM=GASTWN(EXM/EXP(REAL(XPOSM)),EYM/EXP(REAL(XPOSM)),EZM, - BXM,BYM,BZM) ELSE ALFAM=GASTWN(EXM,EYM,EZM,BXM,BYM,BZM) ENDIF * Compare first and second order estimates, divide if too large. IF(NSTACK.LT.MIN(MXSTCK,MXTWNS).AND.EPSTWI*CRUDE.LT. - TOTSTP*ABS(ALFA1-2.0*ALFAM+ALFA2)/3.0)THEN NSTACK=NSTACK+1 ISTACK=MAX(ISTACK,NSTACK) STACK(NSTACK,1)=XPOS2 STACK(NSTACK,2)=YPOS2 STACK(NSTACK,3)=ZPOS2 STACK(NSTACK,4)=ALFA2 XPOS2=XPOSM YPOS2=YPOSM ZPOS2=ZPOSM ALFA2=ALFAM GOTO 20 * No further subdevision is required, transform polar coordinates. ELSE * Make sure the distances are measured in cartesian coordinates. IF(POLAR)THEN CALL CF2RTC(XPOS1,YPOS1,XAUX1,YAUX1,1) CALL CF2RTC(XPOS2,YPOS2,XAUX2,YAUX2,1) STEP=SQRT((XAUX2-XAUX1)**2+(YAUX2-YAUX1)**2+ - (ZPOS2-ZPOS1)**2) ELSE STEP=SQRT((XPOS2-XPOS1)**2+(YPOS2-YPOS1)**2+ - (ZPOS2-ZPOS1)**2) ENDIF * Add the new term to the integral. ALFINT=ALFINT+STEP*(ALFA1+4.0*ALFAM+ALFA2)/6.0 * Continue with the next segment (if complete) or the next subsegment. XPOS1=XPOS2 YPOS1=YPOS2 ZPOS1=ZPOS2 ALFA1=ALFA2 IF(NSTACK.GT.0)THEN XPOS2=STACK(NSTACK,1) YPOS2=STACK(NSTACK,2) ZPOS2=STACK(NSTACK,3) ALFA2=STACK(NSTACK,4) NSTACK=NSTACK-1 GOTO 20 ENDIF ENDIF * Continue with the next segment. 30 CONTINUE * Print some debugging output. IF(LDEBUG)PRINT '(2I5,4(5X,E15.8))',IU+1,LOCVEC(IU+1),XU(IU+1), - YU(IU+1),ZU(IU+1),EXP(MIN(50.0D0,ALFINT)) 10 CONTINUE *** Finally take the exponential. IF(ALFINT.LT.0.0)THEN FACTOR=1.0 ELSEIF(ALFINT.LT.46.0)THEN FACTOR=EXP(ALFINT) ELSE PRINT *,' !!!!!! DLCTW1 WARNING : The Townsend coefficient', - ' can not be integrated without overflow; set to 1E20.' FACTOR=1.0E20 ENDIF IF(LDEBUG)THEN PRINT *,' ++++++ DLCTW1 DEBUG : EFIELD calls: ',NFC, - ', deepest stack: ',ISTACK PRINT *,' Final log estimate: ', - ALFINT,' (crude estimate: ',CRUDE,').' ENDIF END +DECK,DLCTW2. SUBROUTINE DLCTW2(FACTOR) *----------------------------------------------------------------------- * DLCTW2 - Routine returning the multiplication factor for the current * drift line projected over the locally mean path. The * routine uses an adaptive Simpson style integration. * VARIABLES : ALFA. : Townsend coefficients (1,2 end; M middle). * ALFINT : Integral of the Townsend coefficient. * FACTOR : The multiplication factor. * (Last changed on 5/ 2/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,DRIFTLINE. +SEQ,CELLDATA. +SEQ,PRINTPLOT. REAL TWNVEC(MXLIST),ALFA1,ALFA2,ALFAM,FACTOR,EXM,EYM,EZM,ETOTM, - EX,EY,EZ,ETOT,VOLT,GASTWN,DRES,SCALE,BX,BY,BZ,BTOT, - BXM,BYM,BZM,BTOTM DOUBLE PRECISION XAUX1,XAUX2,YAUX1,YAUX2,STEP,ALFINT, - XPOS1,XPOS2,XPOSM,YPOS1,YPOS2,YPOSM,ZPOSM,ZPOS1,ZPOS2, - TOTSTP,CRUDE,STACK(MXSTCK,4),VD(3) INTEGER LOCVEC(MXLIST),ISTACK,NSTACK,ILOCRS,NFC,ILOCM,IU,ILOC EXTERNAL GASTWN *** Identify the routine IF(LIDENT)PRINT *,' /// ROUTINE DLCTW2 ///' *** Return straight away if there is only one data point. IF(NU.LE.1)THEN FACTOR=1.0 RETURN ENDIF *** Obtain a very rough estimate of the result. CRUDE=0.0 DO 100 IU=1,NU CALL EFIELD(REAL(XU(IU)),REAL(YU(IU)),REAL(ZU(IU)), - EX,EY,EZ,ETOT,VOLT,0,ILOC) CALL BFIELD(REAL(XU(IU)),REAL(YU(IU)),REAL(ZU(IU)), - BX,BY,BZ,BTOT) * Cheat in case the point is located inside a wire. IF(ILOC.GT.0.AND.ILOC.LE.MXWIRE)THEN DRES=D(ILOC) ILOCRS=ILOC D(ILOCRS)=0.0 CALL EFIELD(REAL(XU(IU)),REAL(YU(IU)),REAL(ZU(IU)), - EX,EY,EZ,ETOT,VOLT,0,ILOC) CALL BFIELD(REAL(XU(IU)),REAL(YU(IU)),REAL(ZU(IU)), - BX,BY,BZ,BTOT) D(ILOCRS)=DRES IF(LDEBUG)PRINT *,' ++++++ DLCTW2 DEBUG : Drift-line', - ' data point in wire ',ILOCRS,' detected; d=0 fix.' ENDIF * In case this didn't help, just log the failure. LOCVEC(IU)=ILOC * Compute projection of the path. IF(IU.GT.1)THEN CALL DLCVEL((XU(IU-1)+XU(IU))/2,(YU(IU-1)+YU(IU))/2, - (ZU(IU-1)+ZU(IU))/2,VD,QPCHAR,IPTYPE,ILOC) IF(((XU(IU)-XU(IU-1))**2+(YU(IU)-YU(IU-1))**2+ - (ZU(IU)-ZU(IU-1))**2)* - (VD(1)**2+VD(2)**2+VD(3)**2).LE.0)THEN SCALE=0 ELSE SCALE=((XU(IU)-XU(IU-1))*VD(1)+ - (YU(IU)-YU(IU-1))*VD(2)+(ZU(IU)-ZU(IU-1))*VD(3))/ - SQRT(((XU(IU)-XU(IU-1))**2+(YU(IU)-YU(IU-1))**2+ - (ZU(IU)-ZU(IU-1))**2)* - (VD(1)**2+VD(2)**2+VD(3)**2)) ENDIF C print *,' Scale = ',scale C print *,' x: ',xu(iu-1),xu(iu),vd(1) C print *,' y: ',yu(iu-1),yu(iu),vd(2) C print *,' z: ',zu(iu-1),zu(iu),vd(3) ENDIF * Compute Townsend coefficients and step length. IF(POLAR)THEN TWNVEC(IU)=GASTWN(EX/EXP(REAL(XU(IU))),EY/EXP(REAL(XU(IU))), - EZ,BX,BY,BZ) IF(IU.GT.1)THEN CALL CF2RTC(XU(IU),YU(IU),XAUX1,YAUX1,1) CALL CF2RTC(XU(IU-1),YU(IU-1),XAUX2,YAUX2,1) STEP=SQRT((XAUX2-XAUX1)**2+(YAUX2-YAUX1)**2+ - (ZU(IU)-ZU(IU-1))**2) ENDIF ELSE TWNVEC(IU)=GASTWN(EX,EY,EZ,BX,BY,BZ) IF(IU.GT.1)STEP=SQRT((XU(IU)-XU(IU-1))**2+ - (YU(IU)-YU(IU-1))**2+(ZU(IU)-ZU(IU-1))**2) ENDIF IF(IU.GT.1)CRUDE=CRUDE+STEP*SCALE*(TWNVEC(IU)+TWNVEC(IU-1))/2.0 100 CONTINUE NFC=NU *** Ensure that the crude sum is positive. IF(CRUDE.LT.0)THEN PRINT *,' !!!!!! DLCTW2 WARNING : Negative Townsend sum'// - ' in 1st order ; multiplication set to 1.' FACTOR=1 RETURN ELSEIF(CRUDE.EQ.0)THEN FACTOR=1 RETURN ENDIF *** Print a heading for the debugging output. IF(LDEBUG)THEN PRINT *,' ++++++ DLCTW2 DEBUG : Townsend integration', - ' debugging output follows:' PRINT *,' ' PRINT *,' IU loc XU(IU)'// - ' YU(IU)'// - ' ZU(IU)'// - ' number of electrons' PRINT *,' [cm]'// - ' [cm]'// - ' [cm]'// - ' [numeric]' PRINT *,' ' PRINT '(2(2X,I3),3(5X,E15.8))',1,LOCVEC(1),XU(1),YU(1),ZU(1) ENDIF *** Initialise the sum ALFINT ALFINT=0.0 *** Loop over the whole drift-line. ISTACK=0 DO 10 IU=1,NU-1 IF(LOCVEC(IU).NE.0.OR.LOCVEC(IU+1).NE.0)GOTO 30 * Initial values for the position. XPOS1=XU(IU) YPOS1=YU(IU) ZPOS1=ZU(IU) ALFA1=TWNVEC(IU) XPOS2=XU(IU+1) YPOS2=YU(IU+1) ZPOS2=ZU(IU+1) ALFA2=TWNVEC(IU+1) * Calculate the total steplength, in Cartesian coordinates. IF(POLAR)THEN CALL CF2RTC(XPOS1,YPOS1,XAUX1,YAUX1,1) CALL CF2RTC(XPOS2,YPOS2,XAUX2,YAUX2,1) TOTSTP=SQRT((XAUX2-XAUX1)**2+(YAUX2-YAUX1)**2+ - (ZPOS2-ZPOS1)**2) ELSE TOTSTP=SQRT((XPOS2-XPOS1)**2+(YPOS2-YPOS1)**2+ - (ZPOS2-ZPOS1)**2) ENDIF * Compute projection of the path. CALL DLCVEL((XU(IU+1)+XU(IU))/2,(YU(IU+1)+YU(IU))/2, - (ZU(IU+1)+ZU(IU))/2,VD,QPCHAR,IPTYPE,ILOC) IF(((XU(IU+1)-XU(IU))**2+(YU(IU+1)-YU(IU))**2+ - (ZU(IU+1)-ZU(IU))**2)* - (VD(1)**2+VD(2)**2+VD(3)**2).LE.0)THEN SCALE=0 ELSE SCALE=((XU(IU+1)-XU(IU))*VD(1)+ - (YU(IU+1)-YU(IU))*VD(2)+(ZU(IU+1)-ZU(IU))*VD(3))/ - SQRT(((XU(IU+1)-XU(IU))**2+(YU(IU+1)-YU(IU))**2+ - (ZU(IU+1)-ZU(IU))**2)* - (VD(1)**2+VD(2)**2+VD(3)**2)) ENDIF C print *,' Scale = ',scale * Return at this point of further refinement is needed. NSTACK=0 20 CONTINUE * Set the new middle point, to be used for comparison. XPOSM=0.5*(XPOS1+XPOS2) YPOSM=0.5*(YPOS1+YPOS2) ZPOSM=0.5*(ZPOS1+ZPOS2) * Compute the field and the Townsend coeff. at the middle point. CALL EFIELD(REAL(XPOSM),REAL(YPOSM),REAL(ZPOSM), - EXM,EYM,EZM,ETOTM,VOLT,0,ILOCM) CALL BFIELD(REAL(XPOSM),REAL(YPOSM),REAL(ZPOSM), - BXM,BYM,BZM,BTOTM) NFC=NFC+1 * Cheat in case the point is located inside a wire. IF(ILOCM.GT.0.AND.ILOCM.LE.MXWIRE)THEN DRES=D(ILOCM) ILOCRS=ILOCM D(ILOCRS)=0.0 CALL EFIELD(REAL(XPOSM),REAL(YPOSM),REAL(ZPOSM), - EXM,EYM,EZM,ETOTM,VOLT,0,ILOCM) CALL BFIELD(REAL(XPOSM),REAL(YPOSM),REAL(ZPOSM), - BXM,BYM,BZM,BTOTM) NFC=NFC+1 D(ILOCRS)=DRES IF(LDEBUG)PRINT *,' ++++++ DLCTW2 DEBUG : Intermediate', - ' point in wire ',ILOCRS,' detected; d=0 fix.' ENDIF * Skip this step in case the ILOC is not due to a wire. IF(ILOCM.NE.0)GOTO 30 IF(POLAR)THEN ALFAM=GASTWN(EXM/EXP(REAL(XPOSM)),EYM/EXP(REAL(XPOSM)),EZM, - BXM,BYM,BZM) ELSE ALFAM=GASTWN(EXM,EYM,EZM,BXM,BYM,BZM) ENDIF * Compare first and second order estimates, divide if too large. IF(NSTACK.LT.MIN(MXSTCK,MXTWNS).AND.EPSTWI*CRUDE.LT. - TOTSTP*ABS(ALFA1-2.0*ALFAM+ALFA2)/3.0)THEN NSTACK=NSTACK+1 ISTACK=MAX(ISTACK,NSTACK) STACK(NSTACK,1)=XPOS2 STACK(NSTACK,2)=YPOS2 STACK(NSTACK,3)=ZPOS2 STACK(NSTACK,4)=ALFA2 XPOS2=XPOSM YPOS2=YPOSM ZPOS2=ZPOSM ALFA2=ALFAM GOTO 20 * No further subdevision is required, transform polar coordinates. ELSE * Make sure the distances are measured in cartesian coordinates. IF(POLAR)THEN CALL CF2RTC(XPOS1,YPOS1,XAUX1,YAUX1,1) CALL CF2RTC(XPOS2,YPOS2,XAUX2,YAUX2,1) STEP=SQRT((XAUX2-XAUX1)**2+(YAUX2-YAUX1)**2+ - (ZPOS2-ZPOS1)**2) ELSE STEP=SQRT((XPOS2-XPOS1)**2+(YPOS2-YPOS1)**2+ - (ZPOS2-ZPOS1)**2) ENDIF * Add the new term to the integral. ALFINT=ALFINT+STEP*SCALE*(ALFA1+4.0*ALFAM+ALFA2)/6.0 * Continue with the next segment (if complete) or the next subsegment. XPOS1=XPOS2 YPOS1=YPOS2 ZPOS1=ZPOS2 ALFA1=ALFA2 IF(NSTACK.GT.0)THEN XPOS2=STACK(NSTACK,1) YPOS2=STACK(NSTACK,2) ZPOS2=STACK(NSTACK,3) ALFA2=STACK(NSTACK,4) NSTACK=NSTACK-1 GOTO 20 ENDIF ENDIF * Continue with the next segment. 30 CONTINUE * Print some debugging output. IF(LDEBUG)PRINT '(2I5,4(5X,E15.8))',IU+1,LOCVEC(IU+1),XU(IU+1), - YU(IU+1),ZU(IU+1),EXP(MIN(50.0D0,ALFINT)) 10 CONTINUE *** Finally take the exponential. IF(ALFINT.LT.0.0)THEN FACTOR=1.0 ELSEIF(ALFINT.LT.46.0)THEN FACTOR=EXP(ALFINT) ELSE PRINT *,' !!!!!! DLCTW2 WARNING : The Townsend coefficient', - ' can not be integrated without overflow; set to 1E20.' FACTOR=1.0E20 ENDIF IF(LDEBUG)THEN PRINT *,' ++++++ DLCTW2 DEBUG : EFIELD calls: ',NFC, - ', deepest stack: ',ISTACK PRINT *,' Final log estimate: ', - ALFINT,' (crude estimate: ',CRUDE,').' ENDIF END +DECK,DLCPHI. SUBROUTINE DLCPHI(PHI) *----------------------------------------------------------------------- * DLCPHI - Computes the incidence angle of a drift line on an * electrode. * VARIABLES : PHI - Incidence angle. * (Last changed on 20/ 5/99.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,SOLIDS. +SEQ,PRINTPLOT. +SEQ,DRIFTLINE. REAL PHI,XW,YW DOUBLE PRECISION X0,Y0,Z0,CT,ST,CP,SP,UU,VV INTEGER IW,ISOLID,IREF *** Deal with wires. IF(ISTAT.GE.1.AND.ISTAT.LE.NWIRE)THEN IW=ISTAT PHI=ATAN2(REAL(YU(NU))-Y(IW),REAL(XU(NU)-X(IW))) *** Deal with wire replicas. ELSEIF(ISTAT.GE.MXWIRE+1.AND.ISTAT.LE.MXWIRE+NWIRE)THEN IW=ISTAT-MXWIRE XW=X(IW) IF(PERX)XW=XW+SX*ANINT((REAL(XU(NU))-XW)/SX) YW=Y(IW) IF(PERY)YW=YW+SY*ANINT((REAL(YU(NU))-YW)/SY) PHI=ATAN2(REAL(YU(NU))-YW,REAL(XU(NU))-XW) *** Deal with solids. ELSEIF(ISTAT.GE.2*MXWIRE+1.AND.ISTAT.LE.2*MXWIRE+NSOLID)THEN ISOLID=ISTAT-2*MXWIRE ** Cylinders can be processed in detail. IF(ISOLTP(ISOLID).EQ.1)THEN * Starting point in buffer. IREF=ISTART(ISOLID) IF(IREF.LT.0.OR.IREF+8.GT.MXSBUF)THEN PRINT *,' !!!!!! DLCPHI WARNING : Solid address'// - ' is out of range ; returning reference.' RETURN ENDIF * Obtain parameters of the cylinder. X0=CBUF(IREF+3) Y0=CBUF(IREF+4) Z0=CBUF(IREF+5) CT=CBUF(IREF+10) ST=CBUF(IREF+11) CP=CBUF(IREF+12) SP=CBUF(IREF+13) * Compute the U and V coordinates. UU=+CP*CT*(XU(NU)-X0)+SP*CT*(YU(NU)-Y0)-ST*(ZU(NU)-Z0) VV=-SP *(XU(NU)-X0)+CP* (YU(NU)-Y0) * Compute the angle. IF(UU.NE.0.OR.VV.NE.0)THEN PHI=REAL(ATAN2(VV,UU)) ELSE PHI=0 ENDIF ** Other shapes are not yet processed specially. ELSE PHI=0 ENDIF *** Anything else. ELSE PHI=0 ENDIF END +DECK,DLCTRW. SUBROUTINE DLCTRW *----------------------------------------------------------------------- * DLCTRW - This routine writes the data on a track to an external * dataset for future use. This routine writes its data * instantly, not delayed like most other WRITE-routines. * VARIABLES : * (Last changed on 30/ 8/97.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,GASDATA. +SEQ,PRINTPLOT. +SEQ,SIGNALDATA. +SEQ,PARAMETERS. CHARACTER*(MXINCH) STRING CHARACTER*(MXNAME) FILE CHARACTER*29 REMARK CHARACTER*8 TIME,DATE,MEMBER LOGICAL EXMEMB +SELF,IF=SAVE. SAVE FILE,NCFILE,MEMBER,NCMEMB,REMARK,NCREM +SELF. *** Identify the routine. IF(LIDENT)PRINT *,' /// ROUTINE DLCTRW ///' *** Return right away if no track has been set. IF(.NOT.TRASET)THEN PRINT *,' !!!!!! DLCTRW WARNING : No track data present,'// - ' first call PREPARE-TRACK ; nothing written.' RETURN ENDIF *** Set the file name etc. FILE=' ' NCFILE=1 MEMBER='< none >' NCMEMB=8 REMARK='none' NCREM=4 * First decode the argument string. CALL INPNUM(NWORD) * Make sure there is at least one argument. IF(NWORD.EQ.1)THEN PRINT *,' !!!!!! DLCTRW WARNING : WRITE takes at least 1'// - ' argument (a dataset name); data will not be written.' RETURN * Check whether keywords have been used. ELSEIF(INPCMP(2,'D#ATASET')+INPCMP(2,'R#EMARK').NE.0)THEN INEXT=2 DO 10 I=2,NWORD IF(I.LT.INEXT)GOTO 10 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 10 CONTINUE * Otherwise the string is interpreted as a file name (+ member name). ELSE CALL INPSTR(2,2,STRING,NCFILE) FILE=STRING IF(NWORD.GE.3)THEN CALL INPSTR(3,3,STRING,NCMEMB) MEMBER=STRING ENDIF IF(NWORD.GE.4)THEN CALL INPSTR(4,NWORD,STRING,NCREM) REMARK=STRING ENDIF ENDIF * Print error messages. CALL INPERR IF(NCFILE.GT.MXNAME)PRINT *,' !!!!!! DLCTRW WARNING : The file', - ' name is truncated to MXNAME (=',MXNAME,') characters.' IF(NCMEMB.GT.8)PRINT *,' !!!!!! DLCTRW WARNING : The member', - ' name is shortened to ',MEMBER,', first 8 characters.' IF(NCREM.GT.29)PRINT *,' !!!!!! DLCTRW 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),'TRACK',EXMEMB) IF(JEXMEM.EQ.2.AND.EXMEMB)THEN PRINT *,' ------ DLCTRW MESSAGE : A copy of the member'// - ' exists; new member will be appended.' ELSEIF(JEXMEM.EQ.3.AND.EXMEMB)THEN PRINT *,' !!!!!! DLCTRW 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 *,' ++++++ DLCTRW 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 *,' !!!!!! DLCTRW WARNING : Opening ',FILE(1:NCFILE), - ' failed ; the tracks data will not be written.' RETURN ENDIF CALL DSNLOG(FILE,'Track data','Sequential','Write ') IF(LDEBUG)PRINT *,' ++++++ DLCTRW 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,'' TRACK '', - 1X,''"'',A29,''"'')') DATE,TIME,MEMBER,REMARK WRITE(12,'(A80)',IOSTAT=IOS,ERR=2010) STRING(1:80) IF(LDEBUG)THEN PRINT *,' ++++++ DLCTRW DEBUG : Dataset heading record:' PRINT *,STRING(1:80) ENDIF * Write some cell information to the dataset for future checks. WRITE(12,'('' Some cell data for checks follows'')',IOSTAT=IOS, - ERR=2010) WRITE(12,'('' CELLID: '',A)',IOSTAT=IOS,ERR=2010) CELLID WRITE(12,'('' NWIRE: '',I10,'' TYPE: '',A3,I2, - '' POLAR: '',L1,'' TUBE: '',L1)', - IOSTAT=IOS,ERR=2010) NWIRE,TYPE,ICTYPE,POLAR,TUBE * Write some gas information to the dataset for future checks. WRITE(12,'('' Some gas data for checks follows'')',IOSTAT=IOS, - ERR=2010) WRITE(12,'('' GASID : '',A)',IOSTAT=IOS,ERR=2010) GASID WRITE(12,'('' NGAS: '',I10,'' GASOK: '',8L1)',IOSTAT=IOS, - ERR=2010) NGAS,(GASOK(I),I=1,8) * Write the track to the dataset. WRITE(12,'('' TRACK: '',6E15.8)',IOSTAT=IOS,ERR=2010) - XT0,YT0,ZT0,XT1,YT1,ZT1 WRITE(12,'('' Principal direction: '',I3)',IOSTAT=IOS,ERR=2010) - ITRMAJ * And write the drifting information to the dataset. WRITE(12,'('' Drifting information follows: '')') WRITE(12,'('' TRAFLG: '',9L1,'' NTRBNK: '',I10)',IOSTAT=IOS, - ERR=2010) (TRAFLG(J),J=1,9),NTRBNK WRITE(12,'('' x [cm] y [cm] z [cm]''/ - '' time [microsec] s [microsec] multiplication'', - '' attachment vector status'', - '' approach angle'')',IOSTAT=IOS,ERR=2010) DO 210 I=1,NTRBNK WRITE(12,'(1X,3E15.8/1X,5E15.8,I10,E15.8)',IOSTAT=IOS,ERR=2010) - (TRABNK(I,J),J=1,7),TRAVEC(I),NINT(TRABNK(I,8)),TRABNK(I,9) 210 CONTINUE *** Close the file after the operation. CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) CALL TIMLOG('Writing track information to a dataset: ') RETURN *** Handle the error conditions. 2010 CONTINUE PRINT *,' ###### DLCTRW ERROR : I/O error while writing to '// - FILE(1:NCFILE)//' via unit 12 ; no track data written.' CALL INPIOS(IOS) CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) RETURN 2030 CONTINUE PRINT *,' ###### DLCTRW ERROR : Dataset '//FILE(1:NCFILE)// - ' unit 12 cannot be closed ; results not predictable' CALL INPIOS(IOS) END +DECK,DLCTRG. SUBROUTINE DLCTRG(IFAIL) *----------------------------------------------------------------------- * DLCTRG - This routine retrieves drifting information for a track * from a dataset. It informs the user if the data don't seem * to belong to the present cell and gas information. * VARIABLES : STRING : Character string that should contain a * description of the dataset being read. * (Last changed on 21/ 4/96.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,GASDATA. +SEQ,PARAMETERS. +SEQ,SIGNALDATA. +SEQ,PRINTPLOT. CHARACTER*(MXCHAR) STRING CHARACTER*80 CELIDR,GASIDR CHARACTER*8 MEMBER CHARACTER*3 TYPER CHARACTER*(MXNAME) FILE LOGICAL DSNCMP,EXIS,POLARR,TUBER,GASOKR(8) EXTERNAL DSNCMP *** Identify the routine, if requested. IF(LIDENT)PRINT *,' /// ROUTINE DLCTRG ///' *** Initialise IFAIL on 1 (i.e. fail). IFAIL=1 FILE=' ' MEMBER='*' NCFILE=8 NCMEMB=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.2)THEN CALL INPSTR(2,2,STRING,NCFILE) FILE=STRING ENDIF * If there's a second argument, it is the member name. IF(NWORD.GE.3)THEN CALL INPSTR(3,3,STRING,NCMEMB) MEMBER=STRING ENDIF * Check the various lengths. IF(NCFILE.GT.MXNAME)THEN PRINT *,' !!!!!! DLCTRG WARNING : The file name is'// - ' truncated to MXNAME (=',MXNAME,') characters.' NCFILE=MIN(NCFILE,MXNAME) ENDIF IF(NCMEMB.GT.8)THEN PRINT *,' !!!!!! DLCTRG WARNING : The member name is'// - ' shortened to ',MEMBER,', first 8 characters.' NCMEMB=MIN(NCMEMB,8) ELSEIF(NCMEMB.LE.0)THEN PRINT *,' !!!!!! DLCTRG 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 *,' !!!!!! DLCTRG 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.3)PRINT *,' !!!!!! DLCTRG 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 *,' !!!!!! DLCTRG WARNING : Opening ',FILE(1:NCFILE), - ' failed ; track data are not read.' RETURN ENDIF CALL DSNLOG(FILE,'Track data','Sequential','Read only ') IF(LDEBUG)PRINT *,' ++++++ DLCTRG 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,'TRACK ',12,EXIS,'RESPECT') IF(.NOT.EXIS)THEN CALL DSNLOC(MEMBER,NCMEMB,'TRACK ',12,EXIS,'IGNORE') IF(EXIS)THEN PRINT *,' ###### DLCTRG ERROR : Track information ', - MEMBER(1:NCMEMB),' has been deleted from ', - FILE(1:NCFILE),'; not read.' ELSE PRINT *,' ###### DLCTRG ERROR : Track information ', - 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. READ(12,'(A80)',END=2000,IOSTAT=IOS,ERR=2010) STRING IF(LDEBUG)THEN PRINT *,' ++++++ DLCTRG DEBUG : Dataset header', - ' record follows:' PRINT *,STRING ENDIF IF(DSNCMP('02-04-96',STRING(11:18)))THEN PRINT *,' !!!!!! DLCTRG 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 member, start with the cell information. READ(12,'(/9X,A)',END=2000,IOSTAT=IOS,ERR=2010) CELIDR READ(12,'(9X,I10,7X,A3,I2,8X,L1,7X,L1)', - END=2000,IOSTAT=IOS,ERR=2010) - NWIRER,TYPER,ICTYPR,POLARR,TUBER * Compare this with the present cell data. IF(CELLID.NE.CELIDR.OR.NWIRE.NE.NWIRER.OR.TYPE.NE.TYPER.OR. - ICTYPE.NE.ICTYPR.OR. - (POLAR.AND..NOT.POLARR).OR. - (.NOT.POLAR.AND.POLARR).OR. - (TUBE.AND..NOT.TUBER).OR. - (.NOT.TUBE.AND.TUBER))THEN PRINT *,' !!!!!! DLCTRG WARNING : The track on the file'// - ' is not' PRINT *,' compatible with your'// - ' current cell.' ENDIF * Next read the gas information. READ(12,'(/9X,A)',END=2000,IOSTAT=IOS,ERR=2010) GASIDR READ(12,'(7X,I10,8X,8L1)',END=2000,IOSTAT=IOS,ERR=2010) - NGASR,(GASOKR(I),I=1,8) * Compare these bits of information with the present information. IGASCH=0 DO 210 I=1,8 IF((GASOK(I).AND..NOT.GASOKR(I)).OR. - (.NOT.GASOK(I).AND.GASOKR(I)))IGASCH=1 210 CONTINUE IF(GASID.NE.GASIDR.OR.NGAS.NE.NGASR.OR.IGASCH.NE.0)THEN PRINT *,' !!!!!! DLCTRG WARNING : The track on the file'// - ' is not' PRINT *,' compatible with your', - ' current gas.' ENDIF * Now reset the TRASET flag. TRASET=.FALSE. * Next pick up the track. READ(12,'(8X,6E15.8)',END=2000,IOSTAT=IOS,ERR=2010) - XT0,YT0,ZT0,XT1,YT1,ZT1 READ(12,'(22X,I3/)',END=2000,IOSTAT=IOS,ERR=2010) ITRMAJ TRFLAG(1)=.TRUE. * And read the track bank information. READ(12,'(9X,9L1,9X,I10//)',END=2000,IOSTAT=IOS,ERR=2010) - (TRAFLG(J),J=1,9),NTRBNK DO 220 I=1,NTRBNK READ(12,'(1X,3E15.8/1X,5E15.8,I10,E15.8)',END=2000,IOSTAT=IOS, - ERR=2010) (TRABNK(I,J),J=1,7),TRAVEC(I),ISTAT,TRABNK(I,9) TRABNK(I,8)=REAL(ISTAT) 220 CONTINUE * Close the file after the operation. CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) *** Things are probably OK, tell calling routine and common block. IFAIL=0 TRASET=.TRUE. *** Register the amount of CPU time used for reading. CALL TIMLOG('Reading track data from a dataset: ') RETURN *** Handle the I/O error conditions. 2000 CONTINUE PRINT *,' ###### DLCTRG ERROR : EOF encountered while reading', - ' ',FILE(1:NCFILE),' from unit 12 ; no track data read.' CALL INPIOS(IOS) CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) RETURN 2010 CONTINUE PRINT *,' ###### DLCTRG ERROR : I/O error while reading ', - FILE(1:NCFILE),' from unit 12 ; no track data read.' CALL INPIOS(IOS) CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) RETURN 2030 CONTINUE PRINT *,' ###### DLCTRG ERROR : Dataset ',FILE(1:NCFILE),' on', - ' unit 12 cannot be closed ; results not predictable.' CALL INPIOS(IOS) END +DECK,DLCTRP. SUBROUTINE DLCTRP(X0,Y0,Z0,X1,Y1,Z1,LDIFF,LTOWN,LATTA,NLTRIN, - TMIN,TMAX,SMIN,SMAX,AMIN,AMAX,BMIN,BMAX,IFAIL) *----------------------------------------------------------------------- * DLCTRP - Prepares a track for interpolation by DLCTRI. * (Last changed on 20/ 5/99.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,SIGNALDATA. +SEQ,CELLDATA. +SEQ,GASDATA. +SEQ,PARAMETERS. +SEQ,DRIFTLINE. +SEQ,PRINTPLOT. C logical ldebug,lident,ldrplt C integer lunout C parameter(ldebug=.true.,lident=.false.,ldrplt=.true.,lunout=6) +SEQ,CONSTANTS. REAL XPL(MXLIST),YPL(MXLIST),X0,Y0,Z0,X1,Y1,Z1, - XX0,YY0,ZZ0,XX1,YY1,ZZ1,XSTART,YSTART,ZSTART,COORD(MXLIST), - TMIN,TMAX,SMIN,SMAX,AMIN,AMAX,BMIN,BMAX,DELTAT,XCL,YCL,ZCL, - TCL,SCL,ACL,BCL,FCL,VXMIN,VYMIN,VXMAX,VYMAX DOUBLE PRECISION XAUX(2),YAUX(2),ZAUX(2) INTEGER NLTRIN,IFAIL,IFAIL1,I,J,IL,ICL,IDMAX,JL,KL,NLTR LOGICAL LDIFF,LTOWN,LATTA *** Identify the routine if requested. IF(LIDENT)PRINT *,' /// ROUTINE DLCTRP ///' *** Assume failure, reset at the end. IFAIL=1 *** Be sure not more than MXLIST tracks are requested. IF(NLTRIN.GT.MXLIST-4.OR.NLTRIN.LT.4)THEN PRINT *,' !!!!!! DLCTRP WARNING : Number of drift lines'// - ' is not in the range [4,MXLIST-4]; no preparation.' RETURN ENDIF *** Initialise the parameters. DO 1 I=1,9 TRAFLG(I)=.TRUE. 1 CONTINUE TRAFLG(5)=LDIFF.AND.GASOK(3) TRAFLG(6)=LTOWN.AND.GASOK(4) TRAFLG(7)=LATTA.AND.GASOK(6) TRASET=.FALSE. NLTR=4*NINT(REAL(NLTRIN)/4.0) IF(NLTR.GT.MXLIST-4)NLTR=4*INT((MXLIST-4)/4.0) DO 2 I=1,MXLIST DO 3 J=1,9 TRABNK(I,J)=0.0 3 CONTINUE 2 CONTINUE *** Cut the track if we're inside a tube. IF(TUBE)THEN CALL CRTUBE(X0,Y0,Z0,X1,Y1,Z1,XX0,YY0,ZZ0,XX1,YY1,ZZ1, - COTUBE,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! DLCTRP WARNING : Track not suitable'// - ' for preparation ; not done.' IFAIL=1 RETURN ENDIF ELSE XX0=X0 XX1=X1 YY0=Y0 YY1=Y1 ZZ0=Z0 ZZ1=Z1 ENDIF *** Generate debugging output. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCTRP DEBUG : TRAFLG='', - 9L1,'' NLTR='',I5)') (TRAFLG(I),I=1,9),NLTR *** Calculate drift lines from the equidistant points on the track. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCTRP DEBUG : List of'', - '' drift-lines from equidistant track points.'')') ** Open a plot frame if the DRIFT-PLOT option is on. IF(LDRPLT)THEN CALL GRCELL(VXMIN,VYMIN,VXMAX,VYMAX, - 'Drift lines for the track table') IF(GASID.NE.' ')CALL GRCOMM(2,'Gas: '//GASID) * Plot the accepting segment as a dashed line. XAUX(1)=X0 YAUX(1)=Y0 ZAUX(1)=Z0 XAUX(2)=X1 YAUX(2)=Y1 ZAUX(2)=Z1 IF(POLAR)CALL CF2CTR(XAUX,YAUX,XAUX,YAUX,2) CALL GRATTS('TRACK','POLYLINE') CALL PLAGPL(2,XAUX,YAUX,ZAUX) ENDIF ** Initialise the track bank with the track given and true start. NTRBNK=2 TRABNK(1,1)=X0 TRABNK(1,2)=Y0 TRABNK(1,3)=Z0 TRABNK(1,8)=-4 TRABNK(2,1)=XX0 TRABNK(2,2)=YY0 TRABNK(2,3)=ZZ0 TRABNK(2,8)=-4 ** Loop along the segment, produce 3*NLTR/4 drift-lines. IF(LDRPLT)CALL GRATTS('E-DRIFT-LINE','POLYLINE') DO 300 IL=1,3*NLTR/4 * Check number of drift-lines. IF(NTRBNK+1.GT.MXLIST)THEN IF(LDEBUG)PRINT *,' ++++++ DLCTRP DEBUG : NTRBNK=MXLIST.' GOTO 390 ENDIF * Calculate a drift-line. XSTART=XX0+REAL(IL-1)*(XX1-XX0)/REAL(3*NLTR/4-1) YSTART=YY0+REAL(IL-1)*(YY1-YY0)/REAL(3*NLTR/4-1) ZSTART=ZZ0+REAL(IL-1)*(ZZ1-ZZ0)/REAL(3*NLTR/4-1) IF(POLAR)CALL CFMCTR(XSTART,YSTART,XSTART,YSTART,1) CALL DLCALC(XSTART,YSTART,ZSTART,-1.0,1) IF(POLAR)CALL CFMRTC(XSTART,YSTART,XSTART,YSTART,1) * Add the new drift-line to the table. NTRBNK=NTRBNK+1 TRABNK(NTRBNK,1)=XSTART TRABNK(NTRBNK,2)=YSTART TRABNK(NTRBNK,3)=ZSTART TRABNK(NTRBNK,4)=REAL(TU(NU)) IF(TRAFLG(5))CALL DLCDIF(TRABNK(NTRBNK,5)) IF(TRAFLG(6))CALL DLCTWN(TRABNK(NTRBNK,6)) IF(TRAFLG(7))CALL DLCATT(TRABNK(NTRBNK,7)) TRABNK(NTRBNK,8)=REAL(ISTAT) CALL DLCPHI(TRABNK(NTRBNK,9)) IF(NINT(TRABNK(NTRBNK,8)).EQ.NINT(TRABNK(NTRBNK-1,8)))THEN IF(TRABNK(NTRBNK,9).GT.TRABNK(NTRBNK-1,9)+PI)THEN TRABNK(NTRBNK,9)=TRABNK(NTRBNK,9)-2*PI ELSEIF(TRABNK(NTRBNK,9).LT.TRABNK(NTRBNK-1,9)-PI)THEN TRABNK(NTRBNK,9)=TRABNK(NTRBNK,9)+2*PI ENDIF ENDIF IF(LDEBUG)WRITE(LUNOUT,'(2X,''(x,y,z)='',3E11.4,'', t='',E11.4, - '', sigma='',E11.4/'' avalanche='',E11.4,'', loss='',E11.4, - '', angle='',E11.4,'', ISTAT='',I4,'',NU='',I3)') - (TRABNK(NTRBNK,J),J=1,7),TRABNK(NTRBNK,9), - NINT(TRABNK(NTRBNK,8)),NU * Plot and print the data if requested. IF(LDRPLT)CALL DLCPLT * Proceed with the next drift-line. 300 CONTINUE ** Complete the bank with the given and true end point. IF(NTRBNK+2.GT.MXLIST)THEN IF(LDEBUG)PRINT *,' ++++++ DLCTRP DEBUG : NTRBNK=MXLIST.' GOTO 390 ENDIF TRABNK(NTRBNK+1,1)=XX1 TRABNK(NTRBNK+1,2)=YY1 TRABNK(NTRBNK+1,3)=ZZ1 TRABNK(NTRBNK+1,8)=-4 TRABNK(NTRBNK+2,1)=X1 TRABNK(NTRBNK+2,2)=Y1 TRABNK(NTRBNK+2,3)=Z1 TRABNK(NTRBNK+2,8)=-4 NTRBNK=NTRBNK+2 ** Next add the other NLTR/4 drift-lines where delta t is largest. IF(NTRBNK.LE.5)GOTO 390 IF(LDEBUG)PRINT *,' ++++++ DLCTRP DEBUG : Adding intermediate', - ' drift-lines at largest t jumps.' DO 360 IL=1,NLTR/4 * Check number of drift-lines. IF(NTRBNK+1.GT.MXLIST)THEN IF(LDEBUG)PRINT *,' ++++++ DLCTRP DEBUG : NTRBNK=MXLIST.' GOTO 390 ENDIF * Locate the largest t jump. DELTAT=ABS(TRABNK(4,4)-TRABNK(3,4)) IDMAX=3 DO 370 JL=4,NTRBNK-3 IF(ABS(TRABNK(JL+1,4)-TRABNK(JL,4)).GT.DELTAT)THEN DELTAT=ABS(TRABNK(JL+1,4)-TRABNK(JL,4)) IDMAX=JL ENDIF 370 CONTINUE * Shift everything above by one place. DO 380 JL=NTRBNK,IDMAX+1,-1 DO 385 KL=1,9 TRABNK(JL+1,KL)=TRABNK(JL,KL) 385 CONTINUE 380 CONTINUE * Halve the gap between the two points. TRABNK(IDMAX+1,1)=(TRABNK(IDMAX,1)+TRABNK(IDMAX+2,1))/2 TRABNK(IDMAX+1,2)=(TRABNK(IDMAX,2)+TRABNK(IDMAX+2,2))/2 TRABNK(IDMAX+1,3)=(TRABNK(IDMAX,3)+TRABNK(IDMAX+2,3))/2 * Calculate a drift-line from the half-way point. XSTART=TRABNK(IDMAX+1,1) YSTART=TRABNK(IDMAX+1,2) ZSTART=TRABNK(IDMAX+1,3) IF(POLAR)CALL CFMCTR(XSTART,YSTART,XSTART,YSTART,1) CALL DLCALC(XSTART,YSTART,ZSTART,-1.0,1) IF(POLAR)CALL CFMRTC(XSTART,YSTART,XSTART,YSTART,1) * Add the new drift-line to the table. NTRBNK=NTRBNK+1 TRABNK(IDMAX+1,4)=REAL(TU(NU)) IF(TRAFLG(5))CALL DLCDIF(TRABNK(IDMAX+1,5)) IF(TRAFLG(6))CALL DLCTWN(TRABNK(IDMAX+1,6)) IF(TRAFLG(7))CALL DLCATT(TRABNK(IDMAX+1,7)) TRABNK(IDMAX+1,8)=REAL(ISTAT) CALL DLCPHI(TRABNK(IDMAX+1,9)) IF(NINT(TRABNK(IDMAX+1,8)).EQ.NINT(TRABNK(IDMAX,8)))THEN IF(TRABNK(IDMAX+1,9).GT.TRABNK(IDMAX,9)+PI)THEN TRABNK(IDMAX+1,9)=TRABNK(IDMAX+1,9)-2*PI ELSEIF(TRABNK(IDMAX+1,9).LT.TRABNK(IDMAX,9)-PI)THEN TRABNK(IDMAX+1,9)=TRABNK(IDMAX+1,9)+2*PI ENDIF ENDIF IF(LDEBUG)WRITE(LUNOUT,'(2X,''(x,y,z)='',3E11.4,'', t='',E11.4, - '', sigma='',E11.4/'' avalanche='',E11.4,'', loss='',E11.4, - '', angle='',E11.4,'', ISTAT='',I4,'',NU='',I3)') - (TRABNK(IDMAX+1,J),J=1,7),TRABNK(IDMAX+1,9), - NINT(TRABNK(IDMAX+1,8)),NU * Plot and print the data if requested. IF(LDRPLT)CALL DLCPLT * Add another line. 360 CONTINUE ** Jump to this point if the maximum number of drift-lines is reached. 390 CONTINUE ** Finish this plot, if plotting has been requested. IF(LDRPLT)THEN CALL GRNEXT CALL GRALOG('Drift-lines from the acceptance segment.') ENDIF *** Establish the tracks major direction. ITRMAJ=1 IF(ABS(TRABNK(NTRBNK,2)-TRABNK(1,2)).GT. - ABS(TRABNK(NTRBNK,ITRMAJ)-TRABNK(1,ITRMAJ)))ITRMAJ=2 IF(ABS(TRABNK(NTRBNK,3)-TRABNK(1,3)).GT. - ABS(TRABNK(NTRBNK,ITRMAJ)-TRABNK(1,ITRMAJ)))ITRMAJ=3 *** Prepare the distance vector used in interpolations. DO 200 J=1,NTRBNK TRAVEC(J)=ABS(TRABNK(J,1)-TRABNK(1,1))+ - ABS(TRABNK(J,2)-TRABNK(1,2))+ - ABS(TRABNK(J,3)-TRABNK(1,3)) 200 CONTINUE *** Determine maxima and minima, initialise. TMIN=TRABNK(3,4) TMAX=TRABNK(3,4) IF(TRAFLG(5))THEN SMIN=TRABNK(3,5) SMAX=TRABNK(3,5) ELSE SMIN=0.0 SMAX=0.0 ENDIF IF(TRAFLG(6))THEN AMIN=TRABNK(3,6) AMAX=TRABNK(3,6) ELSE AMIN=0.0 AMAX=0.0 ENDIF IF(TRAFLG(7))THEN BMIN=TRABNK(3,7) BMAX=TRABNK(3,7) ELSE BMIN=0.0 BMAX=0.0 ENDIF * Loop over the points. DO 400 I=4,NTRBNK-2 TMIN=MIN(TMIN,TRABNK(I,4)) TMAX=MAX(TMAX,TRABNK(I,4)) IF(TRAFLG(5))THEN SMIN=MIN(SMIN,TRABNK(I,5)) SMAX=MAX(SMAX,TRABNK(I,5)) ENDIF IF(TRAFLG(6))THEN AMIN=MIN(AMIN,TRABNK(I,6)) AMAX=MAX(AMAX,TRABNK(I,6)) ENDIF IF(TRAFLG(7))THEN BMIN=MIN(BMIN,TRABNK(I,7)) BMAX=MAX(BMAX,TRABNK(I,7)) ENDIF 400 CONTINUE *** The track is now prepared. TRASET=.TRUE. IF(LDEBUG)THEN WRITE(LUNOUT,'('' INTERPOLATION TABLE:''/ - '' i x [cm] y [cm] z [cm]'', - '' t [microsec] sigma [1 cm] avalanche'', - '' loss status'')') DO 500 I=3,NTRBNK-2 WRITE(LUNOUT,'(2X,I5,7(2X,E12.5),2X,I6)') - I,(TRABNK(I,J),J=1,7),NINT(TRABNK(I,8)) 500 CONTINUE WRITE(LUNOUT,'(/'' Major axis: '',I5)') ITRMAJ ENDIF *** Plot the various distributions if the debugging is requested. IF(LDEBUG.OR.LDRPLT)THEN * Prepare coordinate vector. DO 410 I=1,NTRBNK COORD(I)=SQRT((TRABNK(I,1)-X0)**2+(TRABNK(I,2)-Y0)**2+ - (TRABNK(I,3)-Z0)**2)/SQRT((TRABNK(NTRBNK,1)-X0)**2+ - (TRABNK(NTRBNK,2)-Y0)**2+(TRABNK(NTRBNK,3)-Z0)**2) 410 CONTINUE * Drift time. CALL GRGRPH(COORD(3),TRABNK(3,4),NTRBNK-4, - 'Track coordinate', - 'Drift time [microsec]','Drift time') DO 420 I=1,MXLIST XCL=X0+REAL(I-1)*(X1-X0)/REAL(MXLIST-1) YCL=Y0+REAL(I-1)*(Y1-Y0)/REAL(MXLIST-1) ZCL=Z0+REAL(I-1)*(Z1-Z0)/REAL(MXLIST-1) XPL(I)=REAL(I-1)/REAL(MXLIST-1) CALL DLCTRI(XCL,YCL,ZCL,YPL(I),ICL,SCL,ACL,BCL,FCL, - .FALSE.,.FALSE.,.FALSE.,IFAIL) IF(IFAIL.NE.0)YPL(I)=-1.0 420 CONTINUE CALL GRATTS('FUNCTION-2','POLYLINE') CALL GPL(MXLIST,XPL,YPL) CALL GRATTS('FUNCTION-1','POLYMARKER') CALL GPM(NTRBNK-4,COORD(3),TRABNK(3,4)) CALL GRNEXT CALL GRALOG('Prepared track - drift time:') * Incidence angle. CALL GRGRPH(COORD(3),TRABNK(3,9),NTRBNK-4, - 'Track coordinate', - 'Incidence angle [radians]','Incidence angle') DO 425 I=1,MXLIST XCL=X0+REAL(I-1)*(X1-X0)/REAL(MXLIST-1) YCL=Y0+REAL(I-1)*(Y1-Y0)/REAL(MXLIST-1) ZCL=Z0+REAL(I-1)*(Z1-Z0)/REAL(MXLIST-1) XPL(I)=REAL(I-1)/REAL(MXLIST-1) CALL DLCTRI(XCL,YCL,ZCL,TCL,ICL,SCL,ACL,BCL,YPL(I), - .FALSE.,.FALSE.,.FALSE.,IFAIL) IF(IFAIL.NE.0)YPL(I)=-1.0 425 CONTINUE CALL GRATTS('FUNCTION-2','POLYLINE') CALL GPL(MXLIST,XPL,YPL) CALL GRATTS('FUNCTION-1','POLYMARKER') CALL GPM(NTRBNK-4,COORD(3),TRABNK(3,9)) CALL GRNEXT CALL GRALOG('Prepared track - angle:') * Status code. CALL GRGRPH(COORD(3),TRABNK(3,8),NTRBNK-4, - 'Track coordinate', - 'Status code','Status code') DO 430 I=1,MXLIST XCL=X0+REAL(I-1)*(X1-X0)/REAL(MXLIST-1) YCL=Y0+REAL(I-1)*(Y1-Y0)/REAL(MXLIST-1) ZCL=Z0+REAL(I-1)*(Z1-Z0)/REAL(MXLIST-1) XPL(I)=REAL(I-1)/REAL(MXLIST-1) CALL DLCTRI(XCL,YCL,ZCL,TCL,ICL,SCL,ACL,BCL,FCL, - .FALSE.,.FALSE.,.FALSE.,IFAIL) YPL(I)=REAL(ICL) IF(IFAIL.NE.0)YPL(I)=0 430 CONTINUE CALL GRATTS('FUNCTION-2','POLYLINE') CALL GPL(MXLIST,XPL,YPL) CALL GRATTS('FUNCTION-1','POLYMARKER') CALL GPM(NTRBNK-4,COORD(3),TRABNK(3,8)) CALL GRNEXT CALL GRALOG('Prepared track - status code:') ENDIF * Diffusion coefficient. IF((LDEBUG.OR.LDRPLT).AND.TRAFLG(5))THEN CALL GRGRPH(COORD(3),TRABNK(3,5),NTRBNK-4, - 'Track coordinate', - 'Diffusion [cm for 1 cm of drift]','Diffusion') DO 440 I=1,MXLIST XCL=X0+REAL(I-1)*(X1-X0)/REAL(MXLIST-1) YCL=Y0+REAL(I-1)*(Y1-Y0)/REAL(MXLIST-1) ZCL=Z0+REAL(I-1)*(Z1-Z0)/REAL(MXLIST-1) XPL(I)=REAL(I-1)/REAL(MXLIST-1) CALL DLCTRI(XCL,YCL,ZCL,TCL,ICL,YPL(I),ACL,BCL,FCL, - .TRUE.,.FALSE.,.FALSE.,IFAIL) IF(IFAIL.NE.0)YPL(I)=-1.0 440 CONTINUE CALL GRATTS('FUNCTION-2','POLYLINE') CALL GPL(MXLIST,XPL,YPL) CALL GRATTS('FUNCTION-1','POLYMARKER') CALL GPM(NTRBNK-4,COORD(3),TRABNK(3,5)) CALL GRNEXT CALL GRALOG('Prepared track - diffusion:') ENDIF * Townsend coefficient. IF((LDEBUG.OR.LDRPLT).AND.TRAFLG(6))THEN CALL GRGRPH(COORD(3),TRABNK(3,6),NTRBNK-4, - 'Track coordinate', - 'Townsend coefficient','Townsend coefficient') DO 450 I=1,MXLIST XCL=X0+REAL(I-1)*(X1-X0)/REAL(MXLIST-1) YCL=Y0+REAL(I-1)*(Y1-Y0)/REAL(MXLIST-1) ZCL=Z0+REAL(I-1)*(Z1-Z0)/REAL(MXLIST-1) XPL(I)=REAL(I-1)/REAL(MXLIST-1) CALL DLCTRI(XCL,YCL,ZCL,TCL,ICL,SCL,YPL(I),BCL,FCL, - .FALSE.,.TRUE.,.FALSE.,IFAIL) IF(IFAIL.NE.0)YPL(I)=-1.0 450 CONTINUE CALL GRATTS('FUNCTION-2','POLYLINE') CALL GPL(MXLIST,XPL,YPL) CALL GRATTS('FUNCTION-1','POLYMARKER') CALL GPM(NTRBNK-4,COORD(3),TRABNK(3,6)) CALL GRNEXT CALL GRALOG('Prepared track - Townsend coefficient:') ENDIF * Attachment coefficient. IF((LDEBUG.OR.LDRPLT).AND.TRAFLG(7))THEN CALL GRGRPH(COORD(3),TRABNK(3,7),NTRBNK-4, - 'Track coordinate', - 'Attachment coefficient','Attachment') DO 460 I=1,MXLIST XCL=X0+REAL(I-1)*(X1-X0)/REAL(MXLIST-1) YCL=Y0+REAL(I-1)*(Y1-Y0)/REAL(MXLIST-1) ZCL=Z0+REAL(I-1)*(Z1-Z0)/REAL(MXLIST-1) XPL(I)=REAL(I-1)/REAL(MXLIST-1) CALL DLCTRI(XCL,YCL,ZCL,TCL,ICL,SCL,ACL,YPL(I),FCL, - .FALSE.,.FALSE.,.TRUE.,IFAIL) IF(IFAIL.NE.0)YPL(I)=-1.0 460 CONTINUE CALL GRATTS('FUNCTION-2','POLYLINE') CALL GPL(MXLIST,XPL,YPL) CALL GRATTS('FUNCTION-1','POLYMARKER') CALL GPM(NTRBNK-4,COORD(3),TRABNK(3,7)) CALL GRNEXT CALL GRALOG('Prepared track - Attachment:') ENDIF *** Things seem to have worked properly, flag that things are OK. IFAIL=0 *** Remember how much time this took. CALL TIMLOG('Preparing the track interpolation: ') END +DECK,DLCTRR. SUBROUTINE DLCTRR *----------------------------------------------------------------------- * DLCTRR - Resets track preparation. * (Last changed on 25/ 3/96.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,SIGNALDATA. TRASET=.FALSE. END +DECK,DLCTRI. SUBROUTINE DLCTRI(XCL,YCL,ZCL,TCL,ICL,SCL,ACL,BCL,FCL, - LDIFF,LAVAL,LATTA,IFAIL) *----------------------------------------------------------------------- * DLCTRI - Interpolates on a track prepared by DLCTRP. The main * objective of this method is to gain lots of speed. * VARIABLES : (XCL,YCL,ZCL): Position of the cluster. * TCL : Interpolated drift-time. * ICL : ISTAT code. * SCL,ACL,BCL : Diffusion, avalanche and loss * FCL : Incidence angle on the wire * (Last changed on 20/ 5/99.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,SIGNALDATA. +SEQ,CELLDATA. +SEQ,PARAMETERS. +SEQ,PRINTPLOT. C logical ldebug,lident C integer lunout C parameter(ldebug=.true.,lident=.false.,lunout=6) +SEQ,DRIFTLINE. REAL XCL,YCL,ZCL,ACL,BCL,SCL,TCL,FCL,DCLUST,VV,TT,VT,DIVDIF, - XSTART,YSTART,ZSTART INTEGER ICL,IFAIL,I,ISTART,ISTPRV,IFOUND,NVEC LOGICAL LDIFF,LAVAL,LATTA EXTERNAL DIVDIF *** Identify the routine if requested. IF(LIDENT)PRINT *,' /// ROUTINE DLCTRI ///' *** Debugging output. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCTRI DEBUG : (x,y,z) '', - 3E15.8)') XCL,YCL,ZCL *** Initialise the IFAIL flag on 1, i.e. fail, set the output to zero. IFAIL=1 TCL=0.0 SCL=0.0 ACL=0.0 BCL=1.0 FCL=0.0 ICL=0 *** Return if the track has not been properly prepared. IF(.NOT.TRASET.OR.NTRBNK.LE.1)THEN PRINT *,' ###### DLCTRI ERROR : Interpolation cannot be'// - ' performed because the track has not been prepared.' RETURN ENDIF *** Check whether the cluster is roughly on the stored track. IF(ABS(XCL-TRABNK(1,1))+ABS(YCL-TRABNK(1,2))+ - ABS(ZCL-TRABNK(1,3)).LT.ABS(XCL-TRABNK(NTRBNK,1))+ - ABS(YCL-TRABNK(NTRBNK,2))+ABS(ZCL-TRABNK(NTRBNK,3)))THEN VT=(XCL-TRABNK(1,1))*(TRABNK(NTRBNK,1)-TRABNK(1,1))+ - (YCL-TRABNK(1,2))*(TRABNK(NTRBNK,2)-TRABNK(1,2))+ - (ZCL-TRABNK(1,3))*(TRABNK(NTRBNK,3)-TRABNK(1,3)) VV=(XCL-TRABNK(1,1))**2+ - (YCL-TRABNK(1,2))**2+ - (ZCL-TRABNK(1,3))**2 TT=(TRABNK(NTRBNK,1)-TRABNK(1,1))**2+ - (TRABNK(NTRBNK,2)-TRABNK(1,2))**2+ - (TRABNK(NTRBNK,3)-TRABNK(1,3))**2 ELSE VT=(XCL-TRABNK(NTRBNK,1))*(TRABNK(NTRBNK,1)-TRABNK(1,1))+ - (YCL-TRABNK(NTRBNK,2))*(TRABNK(NTRBNK,2)-TRABNK(1,2))+ - (ZCL-TRABNK(NTRBNK,3))*(TRABNK(NTRBNK,3)-TRABNK(1,3)) VV=(XCL-TRABNK(NTRBNK,1))**2+ - (YCL-TRABNK(NTRBNK,2))**2+ - (ZCL-TRABNK(NTRBNK,3))**2 TT=(TRABNK(NTRBNK,1)-TRABNK(1,1))**2+ - (TRABNK(NTRBNK,2)-TRABNK(1,2))**2+ - (TRABNK(NTRBNK,3)-TRABNK(1,3))**2 ENDIF *** If it isn't, then compute the drift line explicitely. IF(VV*TT-VT**2.GT.(1E-2*TT)**2.OR. - (XCL.LT.MIN(TRABNK(3,1),TRABNK(NTRBNK-2,1)).OR. - XCL.GT.MAX(TRABNK(3,1),TRABNK(NTRBNK-2,1))).OR. - (YCL.LT.MIN(TRABNK(3,2),TRABNK(NTRBNK-2,2)).OR. - YCL.GT.MAX(TRABNK(3,2),TRABNK(NTRBNK-2,2))).OR. - (ZCL.LT.MIN(TRABNK(3,3),TRABNK(NTRBNK-2,3)).OR. - ZCL.GT.MAX(TRABNK(3,3),TRABNK(NTRBNK-2,3))))THEN IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCTRI ERROR :'', - '' Cluster at '',3E15.8/26X,'' is not located'', - '' on the track.'')') XCL,YCL,ZCL GOTO 1010 *** Maybe the point is very close to the begin or end point ? ELSEIF(SQRT((XCL-TRABNK(3,1))**2+(YCL-TRABNK(3,2))**2+ - (ZCL-TRABNK(3,3))**2).LT. - 1.0E-4*(1+SQRT(XCL**2+YCL**2+ZCL**2)))THEN TCL=TRABNK(3,4) SCL=TRABNK(3,5) ACL=TRABNK(3,6) BCL=TRABNK(3,7) ICL=NINT(TRABNK(3,8)) FCL=TRABNK(3,9) IFAIL=0 IF(LDEBUG)PRINT *,' ++++++ DLCTRI DEBUG : Cluster'// - ' coincides with track starting point.' RETURN ELSEIF(SQRT((XCL-TRABNK(NTRBNK-2,1))**2+ - (YCL-TRABNK(NTRBNK-2,2))**2+ - (ZCL-TRABNK(NTRBNK-2,3))**2).LT. - 1.0E-4*(1+SQRT(XCL**2+YCL**2+ZCL**2)))THEN TCL=TRABNK(NTRBNK-2,4) SCL=TRABNK(NTRBNK-2,5) ACL=TRABNK(NTRBNK-2,6) BCL=TRABNK(NTRBNK-2,7) FCL=TRABNK(NTRBNK-2,9) ICL=NINT(TRABNK(NTRBNK-2,8)) IFAIL=0 IF(LDEBUG)PRINT *,' ++++++ DLCTRI DEBUG : Cluster'// - ' coincides with track end point.' RETURN *** Could also be that the cluster is in the end zones. ELSEIF((TRABNK(1,1)-XCL)*(XCL-TRABNK(3,1)).GE.0.AND. - (TRABNK(1,2)-YCL)*(YCL-TRABNK(3,2)).GE.0.AND. - (TRABNK(1,3)-ZCL)*(ZCL-TRABNK(3,3)).GE.0)THEN IF(LDEBUG)PRINT *,' ++++++ DLCTRI DEBUG : Cluster in'// - ' start zone.' GOTO 1010 ELSEIF((TRABNK(NTRBNK-2,1)-XCL)*(XCL-TRABNK(NTRBNK,1)).GE.0.AND. - (TRABNK(NTRBNK-2,2)-YCL)*(YCL-TRABNK(NTRBNK,2)).GE.0.AND. - (TRABNK(NTRBNK-2,3)-ZCL)*(ZCL-TRABNK(NTRBNK,3)).GE.0)THEN IF(LDEBUG)PRINT *,' ++++++ DLCTRI DEBUG : Cluster in'// - ' end zone.' GOTO 1010 ENDIF *** Only cases left of points on the track. ISTPRV=NINT(TRABNK(1,8)) IFOUND=0 ISTART=3 DO 10 I=4,NTRBNK-1 * Check whether this step covers the cluster position. IF(ISTPRV.EQ.NINT(TRABNK(I,8)).AND. - ((ITRMAJ.EQ.1.AND. - (TRABNK(I-1,1)-XCL)*(TRABNK(I,1)-XCL).LE.0).OR. - (ITRMAJ.EQ.2.AND. - (TRABNK(I-1,2)-YCL)*(TRABNK(I,2)-YCL).LE.0).OR. - (ITRMAJ.EQ.3.AND. - (TRABNK(I-1,3)-ZCL)*(TRABNK(I,3)-ZCL).LE.0)))IFOUND=I * Change of ISTAT, check whether the cluster has been covered. IF(ISTPRV.EQ.NINT(TRABNK(I,8)).AND.I.NE.NTRBNK-1)GOTO 10 * Interpolate if that is the case. IF(IFOUND.NE.0)THEN * Fix the number of points in the interpolation vector. NVEC=I-ISTART IF(I.EQ.NTRBNK-1.AND.ISTPRV.EQ.NINT(TRABNK(I,8)))NVEC=NVEC+1 IF(ISTART+NVEC.GT.NTRBNK-1)NVEC=NTRBNK-ISTART-1 * Interpolation is not meaningful on a single point, return abend. IF(NVEC.LT.NINORD)THEN IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCTRI DEBUG :'', - '' Too few points: '',I5)') NVEC GOTO 1010 * Interpolate normally with 2 or more points, then return on IFAIL=0. ELSE IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCTRI DEBUG :'', - '' Interpolation from I='',I3,'' to '',I3)') - ISTART,ISTART+NVEC-1 DCLUST=ABS(XCL-TRABNK(1,1))+ABS(YCL-TRABNK(1,2))+ - ABS(ZCL-TRABNK(1,3)) ICL=NINT(TRABNK(ISTART,8)) IF(TRAFLG(4))TCL=DIVDIF(TRABNK(ISTART,4), - TRAVEC(ISTART),NVEC,DCLUST,MIN(NINORD,NVEC)) IF(TRAFLG(5).AND.LDIFF)SCL=DIVDIF(TRABNK(ISTART,5), - TRAVEC(ISTART),NVEC,DCLUST,MIN(NINORD,NVEC)) IF(TRAFLG(6).AND.LAVAL)ACL=DIVDIF(TRABNK(ISTART,6), - TRAVEC(ISTART),NVEC,DCLUST,MIN(NINORD,NVEC)) IF(TRAFLG(7).AND.LATTA)BCL=DIVDIF(TRABNK(ISTART,7), - TRAVEC(ISTART),NVEC,DCLUST,MIN(NINORD,NVEC)) IF(TRAFLG(9))FCL=DIVDIF(TRABNK(ISTART,9), - TRAVEC(ISTART),NVEC,DCLUST,MIN(NINORD,NVEC)) ENDIF IFAIL=0 RETURN * Reset the current interpolation vector if not. ELSE ISTPRV=NINT(TRABNK(I,8)) ISTART=I ENDIF 10 CONTINUE *** Interpolation failed because the cluster is outside the track. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCTRI DEBUG : Unable to'', - '' interpolate an in-range, colinear cluster.'')') *** If something fails, compute an explicit drift line. 1010 CONTINUE IF(LINCAL)THEN IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCTRI DEBUG :'', - '' Computing a drift line from '',3E12.5)') XCL,YCL,ZCL ELSE IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ DLCTRI DEBUG :'', - '' Drift line from '',3E12.5,'' abandoned.'')') - XCL,YCL,ZCL IFAIL=0 ICL=-3 RETURN ENDIF * Set the starting point. XSTART=XCL YSTART=YCL ZSTART=ZCL IF(POLAR)CALL CFMCTR(XSTART,YSTART,XSTART,YSTART,1) CALL DLCALC(XSTART,YSTART,ZSTART,-1.0,1) IF(POLAR)CALL CFMRTC(XSTART,YSTART,XSTART,YSTART,1) * Store drift time, diffusion, Townsend, attachment and status. TCL=REAL(TU(NU)) IF(TRAFLG(5).AND.LDIFF)CALL DLCDIF(SCL) IF(TRAFLG(6).AND.LAVAL)CALL DLCTWN(ACL) IF(TRAFLG(7).AND.LATTA)CALL DLCATT(BCL) ICL=ISTAT CALL DLCPHI(FCL) * End of this calculation. IFAIL=0 END +DECK,DLCBCK. SUBROUTINE DLCBCK(ACTION) *----------------------------------------------------------------------- * DLCBCK - Stores a drift lines or restores it. * (Last changed on 22/ 1/01.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,DRIFTLINE. DOUBLE PRECISION XUCOPY(MXLIST),YUCOPY(MXLIST),ZUCOPY(MXLIST), - TUCOPY(MXLIST) REAL QPCOPY INTEGER ISCOPY,NUCOPY,I,IPCOPY,ITCOPY CHARACTER*(*) ACTION +SELF,IF=SAVE. SAVE XUCOPY,YUCOPY,ZUCOPY,TUCOPY,ISCOPY,NUCOPY,IPCOPY,ITCOPY, - QPCOPY +SELF. DATA ISCOPY/0/, NUCOPY/0/ *** Save if requested. IF(ACTION.EQ.'SAVE')THEN * Verify current settings. IF(NU.LT.0.OR.NU.GT.MXLIST) - PRINT *,' !!!!!! DLCBCK WARNING : Invalid number of'// - ' drift line points found; limited save.' * Store the drift line. DO 10 I=1,MIN(MXLIST,MAX(0,NU)) XUCOPY(I)=XU(I) YUCOPY(I)=YU(I) ZUCOPY(I)=ZU(I) TUCOPY(I)=TU(I) 10 CONTINUE ISCOPY=ISTAT IPCOPY=IPTYPE ITCOPY=IPTECH QPCOPY=QPCHAR NUCOPY=NU *** Restore the drift line. ELSEIF(ACTION.EQ.'RESTORE')THEN * Verify current settings. IF(NUCOPY.LT.0.OR.NUCOPY.GT.MXLIST) - PRINT *,' !!!!!! DLCBCK WARNING : Invalid number of'// - ' drift line points found; limited restore.' * Store the drift line. DO 20 I=1,MIN(MXLIST,MAX(0,NUCOPY)) XU(I)=XUCOPY(I) YU(I)=YUCOPY(I) ZU(I)=ZUCOPY(I) TU(I)=TUCOPY(I) 20 CONTINUE ISTAT=ISCOPY IPTYPE=IPCOPY IPTECH=ITCOPY QPCHAR=QPCOPY NU=NUCOPY *** Other actions are not known. ELSE PRINT *,' !!!!!! DLCBCK WARNING : Unknown action ', - ACTION,' received ; nothing done.' ENDIF END +PATCH,SIGNAL. +DECK,SIGINP. SUBROUTINE SIGINP *----------------------------------------------------------------------- * SIGINP - Routine looking at the instructions in the signal section. * The actual calculations are performed by other routines. * VARIABLES : CHANGE : .TRUE. when new ion tails have to be * calculated (due to a change in parameters) * OPEN : used for checking the the unit status * (Last changed on 12/10/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PARAMETERS. +SEQ,CELLDATA. +SEQ,GASDATA. +SEQ,DRIFTLINE. +SEQ,PRINTPLOT. +SEQ,SIGNALDATA. +SEQ,CONSTANTS. CHARACTER*(MXCHAR) STRING CHARACTER*20 STR1,STR2,STR3,STR4 LOGICAL CHANGE,OPEN,LDIFF,LTOWN,LATTA,FLAG(MXWORD+3) INTEGER NTIMER,IFAIL,IFAIL1,IFAIL2,IFAIL3, - I,J,K,INEXT,NGRDXR,NGRDYR,NGRIDR,NWORD,NC,NFOURR,MFR, - NLTR,NLTRR,IOS,INPTYP,INPCMP,NC1,NC2,NC3,NC4 REAL TDEVR,TSTARR,FACTR,RELWID,THETAR,TMIN,TMAX,SMIN,SMAX, - AMIN,AMAX,BMIN,BMAX DOUBLE PRECISION DUMMY(1) EXTERNAL INPCMP,INPTYP +SELF,IF=AST. EXTERNAL ASTCCH +SELF. *** Define some formats. 1110 FORMAT(' The Fourier series will have ',I10,' terms.') *** Print a heading for the signal simulation pages. WRITE(*,'(''1'')') PRINT *,' ================================================' PRINT *,' ========== Start of signal section ==========' PRINT *,' ================================================' PRINT *,' ' *** Identify the routine IF(LIDENT)PRINT *,' /// ROUTINE SIGINP ///' *** Check that sufficient gas data have been read. IF(.NOT.(GASOK(1).AND.GASOK(2).AND.(GASOK(5).OR.HEEDOK)))THEN PRINT *,' ###### SIGINP ERROR : Insufficient gasdata', - ' (needed are the electron drift velocity,' PRINT *,' the ion mobility and', - ' cluster data); this section is skipped.' CALL SKIP RETURN ENDIF *** Set default area. CALL GRASET(DXMIN,DYMIN,DZMIN,DXMAX,DYMAX,DZMAX) *** Set SIGSET, CHANGE, RESSET and AVATYP to false. SIGSET=.FALSE. CHANGE=.TRUE. AVATYP='NOT SET' RESSET=.FALSE. *** Start a loop over the input file, searching for keywords. CALL INPPRM('Signal','NEW-PRINT') 10 CONTINUE CALL INPWRD(NWORD) +SELF,IF=AST. *** Set up ASTCCH as the condition handler. CALL LIB$ESTABLISH(ASTCCH) +SELF. CALL INPSTR(1,1,STRING,NC) *** Skip this line if it is blank. IF(NWORD.EQ.0)GOTO 10 *** Return to the main program if & is the first character. IF(STRING(1:1).EQ.'&')THEN GOTO 60 *** Add noise to the signals. ELSEIF(INPCMP(1,'ADD-N#OISE').NE.0)THEN CALL SIGNOI(IFAIL) *** Look for the AREA instruction. ELSEIF(INPCMP(1,'AREA').NE.0)THEN CALL CELVIE(DXMIN,DYMIN,DZMIN,DXMAX,DYMAX,DZMAX) CALL INPERR *** Read the avalanche parameters if AVALANCHE is a keyword. ELSEIF(INPCMP(1,'AV#ALANCHE').NE.0)THEN * Print the current setting, if entered without arguments. IF(NWORD.EQ.1)THEN IF(AVATYP.EQ.'EXPONENTIAL')THEN CALL OUTFMT(AVALAN(1),2,STR1,NC1,'LEFT') WRITE(LUNOUT,'('' The multiplication factor'', - '' is exponentially distributed with an'', - '' average of '',A,''.'')') STR1(1:NC1) ELSEIF(AVATYP.EQ.'FIXED')THEN CALL OUTFMT(AVALAN(1),2,STR1,NC1,'LEFT') WRITE(LUNOUT,'('' The multiplication factor'', - '' is '',A,'' irrespective of the'', - '' drift line.'')') STR1(1:NC1) ELSEIF(AVATYP.EQ.'GAUSSIAN')THEN CALL OUTFMT(AVALAN(1),2,STR1,NC1,'LEFT') CALL OUTFMT(AVALAN(2),2,STR2,NC2,'LEFT') WRITE(LUNOUT,'('' The multiplication factor'', - '' distribution is Gaussian with''/ - '' mean '',A,'' and relative width '',A, - ''.'')') STR1(1:NC1),STR2(1:NC2) ELSEIF(AVATYP.EQ.'NOT SET')THEN WRITE(LUNOUT,'('' No avalanche specification'', - '' has been entered in this section.'')') ELSEIF(AVATYP.EQ.'POLYA-FIXED')THEN CALL OUTFMT(AVALAN(1),2,STR1,NC1,'LEFT') CALL OUTFMT(AVALAN(2),2,STR2,NC2,'LEFT') WRITE(LUNOUT,'('' The multiplication factor'', - '' is Polya distributed''/'' with fixed'', - '' mean '',A,'' and with a parameter '', - A,''.'')') STR1(1:NC1),STR2(1:NC2) ELSEIF(AVATYP.EQ.'POLYA-TOWN')THEN CALL OUTFMT(AVALAN(1),2,STR1,NC1,'LEFT') WRITE(LUNOUT,'('' The multiplication factor'', - '' is Polya distributed with a mean''/ - '' determined by the Townsend'', - '' coefficients and with a parameter '', - A,''.'')') STR1(1:NC1) ELSEIF(AVATYP.EQ.'TOWNSEND')THEN WRITE(LUNOUT,'('' The multiplication factor'', - '' is determined by the Townsend'', - '' coefficients with exponential'', - '' fluctuations.'')') ELSEIF(AVATYP.EQ.'TOWN-FIXED')THEN WRITE(LUNOUT,'('' The multiplication factor'', - '' is determined by the Townsend'', - '' coefficients without fluctuations.'')') ELSE PRINT *,' ###### SIGINP ERROR : Avalanche type ', - AVATYP,' not known.' ENDIF * The avalanche type might be EXPONENTIAL. ELSEIF(NWORD.EQ.3.AND.INPCMP(2,'E#XPONENTIAL').NE.0)THEN AVATYP='EXPONENTIAL' CALL INPCHK(3,2,IFAIL1) CALL INPRDR(3,FACTR,0.0) IF(FACTR.GT.0.0.AND.IFAIL1.EQ.0)THEN AVALAN(1)=FACTR ELSE CALL INPMSG(3,'Multiplication is not > 0.') AVALAN(1)=1 ENDIF * The avalanche type might be FIXED. ELSEIF(NWORD.EQ.3.AND.INPCMP(2,'F#IXED').NE.0)THEN AVATYP='FIXED' CALL INPCHK(3,2,IFAIL1) CALL INPRDR(3,FACTR,0.0) IF(FACTR.GT.0.0.AND.IFAIL1.EQ.0)THEN AVALAN(1)=FACTR ELSE CALL INPMSG(3,'Multiplication is not > 0.') AVALAN(1)=1 ENDIF * The avalanche type might be GAUSSIAN. ELSEIF(NWORD.EQ.4.AND.INPCMP(2,'G#AUSSIAN').NE.0)THEN AVATYP='GAUSSIAN' CALL INPCHK(3,2,IFAIL1) CALL INPCHK(4,2,IFAIL2) CALL INPRDR(3,FACTR,0.0) CALL INPRDR(4,RELWID,0.0) IF(FACTR.GT.0.0.AND.IFAIL1.EQ.0)THEN AVALAN(1)=FACTR ELSE CALL INPMSG(3,'Multiplication is not > 0.') AVALAN(1)=1 ENDIF IF(RELWID.GE.0.0.AND.IFAIL2.EQ.0)THEN AVALAN(2)=RELWID ELSE CALL INPMSG(4,'Relative width must be >= 0.') AVALAN(2)=0 ENDIF * The avalanche type might be POLYA-FIXED. ELSEIF(NWORD.GE.2.AND.NWORD.LE.4.AND. - INPCMP(2,'P#OLYA-F#IXED')+ - INPCMP(2,'F#IXED-P#OLYA').NE.0)THEN AVATYP='POLYA-FIXED' IF(NWORD.GE.3)THEN CALL INPCHK(3,2,IFAIL1) CALL INPRDR(3,FACTR,0.0) ELSE IFAIL1=0 FACTR=1 ENDIF IF(FACTR.GT.0.AND.IFAIL1.EQ.0)THEN AVALAN(1)=FACTR ELSE CALL INPMSG(3,'Multiplication is not > 0.') AVALAN(1)=1 ENDIF IF(NWORD.GE.4)THEN CALL INPCHK(4,2,IFAIL2) CALL INPRDR(4,THETAR,0.5) ELSE IFAIL2=0 THETAR=0.5 ENDIF IF(THETAR.GT.-1.AND.IFAIL2.EQ.0)THEN AVALAN(2)=THETAR ELSE CALL INPMSG(4,'Polya parameter must be > -1.') AVALAN(2)=0.5 ENDIF * The avalanche type might be POLYA-TOWNSEND. ELSEIF(NWORD.GE.2.AND.NWORD.LE.3.AND. - INPCMP(2,'P#OLYA-T#OWNSEND')+ - INPCMP(2,'T#OWNSEND-P#OLYA').NE.0)THEN AVATYP='POLYA-TOWN' IF(NWORD.GE.3)THEN CALL INPCHK(3,2,IFAIL1) CALL INPRDR(3,THETAR,0.0) ELSE IFAIL1=0 THETAR=0.5 ENDIF IF(THETAR.GT.-1.AND.IFAIL1.EQ.0)THEN AVALAN(1)=THETAR ELSE CALL INPMSG(3,'Polya parameter must be > -1.') AVALAN(1)=0.5 ENDIF * The avalanche type might be TOWNSEND. ELSEIF(NWORD.EQ.2.AND.INPCMP(2,'T#OWNSEND').NE.0)THEN IF(GASOK(4))THEN AVATYP='TOWNSEND' ELSE CALL INPMSG(2,'No Townsend data are present. ') ENDIF * The avalanche type might be TOWNSEND-FIXED. ELSEIF(NWORD.EQ.2.AND.INPCMP(2,'T#OWNSEND-FIX#ED')+ - INPCMP(2,'FIX#ED-T#OWNSEND').NE.0)THEN IF(GASOK(4))THEN AVATYP='TOWN-FIXED' ELSE CALL INPMSG(2,'No Townsend data are present. ') ENDIF * Apparently some incorrect format has been used. ELSE PRINT *,' !!!!!! SIGINP WARNING : Incorrect format'// - ' of an AVALANCHE statement; see the writeup.' ENDIF CALL INPERR *** Look for the CHECK command. ELSEIF(INPCMP(1,'CH#ECK').NE.0)THEN CALL SIGCHK *** Convolute signals with a transfer function. ELSEIF(INPCMP(1,'CON#VOLUTE-S#IGNALS').NE.0)THEN CALL SIGCNV(IFAIL) *** Look for the FOURIER instruction. ELSEIF(INPCMP(1,'F#OURIER').NE.0)THEN IF(NWORD.EQ.1)THEN PRINT 1110,NFOUR ELSEIF(NWORD.EQ.2)THEN CALL INPCHK(2,1,IFAIL1) CALL INPRDI(2,NFOURR,1) * check the new value, replace if acceptable. MFR=NINT(LOG(REAL(NFOURR))/LOG(2.0)) IF(IFAIL1.EQ.0.AND.NFOURR.NE.2**MFR)THEN CALL INPMSG(2,'Not an integral power of 2. ') ELSEIF(IFAIL1.EQ.0.AND.NFOURR.LE.0)THEN CALL INPMSG(2,'Not larger than 0. ') ELSEIF(IFAIL1.EQ.0.AND.NFOURR.GT.MXFOUR)THEN CALL INPMSG(2,'Larger than MXFOUR. ') ELSEIF(IFAIL1.EQ.0)THEN IF(NFOUR.NE.NFOURR)THEN CHANGE=.TRUE. SIGSET=.FALSE. ENDIF NFOUR=NFOURR ENDIF ELSE PRINT *,' !!!!!! SIGINP WARNING : FOURIER takes one'// - ' argument ; instruction is ignored.' ENDIF * Print error messages. CALL INPERR *** Read track information from a dataset if GET is the command. ELSEIF(INPCMP(1,'GET-TR#ACK').NE.0)THEN CALL DLCTRG(IFAIL) *** Look for the keyword GRID. ELSEIF(INPCMP(1,'G#RID').NE.0)THEN IF(NWORD.EQ.1)THEN WRITE(LUNOUT,'('' Current grid density: '', - I3,'' by '',I3,'' points.'')') NGRIDX,NGRIDY ELSEIF(NWORD.EQ.2)THEN CALL INPCHK(2,1,IFAIL1) CALL INPRDI(2,NGRIDR,25) IF(NGRIDR.LE.1.OR.NGRIDR.GT.MXGRID) - CALL INPMSG(2,'GRID out of range 2 -> MXGRID.') CALL INPERR IF(IFAIL1.NE.0.OR.NGRIDR.LE.1.OR.NGRIDR.GT.MXGRID)THEN PRINT *,' !!!!!! SIGINP WARNING : GRID statement', - ' ignored because of syntax or value errors.' ELSE NGRIDX=NGRIDR NGRIDY=NGRIDR ENDIF ELSEIF(NWORD.EQ.3)THEN CALL INPCHK(2,1,IFAIL1) CALL INPCHK(3,1,IFAIL2) CALL INPRDI(2,NGRDXR,25) CALL INPRDI(3,NGRDYR,25) IF(NGRDXR.LE.1.OR.NGRDXR.GT.MXGRID) - CALL INPMSG(2,'out of the range 2 -> MXGRID. ') IF(NGRDYR.LE.1.OR.NGRDYR.GT.MXGRID) - CALL INPMSG(2,'out of the range 2 -> MXGRID. ') CALL INPERR IF(IFAIL1.NE.0.OR.NGRDXR.LE.1.OR.NGRDXR.GT.MXGRID.OR. - NGRDYR.LE.1.OR.NGRDYR.GT.MXGRID)THEN PRINT *,' !!!!!! SIGINP WARNING : GRID statement', - ' ignored because of syntax or value errors.' ELSE NGRIDX=NGRDXR NGRIDY=NGRDYR ENDIF ELSE PRINT *,' !!!!!! SIGINP WARNING : GRID requires 1'// - ' or 2 arguments ; the instruction is ignored.' ENDIF * Print error messages. CALL INPERR *** Integration parameters. ELSEIF(INPCMP(1,'INT#EGRATION-#PARAMETERS').NE.0)THEN CALL DLCPAR *** If OPTION is a keyword, try and identify them: ELSEIF(INPCMP(1,'OPT#IONS').NE.0)THEN IF(NWORD.EQ.1)WRITE(LUNOUT,'( - '' LOCAL OPTIONS CURRENTLY IN EFFECT:''// - '' Plotting of track, clusters and electrons: '', - L1/ - '' Printing of track, clusters and electrons: '', - L1/ - '' Contour all media (T) or drift medium (F): '', - L1/ - '' Plotting of the drift lines (DRIFT-PLOT): '', - L1/ - '' Printing of drift line details (DRIFT-PRINT): '', - L1/ - '' Plot wires by markers (WIRE-MARKERS): '', - L1/ - '' Check for multiple field map indices: '', - L1/)') LCLPLT,LCLPRT,LCNTAM,LDRPLT,LDRPRT,LWRMRK,LMAPCH DO 11 I=2,NWORD * look for clusterplot option, IF(INPCMP(I,'NOC#LUSTER-PL#OT').NE.0)THEN LCLPLT=.FALSE. ELSEIF(INPCMP(I,'C#LUSTER-PL#OT').NE.0)THEN LCLPLT=.TRUE. * look for cluster-print option, ELSEIF(INPCMP(I,'NOC#LUSTER-PR#INT').NE.0)THEN LCLPRT=.FALSE. ELSEIF(INPCMP(I,'C#LUSTER-PR#INT').NE.0)THEN LCLPRT=.TRUE. * search for plotting-of-drift lines option, ELSEIF(INPCMP(I,'NOD#RIFT-PL#OT').NE.0)THEN LDRPLT=.FALSE. ELSEIF(INPCMP(I,'D#RIFT-PL#OT').NE.0)THEN LDRPLT=.TRUE. * search for printing-of-drift lines option, ELSEIF(INPCMP(I,'NOD#RIFT-PR#INT').NE.0)THEN LDRPRT=.FALSE. ELSEIF(INPCMP(I,'DR#IFT-PR#INT').NE.0)THEN LDRPRT=.TRUE. * Contour drawing options. ELSEIF(INPCMP(I,'CONT#OUR-ALL-#MEDIA').NE.0)THEN LCNTAM=.TRUE. ELSEIF(INPCMP(I,'CONT#OUR-DR#IFT-#MEDIUM')+ - INPCMP(I,'CONT#OUR-DR#IFT-#MEDIA').NE.0)THEN LCNTAM=.FALSE. * Wires drawn as markers. ELSEIF(INPCMP(I,'NOW#IRE-M#ARKERS').NE.0)THEN LWRMRK=.FALSE. ELSEIF(INPCMP(I,'W#IRE-M#ARKERS').NE.0)THEN LWRMRK=.TRUE. * Detect multiple map indices. ELSEIF(INPCMP(I,'CH#ECK-MAP-#INDICES')+ - INPCMP(I,'CH#ECK-MAP-#INDEXING').NE.0)THEN LMAPCH=.TRUE. ELSEIF(INPCMP(I,'NOCH#ECK-MAP-#INDICES')+ - INPCMP(I,'NOCH#ECK-MAP-#INDEXING').NE.0)THEN LMAPCH=.FALSE. * option not known. ELSE CALL INPMSG(I,'The option is not known. ') ENDIF 11 CONTINUE * Print error messages. CALL INPERR *** Plot the signal field. ELSEIF(INPCMP(1,'PL#OT-F#IELD').NE.0)THEN CALL SIGWGT *** Plot signals if PLOT-SIGNALS is a keyword. ELSEIF(INPCMP(1,'PL#OT-S#IGNALS').NE.0)THEN CALL SIGPLT *** PREPARE-TRACK: Prepare a drifting information table. ELSEIF(INPCMP(1,'PR#EPARE-#TRACK').NE.0.AND..NOT.TRFLAG(1))THEN PRINT *,' !!!!!! SIGINP WARNING : Track preparation'// - ' must be done after track definition.' * Track has indeed been defined. ELSEIF(INPCMP(1,'PR#EPARE-#TRACK').NE.0)THEN * Initial option values. LDIFF=GASOK(3) LTOWN=GASOK(4) LATTA=GASOK(6) NLTR=NLINED * Flag recognised keywords. DO 30 I=1,NWORD+3 FLAG(I)=.FALSE. IF(INPCMP(I,'A#TTACHMENT-#COEFFICIENT')+ - INPCMP(I,'D#IFFUSION-#COEFFICIENT')+ - INPCMP(I,'L#INES')+ - INPCMP(I,'NOA#TTACHMENT-#COEFFICIENT')+ - INPCMP(I,'NOD#IFFUSION-#COEFFICIENT')+ - INPCMP(I,'NOT#OWNSEND-#COEFFICIENT')+ - INPCMP(I,'T#OWNSEND-#COEFFICIENT').NE.0)FLAG(I)=.TRUE. 30 CONTINUE * Loop over the parameter string. INEXT=2 DO 20 I=2,NWORD IF(I.LT.INEXT)GOTO 20 * Check for the number of drift-lines to be used. IF(INPCMP(I,'L#INES').NE.0)THEN IF(I+1.GT.NWORD.OR.FLAG(I+1))THEN CALL INPMSG(I,'The argument is missing. ') ELSEIF(INPTYP(I+1).LE.0)THEN CALL INPMSG(I+1,'The argument is not numeric. ') INEXT=I+2 ELSE CALL INPCHK(I+1,1,IFAIL) CALL INPRDI(I+1,NLTRR,NLTR) IF(IFAIL.EQ.0.AND.NLTRR.LT.4)THEN CALL INPMSG(I+1, - 'At least 4 lines are needed. ') ELSEIF(IFAIL.EQ.0.AND.NLTRR.GT.MXLIST-4)THEN CALL INPMSG(I+1, - 'Not more than MXLIST-4 lines. ') ELSEIF(IFAIL.EQ.0)THEN NLTR=NLTRR ENDIF INEXT=I+2 ENDIF * Check for the diffusion options. ELSEIF(INPCMP(I,'D#IFFUSION-#COEFFICIENT').NE.0)THEN IF(.NOT.GASOK(3))THEN CALL INPMSG(I,'No diffusion data are present.') ELSE LDIFF=.TRUE. ENDIF ELSEIF(INPCMP(I,'NOD#IFFUSION-#COEFFICIENT').NE.0)THEN LDIFF=.FALSE. * Check for the Townsend options. ELSEIF(INPCMP(I,'T#OWNSEND-#COEFFICIENT').NE.0)THEN IF(.NOT.GASOK(4))THEN CALL INPMSG(I,'No Townsend data are present. ') ELSE LTOWN=.TRUE. ENDIF ELSEIF(INPCMP(I,'NOT#OWNSEND-#COEFFICIENT').NE.0)THEN LTOWN=.FALSE. * Check for the attachment options. ELSEIF(INPCMP(I,'A#TTACHMENT-#COEFFICIENT').NE.0)THEN IF(.NOT.GASOK(6))THEN CALL INPMSG(I,'No attachment data are present') ELSE LATTA=.TRUE. ENDIF ELSEIF(INPCMP(I,'NOA#TTACHMENT-#COEFFICIENT').NE.0)THEN LATTA=.FALSE. * Unrecognised option. ELSE CALL INPMSG(I,'Invalid option, ignored. ') ENDIF 20 CONTINUE * Dump error messages. CALL INPERR * Call the preparation routine with proper arguments. CALL DLCTRP(XT0,YT0,ZT0,XT1,YT1,ZT1,LDIFF,LTOWN,LATTA,NLTR, - TMIN,TMAX,SMIN,SMAX,AMIN,AMAX,BMIN,BMAX,IFAIL) *** Reset various things. ELSEIF(INPCMP(1,'RESET').NE.0)THEN * No keywords, reset everything. IF(NWORD.EQ.1)THEN DO 110 K=1,MXSW DO 120 J=1,MXLIST SIGNAL(J,K,1)=0.0 SIGNAL(J,K,2)=0.0 120 CONTINUE 110 CONTINUE RESSET=.FALSE. AVATYP='NOT SET' SIGSET=.FALSE. CALL SIGIST('CLOSE',0,DUMMY,DUMMY,0,0,0,0,IFAIL1) IF(TYPE.NE.'MAP')THEN CALL BOOK('RELEASE','MATRIX','SIGNAL',IFAIL1) IF(IFAIL1.NE.0) - PRINT *,' !!!!!! SIGINP WARNING : Unable '// - 'to release signal matrix storage.' ENDIF ELSE * Otherwise, loop over the keywords. DO 70 I=2,NWORD IF(INPCMP(I,'SIG#NALS').NE.0)THEN DO 80 K=1,MXSW DO 90 J=1,MXLIST SIGNAL(J,K,1)=0.0 SIGNAL(J,K,2)=0.0 90 CONTINUE 80 CONTINUE ELSEIF(INPCMP(I,'RES#OLUTION')+INPCMP(I,'WIN#DOW')+ - INPCMP(I,'TIME-WIN#DOW').NE.0)THEN RESSET=.FALSE. ELSEIF(INPCMP(I,'AVA#LANCHE-#MODEL').NE.0)THEN AVATYP='NOT SET' ELSEIF(INPCMP(I,'MAT#RICES').NE.0)THEN SIGSET=.FALSE. CALL SIGIST('CLOSE',0,DUMMY,DUMMY,0,0,0,0,IFAIL1) IF(TYPE.NE.'MAP')THEN CALL BOOK('RELEASE','MATRIX','SIGNAL',IFAIL1) IF(IFAIL1.NE.0) - PRINT *,' !!!!!! SIGINP WARNING :'// - ' Unable to release signal matrix'// - ' storage.' ENDIF ELSE CALL INPMSG(I,'Not a known option.') ENDIF 70 CONTINUE * Print error messages. CALL INPERR ENDIF *** Look for the time window. ELSEIF(INPCMP(1,'RES#OLUTION')+INPCMP(1,'WIN#DOW')+ - INPCMP(1,'T#IME-WIN#DOW').NE.0)THEN IF(NWORD.EQ.1)THEN IF(RESSET)THEN CALL OUTFMT(TSTART,2,STR1,NC1,'LEFT') CALL OUTFMT(TSTART+(NTIME-1)*TDEV,2,STR2,NC2, - 'LEFT') CALL OUTFMT(REAL(NTIME),2,STR3,NC3,'LEFT') CALL OUTFMT(TDEV,2,STR4,NC4,'LEFT') WRITE(LUNOUT,'('' Time window: ['',A, - '', '',A,''] microsec, in '',A, - '' steps of '',A,'' microsec.'')') - STR1(1:NC1),STR2(1:NC2),STR3(1:NC3), - STR4(1:NC4) ELSE WRITE(LUNOUT,'('' The time window has not'', - '' yet been set.'')') ENDIF ELSEIF(NWORD.LE.4)THEN CALL INPCHK(2,2,IFAIL1) CALL INPCHK(3,2,IFAIL2) CALL INPCHK(4,1,IFAIL3) CALL INPRDR(2,TSTARR,TSTART) CALL INPRDR(3,TDEVR,TDEV) CALL INPRDI(4,NTIMER,NTIME) IF(IFAIL1.EQ.0.AND.TSTARR.LT.0.0)THEN CALL INPMSG(2,'The starting time is not > 0 ') IFAIL1=1 ENDIF IF(IFAIL2.EQ.0.AND.TDEVR.LE.0.0)THEN CALL INPMSG(3,'The time resolution is not > 0') IFAIL2=1 ENDIF IF(IFAIL3.EQ.0.AND. - (NTIMER.LE.1.OR.NTIMER.GT.MXLIST))THEN CALL INPMSG(4,'Number of samples not in range') IFAIL3=1 ENDIF * if the TSTART, TDEV read from input are > 0 transfer to TSTART, TDEV IF(IFAIL1.EQ.0)THEN IF(TSTART.NE.TSTARR)CHANGE=.TRUE. TSTART=TSTARR ELSE PRINT *,' !!!!!! SIGINP WARNING : Start time in'// - ' RESOLUTION is ignored because of errors' ENDIF IF(IFAIL2.EQ.0)THEN IF(TDEV.NE.TDEVR)CHANGE=.TRUE. TDEV=TDEVR ELSE PRINT *,' !!!!!! SIGINP WARNING : Resolution in'// - ' RESOLUTION is ignored because of errors.' ENDIF IF(IFAIL3.EQ.0)THEN IF(NTIMER.NE.NTIME)CHANGE=.TRUE. NTIME=NTIMER ELSE PRINT *,' !!!!!! SIGINP WARNING : Number of'// - ' samples in RESOLUTION ignored because'// - ' of errors.' ENDIF * Preset a vector of signal times. DO 40 I=1,MXLIST TIMSIG(I)=TSTART+(I-1)*TDEV DO 100 J=1,MXSW SIGNAL(I,J,1)=0.0 SIGNAL(I,J,2)=0.0 100 CONTINUE 40 CONTINUE RESSET=.TRUE. * Incorrect number of arguments. ELSE PRINT *,' !!!!!! SIGINP WARNING : RESOLUTION takes'// - ' 1, 2 or 3 arguments ; instruction is ignored.' ENDIF * Print error messages. CALL INPERR *** Search for the SELECT instruction. ELSEIF(INPCMP(1,'SEL#ECT').NE.0)THEN CALL CELSEL CHANGE=.TRUE. *** Start simulation if SIGNAL is a keyword. ELSEIF(INPCMP(1,'SIG#NAL').NE.0)THEN CALL SIGGEN(CHANGE) +SELF,IF=NEVER. *** The THRESHOLD command. ELSEIF(INPCMP(1,'THR#ESHOLD').NE.0)THEN CALL SIGTHR +SELF. *** Look for the instruction TRACK. ELSEIF(INPCMP(1,'TR#ACK').NE.0)THEN CALL TRAREA *** Write signals if WRITE-SIGNALS is a keyword. ELSEIF(INPCMP(1,'WR#ITE-S#IGNALS').NE.0)THEN CALL SIGWRT *** Write the track data if WRITE-TRACK is a keyword. ELSEIF(INPCMP(1,'WR#ITE-T#RACK').NE.0)THEN CALL DLCTRW *** The instruction is not known. ELSE CALL INPSTR(1,1,STRING,NC) PRINT *,' !!!!!! SIGINP WARNING : '//STRING(1:NC)//' is'// - ' not a valid instruction ; it is ignored.' ENDIF *** End loop over input. GOTO 10 *** Normal end of this routine: close scratch units if open. 60 CONTINUE INQUIRE(UNIT=13,OPENED=OPEN) IF(OPEN)CLOSE(UNIT=13,IOSTAT=IOS,ERR=2030) IF(SIGSET)THEN CALL SIGIST('CLOSE',0,DUMMY,DUMMY,0,0,0,0,IFAIL1) IF(TYPE.NE.'MAP')THEN CALL BOOK('RELEASE','MATRIX','SIGNAL',IFAIL1) IF(IFAIL1.NE.0)PRINT *,' !!!!!! SIGINP WARNING :'// - ' Unable to release signal matrix storage.' ENDIF SIGSET=.FALSE. ENDIF RETURN *** Handle error conditions. 2030 CONTINUE PRINT *,' !!!!!! SIGINP WARNING : Problems closing scratch'// - ' data set on unit 13 or 14 (used for intermediate'// - ' results);' PRINT *,' new simulations are'// - ' probably not possible.' CALL INPIOS(IOS) END +DECK,SIGGEN. SUBROUTINE SIGGEN(CHANGE) *----------------------------------------------------------------------- * SIGGEN - Routine computing a single signal. * VARIABLES : CHANGE : see routine SIGINP * (Last changed on 14/11/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,GASDATA. +SEQ,PARAMETERS. +SEQ,PRINTPLOT. +SEQ,DRIFTLINE. +SEQ,SIGNALDATA. INTEGER NASIMR,NISIMR,NORIAR,JIORDR,IFAIL,IFAIL1, - INEXT,I,J,NWORD,INPTYP,INPCMP REAL PRSR,XT0P,YT0P,XT1P,YT1P,XR0,XR1,YR0,YR1 DOUBLE PRECISION DUMMY(1) LOGICAL CHANGE,LSIGAD,LDIFF,LAVAL,LATTA,LTRACK,LTRMC,OK EXTERNAL INPTYP,INPCMP +SELF,IF=SAVE. SAVE LDIFF ,LAVAL ,LATTA ,LTRACK ,LTRMC +SELF. DATA LDIFF ,LAVAL ,LATTA ,LTRACK ,LTRMC - /.TRUE.,.TRUE.,.TRUE.,.FALSE.,.FALSE./ *** Identify the routine IF(LIDENT)PRINT *,' /// ROUTINE SIGGEN ///' *** Reset the addition flag each time. LSIGAD=.FALSE. *** Ensure that we can do this, assume for a start this is OK. OK=.TRUE. * Check location definition. IF(.NOT.TRFLAG(1))THEN PRINT *,' !!!!!! SIGGEN WARNING : The track location'// - ' has not been set.' OK=.FALSE. ELSE * Check that the track lies at least partially in the drift area. IF(POLAR)THEN IFAIL=0 CALL CFMCTR(XT0,YT0,XR0,YR0,1) CALL CFMCTR(XT1,YT1,XR1,YR1,1) IF(XR0.LT.DXMIN.OR.XR0.GT.DXMAX.OR. - XR1.LT.DXMIN.OR.XR1.GT.DXMAX.OR. - YR0.LT.DYMIN.OR.YR0.GT.DYMAX.OR. - YR1.LT.DYMIN.OR.YR1.GT.DYMAX)THEN PRINT *,' !!!!!! SIGGEN WARNING : The track'// - ' is located at least partialy outside'// - ' the drift area.' OK=.FALSE. ENDIF ELSE CALL CLIP3(XT0,YT0,ZT0,XT1,YT1,ZT1, - DXMIN,DYMIN,DZMIN,DXMAX,DYMAX,DZMAX,IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! SIGGEN WARNING : The track is'// - ' not located at least partially in the'// - ' drift area.' OK=.FALSE. ENDIF ENDIF ENDIF * Clustering model. IF(ITRTYP.EQ.0)THEN PRINT *,' !!!!!! SIGGEN WARNING : The clustering model'// - ' has yet not been set.' OK=.FALSE. ENDIF * Avalanche type. IF(AVATYP.EQ.'NOT SET')THEN PRINT *,' !!!!!! SIGGEN WARNING : The avalanche type has'// - ' not yet been set.' OK=.FALSE. ENDIF * Avalanche type. IF(.NOT.RESSET)THEN PRINT *,' !!!!!! SIGGEN WARNING : The time resolution has'// - ' not yet been set.' OK=.FALSE. DO 60 I=1,NTIME TIMSIG(I)=TSTART+(I-1)*TDEV 60 CONTINUE ENDIF * Return if not OK. IF(JFAIL.EQ.2.AND..NOT.OK)THEN PRINT *,' ###### SIGGEN ERROR : No signal simulation'// - ' because of the above warnings.' RETURN ELSEIF(JFAIL.EQ.3.AND..NOT.OK)THEN PRINT *,' ###### SIGGEN ERROR : Program terminated'// - ' because of the above warnings.' CALL QUIT ELSEIF(.NOT.OK)THEN PRINT *,' !!!!!! SIGGEN WARNING : No signal simulation'// - ' because of the above warnings.' RETURN ENDIF *** Decode the argument string. CALL INPNUM(NWORD) INEXT=2 DO 10 I=2,NWORD IF(I.LT.INEXT)GOTO 10 * Look for the electron-pulse options. IF(INPCMP(I,'NOELE#CTRON-#PULSE').NE.0)THEN LEPULS=.FALSE. ELSEIF(INPCMP(I,'ELE#CTRON-#PULSE').NE.0)THEN LEPULS=.TRUE. * Look for the ion-pulse options. ELSEIF(INPCMP(I,'NOION-T#AIL').NE.0)THEN LITAIL=.FALSE. LDTAIL=.FALSE. LRTAIL=.FALSE. ELSEIF(INPCMP(I,'ION-T#AIL')+ - INPCMP(I,'SIMPLE-ION-T#AIL').NE.0)THEN LITAIL=.TRUE. LDTAIL=.FALSE. LRTAIL=.FALSE. ELSEIF(INPCMP(I,'DET#AILED-I#ON-#TAIL').NE.0)THEN LITAIL=.FALSE. LDTAIL=.TRUE. LRTAIL=.FALSE. ELSEIF(INPCMP(I,'NONSAMP#LED-I#ON-#TAIL').NE.0)THEN LITAIL=.FALSE. LDTAIL=.FALSE. LRTAIL=.TRUE. * Look for the cross-talk options. ELSEIF(INPCMP(I,'NOCR#OSS-#INDUCED-#SIGNAL').NE.0)THEN LCROSS=.FALSE. ELSEIF(INPCMP(I,'CR#OSS-#INDUCED-#SIGNAL').NE.0)THEN IF(.NOT.LCROSS)CHANGE=.TRUE. LCROSS=.TRUE. * Look for the diffusion options. ELSEIF(INPCMP(I,'NODIFF#USION').NE.0)THEN LDIFF=.FALSE. ELSEIF(INPCMP(I,'DIFF#USION').NE.0)THEN LDIFF=.TRUE. * Look for the track interpolation options. ELSEIF(INPCMP(I,'NOINT#ERPOLATE-TR#ACK').NE.0)THEN LTRACK=.FALSE. ELSEIF(INPCMP(I,'INT#ERPOLATE-TR#ACK').NE.0)THEN IF(.NOT.TRASET)THEN CALL INPMSG(I,'The track is not prepared.') ELSE LTRACK=.TRUE. ENDIF * Look for the Monte Carlo option. ELSEIF(INPCMP(I,'NOMC-DR#IFT-#LINES')+ - INPCMP(I,'NOM#ONTE-C#ARLO-DR#IFT-#LINES')+ - INPCMP(I,'RUN#GE-K#UTTA-DR#IFT-#LINES').NE.0)THEN LTRMC=.FALSE. ELSEIF(INPCMP(I,'MC-DR#IFT-#LINES')+ - INPCMP(I,'M#ONTE-C#ARLO-DR#IFT-#LINES').NE.0)THEN LTRMC=.TRUE. * Look for the avalanche options. ELSEIF(INPCMP(I,'NOAVAL#ANCHE').NE.0)THEN LAVAL=.FALSE. ELSEIF(INPCMP(I,'AVAL#ANCHE').NE.0)THEN IF(AVATYP.EQ.'NOT SET')PRINT *,' !!!!!! SIGGEN WARNING :', - ' No avalanche specification seen so far; fixed', - ' (perhaps default) factor used.' LAVAL=.TRUE. * Look for the attachment options. ELSEIF(INPCMP(I,'NOATT#ACHMENT').NE.0)THEN LATTA=.FALSE. ELSEIF(INPCMP(I,'ATT#ACHMENT').NE.0)THEN IF(.NOT.GASOK(6))THEN CALL INPMSG(I,'No attachment data') ELSE LATTA=.TRUE. ENDIF * Look for the ADD/NEW option. ELSEIF(INPCMP(I,'ADD').NE.0)THEN LSIGAD=.TRUE. ELSEIF(INPCMP(I,'NEW').NE.0)THEN LSIGAD=.FALSE. * Look for an angular spread function. ELSEIF(INPCMP(I,'ANG#ULAR-SP#READ').NE.0)THEN IF(NWORD.LT.I+1)THEN CALL INPMSG(I,'The function is missing.') ELSEIF(INPCMP(I+1,'FL#AT').NE.0)THEN NCANG=1 FCNANG='1' IENANG=0 LITAIL=.TRUE. ELSE IENANG=0 LITAIL=.TRUE. CALL INPSTR(I+1,I+1,FCNANG,NCANG) ENDIF INEXT=I+2 ELSEIF(INPCMP(I,'NOANG#ULAR-SP#READ').NE.0)THEN IENANG=0 NCANG=0 * Look for angular integration options. ELSEIF(INPCMP(I,'ANG#ULAR-INT#EGRATION-P#OINTS').NE.0)THEN IF(INPTYP(I+1).EQ.1)THEN CALL INPCHK(I+1,1,IFAIL1) CALL INPRDI(I+1,NASIMR,2) IF(NASIMR.GT.0)THEN NASIMP=NASIMR LITAIL=.TRUE. ELSE CALL INPMSG(I+1,'Number out of range.') ENDIF INEXT=I+2 ELSEIF(INPTYP(I+1).EQ.4)THEN NASIMP=2 INEXT=I+2 LITAIL=.TRUE. ENDIF * Look for number of ion angles. ELSEIF(INPCMP(I,'ION-ANG#LES').NE.0)THEN IF(INPCMP(I+1,'NOSAMP#LING')+INPCMP(I+1,'NOSAMP#LES')+ - INPCMP(I+1,'INF#INITE').NE.0)THEN LRTAIL=.TRUE. ELSEIF(INPTYP(I+1).EQ.1)THEN CALL INPCHK(I+1,1,IFAIL1) CALL INPRDI(I+1,NORIAR,MXORIA) IF(NORIAR.GE.1.AND.NORIAR.LE.MXORIA)THEN IF(NORIAR.NE.NORIA)CHANGE=.TRUE. LITAIL=.TRUE. NORIA=NORIAR ELSE CALL INPMSG(I+1,'Number out of range.') ENDIF INEXT=I+2 ELSEIF(INPTYP(I+1).EQ.4)THEN LITAIL=.TRUE. NORIA=MIN(50,MXORIA) INEXT=I+2 ENDIF * Look for signal averaging / sampling options. ELSEIF(INPCMP(I,'SAMP#LE-#SIGNAL').NE.0)THEN NISIMP=0 ELSEIF(INPCMP(I,'AVER#AGE-#SIGNAL').NE.0)THEN IF(INPTYP(I+1).EQ.1)THEN CALL INPCHK(I+1,1,IFAIL1) CALL INPRDI(I+1,NISIMR,2) IF(NISIMR.GT.0.AND.IFAIL1.EQ.0)THEN NISIMP=NISIMR ELSE CALL INPMSG(I+1,'Not a valid number.') ENDIF INEXT=I+2 ELSEIF(INPTYP(I+1).EQ.4)THEN NISIMP=2 INEXT=I+2 ENDIF * Signal interpolation order. ELSEIF(INPCMP(I,'INT#ERPOLATION-ORD#ER').NE.0)THEN IF(INPTYP(I+1).EQ.1)THEN CALL INPCHK(I+1,1,IFAIL1) CALL INPRDI(I+1,JIORDR,2) IF(JIORDR.GT.0.AND.IFAIL1.EQ.0)THEN JIORD=JIORDR ELSE CALL INPMSG(I+1,'Not a valid number.') ENDIF INEXT=I+2 ELSEIF(INPTYP(I+1).EQ.4)THEN JIORD=1 INEXT=I+2 ENDIF * Ion production threshold. ELSEIF(INPCMP(I,'ION-THR#ESHOLD').NE.0)THEN IF(INPTYP(I+1).EQ.1)THEN CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,PRSR,PRSTHR) IF(PRSR.GE.0.AND.PRSR.LT.1.AND.IFAIL1.EQ.0)THEN PRSTHR=PRSR LDTAIL=.TRUE. ELSE CALL INPMSG(I+1,'Not a valid number.') ENDIF INEXT=I+2 ELSEIF(INPTYP(I+1).EQ.4)THEN PRSTHR=1.0E-4 INEXT=I+2 LDTAIL=.TRUE. ENDIF * The option is not known. ELSE CALL INPMSG(I,'The option is not known. ') ENDIF 10 CONTINUE *** Print the error messages. CALL INPERR *** Check consistency of options. IF(LTRACK.AND.LEPULS)THEN PRINT *,' !!!!!! SIGGEN WARNING : The INTERPOLATE-TRACK'// - ' and ELECTRON-PULSE options' PRINT *,' are mutually exclusive'// - ' ; INTERPOLATE-TRACK cancelled.' LTRACK=.FALSE. ENDIF IF(LTRACK.AND.LDTAIL)THEN PRINT *,' !!!!!! SIGGEN WARNING : The INTERPOLATE-TRACK'// - ' and DETAILED-ION-TAIL options' PRINT *,' are mutually exclusive'// - ' ; INTERPOLATE-TRACK cancelled.' LTRACK=.FALSE. ENDIF IF(LTRACK.AND.LTRMC)THEN PRINT *,' !!!!!! SIGGEN WARNING : The INTERPOLATE-TRACK'// - ' and MONTE-CARLO-TRACKS options' PRINT *,' are mutually exclusive'// - ' ; INTERPOLATE-TRACK cancelled.' LTRACK=.FALSE. ENDIF IF(LEPULS.AND..NOT.GASOK(4))THEN PRINT *,' !!!!!! SIGGEN WARNING : ELECTRON-PULSE has been'// - ' requested, but the Townsend' PRINT *,' coefficients are'// - ' missing ; ELECTRON-PULSE cancelled.' LEPULS=.FALSE. ENDIF IF(LTRMC.AND..NOT.LDIFF)THEN PRINT *,' !!!!!! SIGGEN WARNING : DIFFUSION is implied'// - ' by MC-DRIFT; diffusion included.' ENDIF *** Make sure we don't have LATTA on and the data absent. LATTA=LATTA.AND.GASOK(6) *** Check the correct use of ADD and NEW. IF(LSIGAD.AND.CHANGE)PRINT *,' !!!!!! SIGGEN WARNING : New'// - ' signal cannot be added to old one since you changed'// - ' a parameter.' IF((.NOT.LSIGAD).OR.CHANGE)THEN DO 30 I=1,MXSW DO 20 J=1,MXLIST SIGNAL(J,I,1)=0.0 SIGNAL(J,I,2)=0.0 20 CONTINUE 30 CONTINUE ENDIF *** Make sure at least some signal output is requested. IF(.NOT.(LEPULS.OR.LITAIL.OR.LDTAIL.OR.LRTAIL))THEN PRINT *,' !!!!!! SIGGEN WARNING : Neither electron pulses'// - ' nor ion tails are to be included ; no simulation.' RETURN ENDIF IF(NSW.EQ.0)THEN PRINT *,' !!!!!! SIGGEN WARNING : No sense wires has been'// - ' selected ; no signals calculated.' RETURN ENDIF *** Initialise the matrices, cell type and signal storage. IF(.NOT.SIGSET)THEN CALL SIGINI(IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! SIGGEN WARNING : Initialisation of'// - ' signal calculation failed; no signals.' RETURN ENDIF ENDIF *** Print a header, if cluster printing has been enabled. IF(LCLPRT)THEN IF(POLAR)THEN CALL CFMCTP(XT0,YT0,XT0P,YT0P,1) CALL CFMCTP(XT1,YT1,XT1P,YT1P,1) ELSE XT0P=XT0 YT0P=YT0 XT1P=XT1 YT1P=YT1 ENDIF WRITE(LUNOUT,'('' Signal simulation:''/ - '' ==================''// - '' The track begins at ('', - E15.8,2('','',E15.8),'')''/ - '' and ends at ('', - E15.8,2('','',E15.8),'')''/)') - XT0P,YT0P,ZT0,XT1P,YT1P,ZT1 CALL CELPRC(LUNOUT,0) ENDIF *** Open/reset the storage file. IF(CHANGE)THEN CALL SIGIST('RESET',0,DUMMY,DUMMY,0,0,0,0,IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! SIGGEN WARNING : Unable to'// - ' reset a signal storage file; no signals.' RETURN ENDIF ENDIF *** Start simulation by generating clusters, also add signals. CALL SIGCLS(LDIFF,LAVAL,LATTA,LTRACK,LTRMC,IFAIL) IF(IENANG.GT.0)CALL ALGCLR(IENANG) IF(IFAIL.EQ.1)THEN PRINT *,' !!!!!! SIGGEN WARNING : Cluster generation'// - ' failed ; no signal calculation.' RETURN ENDIF *** Reset the CHANGE flag. CHANGE=.FALSE. *** Register the amount of CPU time used. CALL TIMLOG('Generating a signal: ') END +DECK,SIGINI. SUBROUTINE SIGINI(IFAIL) *----------------------------------------------------------------------- * SIGINI - Initialises signal calculations. * (Last changed on 8/ 9/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,SIGNALDATA. +SEQ,PRINTPLOT. INTEGER IFAIL,IFAIL1 DOUBLE PRECISION DUMMY(1) *** Assume that the routine will fail. IFAIL=1 *** Determine the cell type after eliminating true periodicities. IF(TYPE.EQ.'A '.OR.TYPE.EQ.'B1X'.OR. - TYPE.EQ.'B1Y'.OR.TYPE.EQ.'C1 ')THEN FCELTP='A ' ELSEIF(TYPE.EQ.'B2X'.OR.TYPE.EQ.'C2X')THEN FCELTP='B2X' ELSEIF(TYPE.EQ.'B2Y'.OR.TYPE.EQ.'C2Y')THEN FCELTP='B2Y' ELSEIF(TYPE.EQ.'C3 ')THEN FCELTP='C3 ' ELSEIF(TYPE.EQ.'D1 ')THEN FCELTP='D1 ' ELSEIF(TYPE.EQ.'D3 ')THEN FCELTP='D3 ' ELSEIF(TYPE.EQ.'MAP')THEN FCELTP='MAP' ELSE PRINT *,' !!!!!! SIGINI WARNING : No potentials available'// - ' to handle cell type '//TYPE//'; no signals.' RETURN ENDIF *** Establish the directions in which convolutions occur. FPERX=.FALSE. FPERY=.FALSE. IF(TYPE.EQ.'B1X'.OR.TYPE.EQ.'C1 '.OR.TYPE.EQ.'C2Y')FPERX=.TRUE. IF(TYPE.EQ.'B1Y'.OR.TYPE.EQ.'C1 '.OR.TYPE.EQ.'C2X')FPERY=.TRUE. MFEXP=INT(0.1+LOG(1.0*NFOUR)/LOG(2.0)) IF(MFEXP.EQ.0)FPERX=.FALSE. IF(MFEXP.EQ.0)FPERY=.FALSE. *** Set maximum and minimum Fourier terms. MXMIN=0 MYMIN=0 MXMAX=0 MYMAX=0 IF(FPERX)MXMIN=MIN(0,-NFOUR/2+1) IF(FPERX)MXMAX=+NFOUR/2 IF(FPERY)MYMIN=MIN(0,-NFOUR/2+1) IF(FPERY)MYMAX=+NFOUR/2 *** Print some debugging output if requested. IF(LDEBUG)WRITE(LUNOUT,'( - '' ++++++ SIGINI DEBUG : Cell type = '',A3/ - 26X,''Fourier cell type = '',A3/ - 26X,''x convolutions = '',L1/ - 26X,''y convolutions = '',L1/ - 26X,''No of Fourier terms = '',I3,'' (= 2**'',I3,'')'')') - TYPE,FCELTP,FPERX,FPERY,NFOUR,MFEXP *** Prepare the signal matrices. IF(TYPE.NE.'MAP')THEN CALL SIGIPR(IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! SIGINI WARNING : Preparing'// - ' wire signal capacitance matrices failed;'// - ' no signals.' RETURN ENDIF CALL SIGPLP(IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! SIGINI WARNING : Preparing'// - ' plane charges failed; no signals.' RETURN ENDIF ENDIF *** And open the signal file. CALL SIGIST('OPEN',0,DUMMY,DUMMY,0,0,0,0,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! SIGINI WARNING : Unable to'// - ' open a signal storage file; no signals.' RETURN ENDIF *** Seems to have worked. IFAIL=0 SIGSET=.TRUE. END +DECK,SIGIPR. SUBROUTINE SIGIPR(IFAIL) *----------------------------------------------------------------------- * SIGIPR - Prepares the ion tail calculation by filling the signal * matrices (ie non-periodic capacitance matrices), * Fourier transforming them if necessary, inverting them and * Fourier transforming them back. Because of the large number * of terms involved, a (scratch) external file on unit 13 is * used to store the intermediate and final results. This file * is handled by the routines IONBGN and IONIO. * VARIABLES : FFTMAT : Matrix used for Fourier transforms. * (Last changed on 5/ 4/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,SIGNALDATA. +SEQ,PRINTPLOT. +SEQ,SIGNALMATRIX. COMPLEX FFTMAT(MXFOUR,MXWIRE) INTEGER IFAIL,MX,MY,I,J,II,JJ,M,IOS *** Identify the routine. IF(LIDENT)PRINT *,' /// ROUTINE SIGIPR ///' *** Set some parameters. IFAIL=0 *** Book the signal matrices. CALL BOOK('BOOK','MATRIX','SIGNAL',IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! SIGIPR WARNING : Unable to obtain'// - ' signal matrix storage; no induced currents.' RETURN ENDIF *** Open unit 13 for writing of matrices if Fourier transf. are needed. IF(FPERX.OR.FPERY)THEN CALL IONBGN(IFAIL) IF(IFAIL.EQ.1)THEN PRINT *,' !!!!!! SIGIPR WARNING : No storage'// - ' available for the signal matrices; no'// - ' induced currents.' RETURN ENDIF ENDIF *** Have the matrix/matrices filled (and stored). DO 10 MX=MXMIN,MXMAX DO 20 MY=MYMIN,MYMAX * Select layer to be produced. IF(FCELTP.EQ.'A ')CALL IPRA00(MX,MY) IF(FCELTP.EQ.'B2X')CALL IPRB2X(MY) IF(FCELTP.EQ.'B2Y')CALL IPRB2Y(MX) IF(FCELTP.EQ.'C3 ')CALL IPRC30 IF(FCELTP.EQ.'D1 ')CALL IPRD10 IF(FCELTP.EQ.'D3 ')CALL IPRD30 IF(LDEBUG)PRINT *,' ++++++ SIGIPR DEBUG : Signal matrix MX=', - MX,' MY=',MY,' has been calculated.' * Store the matrix. IF(FPERX.OR.FPERY)CALL IONIO(MX,MY,1,0,IFAIL) * Quit if storing failed. IF(IFAIL.NE.0)GOTO 2010 * Dump the signal matrix before inversion, if DEBUG is requested. IF(LDEBUG)THEN WRITE(LUNOUT,'(/'' ++++++ SIGIPR DEBUG : Dump of'', - '' signal matrix ('',I2,'','',I2,'') before'', - '' inversion follows:''/)') MX,MY DO 710 I=0,NWIRE-1,10 DO 720 J=0,NWIRE-1,10 WRITE(LUNOUT,'('' Re-Block '',I2,''.'',I2/)') I/10,J/10 DO 730 II=1,10 IF(I+II.GT.NWIRE)GOTO 730 WRITE(LUNOUT,'(2X,10(E12.5,1X:))') - (REAL(SIGMAT(I+II,J+JJ)),JJ=1,MIN(NWIRE-J,10)) 730 CONTINUE WRITE(LUNOUT,'('' Im-Block '',I2,''.'',I2/)') I/10,J/10 DO 740 II=1,10 IF(I+II.GT.NWIRE)GOTO 740 WRITE(LUNOUT,'(2X,10(E12.5,1X:))') - (AIMAG(SIGMAT(I+II,J+JJ)),JJ=1,MIN(NWIRE-J,10)) 740 CONTINUE 720 CONTINUE 710 CONTINUE WRITE(LUNOUT,'(/'' ++++++ SIGIPR DEBUG : End of the'', - '' uninverted capacitance matrix dump.''/)') ENDIF * Next layer. 20 CONTINUE 10 CONTINUE *** Have them fourier transformed (singly periodic case). IF((FPERX.AND..NOT.FPERY).OR.(FPERY.AND..NOT.FPERX))THEN DO 30 I=1,NWIRE DO 40 M=-NFOUR/2+1,NFOUR/2 CALL IONIO(M,M,2,I,IFAIL) IF(IFAIL.NE.0)GOTO 2010 DO 50 J=1,NWIRE FFTMAT(M+NFOUR/2,J)=SIGMAT(I,J) 50 CONTINUE 40 CONTINUE DO 60 J=1,NWIRE CALL CFFT(FFTMAT(1,J),MFEXP) 60 CONTINUE DO 70 M=-NFOUR/2+1,NFOUR/2 CALL IONIO(M,M,2,I,IFAIL) IF(IFAIL.NE.0)GOTO 2010 DO 80 J=1,NWIRE SIGMAT(I,J)=FFTMAT(M+NFOUR/2,J) 80 CONTINUE CALL IONIO(M,M,1,I,IFAIL) IF(IFAIL.NE.0)GOTO 2010 70 CONTINUE 30 CONTINUE ENDIF * have them fourier transformed (doubly periodic case). IF(FPERX.AND.FPERY)THEN DO 100 I=1,NWIRE DO 110 MX=MXMIN,MXMAX DO 120 MY=MYMIN,MYMAX CALL IONIO(MX,MY,2,I,IFAIL) IF(IFAIL.NE.0)GOTO 2010 DO 130 J=1,NWIRE FFTMAT(MY+NFOUR/2,J)=SIGMAT(I,J) 130 CONTINUE 120 CONTINUE DO 140 J=1,NWIRE CALL CFFT(FFTMAT(1,J),MFEXP) 140 CONTINUE DO 150 MY=MYMIN,MYMAX CALL IONIO(MX,MY,2,I,IFAIL) IF(IFAIL.NE.0)GOTO 2010 DO 160 J=1,NWIRE SIGMAT(I,J)=FFTMAT(MY+NFOUR/2,J) 160 CONTINUE CALL IONIO(MX,MY,1,I,IFAIL) IF(IFAIL.NE.0)GOTO 2010 150 CONTINUE 110 CONTINUE DO 170 MY=MYMIN,MYMAX DO 180 MX=MXMIN,MXMAX CALL IONIO(MX,MY,2,I,IFAIL) IF(IFAIL.NE.0)GOTO 2010 DO 190 J=1,NWIRE FFTMAT(MX+NFOUR/2,J)=SIGMAT(I,J) 190 CONTINUE 180 CONTINUE DO 200 J=1,NWIRE CALL CFFT(FFTMAT(1,J),MFEXP) 200 CONTINUE DO 210 MX=MXMIN,MXMAX CALL IONIO(MX,MY,2,I,IFAIL) IF(IFAIL.NE.0)GOTO 2010 DO 220 J=1,NWIRE SIGMAT(I,J)=FFTMAT(MX+NFOUR/2,J) 220 CONTINUE CALL IONIO(MX,MY,1,I,IFAIL) IF(IFAIL.NE.0)GOTO 2010 210 CONTINUE 170 CONTINUE 100 CONTINUE ENDIF *** Invert the matrices. DO 300 MX=MXMIN,MXMAX DO 310 MY=MYMIN,MYMAX * Retrieve the layer. IF(FPERX.OR.FPERY)THEN CALL IONIO(MX,MY,2,0,IFAIL) IF(IFAIL.NE.0)GOTO 2010 ENDIF * Invert. IF(NWIRE.GE.1)CALL CINV(NWIRE,SIGMAT,MXWIRE,IWORK,IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! SIGIPR WARNING : Inversion of signal', - ' matrix (',MX,',',MY,') failed; no reliable', - ' results; ion tail preparation is abandoned.' IFAIL=1 RETURN ENDIF * Store the matrix back. IF(FPERX.OR.FPERY)THEN CALL IONIO(MX,MY,1,0,IFAIL) IF(IFAIL.NE.0)GOTO 2010 ENDIF * Next layer. 310 CONTINUE 300 CONTINUE *** And transform the matrices back to the original domain. IF((FPERX.AND..NOT.FPERY).OR.(FPERY.AND..NOT.FPERX))THEN DO 410 I=1,NWIRE DO 420 M=-NFOUR/2+1,NFOUR/2 CALL IONIO(M,M,2,I,IFAIL) IF(IFAIL.NE.0)GOTO 2010 DO 430 J=1,NWIRE FFTMAT(M+NFOUR/2,J)=SIGMAT(I,J) 430 CONTINUE 420 CONTINUE DO 440 J=1,NWIRE CALL CFFT(FFTMAT(1,J),-MFEXP) 440 CONTINUE DO 450 M=-NFOUR/2+1,NFOUR/2 CALL IONIO(M,M,2,I,IFAIL) IF(IFAIL.NE.0)GOTO 2010 DO 460 J=1,NWIRE SIGMAT(I,J)=FFTMAT(M+NFOUR/2,J)/NFOUR 460 CONTINUE CALL IONIO(M,M,1,I,IFAIL) IF(IFAIL.NE.0)GOTO 2010 450 CONTINUE 410 CONTINUE ENDIF * have them transformed to the original domain (doubly periodic). IF(FPERX.AND.FPERY)THEN DO 500 I=1,NWIRE DO 510 MX=MXMIN,MXMAX DO 520 MY=MYMIN,MYMAX CALL IONIO(MX,MY,2,I,IFAIL) IF(IFAIL.NE.0)GOTO 2010 DO 530 J=1,NWIRE FFTMAT(MY+NFOUR/2,J)=SIGMAT(I,J) 530 CONTINUE 520 CONTINUE DO 540 J=1,NWIRE CALL CFFT(FFTMAT(1,J),-MFEXP) 540 CONTINUE DO 550 MY=MYMIN,MYMAX CALL IONIO(MX,MY,2,I,IFAIL) IF(IFAIL.NE.0)GOTO 2010 DO 560 J=1,NWIRE SIGMAT(I,J)=FFTMAT(MY+NFOUR/2,J)/NFOUR 560 CONTINUE CALL IONIO(MX,MY,1,I,IFAIL) IF(IFAIL.NE.0)GOTO 2010 550 CONTINUE 510 CONTINUE DO 570 MY=MYMIN,MYMAX DO 580 MX=MXMIN,MXMAX CALL IONIO(MX,MY,2,I,IFAIL) IF(IFAIL.NE.0)GOTO 2010 DO 590 J=1,NWIRE FFTMAT(MX+NFOUR/2,J)=SIGMAT(I,J) 590 CONTINUE 580 CONTINUE DO 600 J=1,NWIRE CALL CFFT(FFTMAT(1,J),-MFEXP) 600 CONTINUE DO 610 MX=MXMIN,MXMAX CALL IONIO(MX,MY,2,I,IFAIL) IF(IFAIL.NE.0)GOTO 2010 DO 620 J=1,NWIRE SIGMAT(I,J)=FFTMAT(MX+NFOUR/2,J)/NFOUR 620 CONTINUE CALL IONIO(MX,MY,1,I,IFAIL) IF(IFAIL.NE.0)GOTO 2010 610 CONTINUE 570 CONTINUE 500 CONTINUE ENDIF *** Dump the signal matrix after inversion, if DEBUG is requested. IF(LDEBUG)THEN DO 750 MX=MXMIN,MXMAX DO 760 MY=MYMIN,MYMAX WRITE(LUNOUT,'(/'' ++++++ SIGIPR DEBUG : Dump of'', - '' signal matrix ('',I2,'','',I2,'') after'', - '' inversion follows:''/)') MX,MY DO 770 I=0,NWIRE-1,10 DO 780 J=0,NWIRE-1,10 WRITE(LUNOUT,'('' Re-Block '',I2,''.'',I2/)') I/10,J/10 DO 790 II=1,10 IF(I+II.GT.NWIRE)GOTO 790 WRITE(LUNOUT,'(2X,10(E12.5,1X:))') - (REAL(SIGMAT(I+II,J+JJ)),JJ=1,MIN(NWIRE-J,10)) 790 CONTINUE WRITE(LUNOUT,'('' Im-Block '',I2,''.'',I2/)') I/10,J/10 DO 800 II=1,10 IF(I+II.GT.NWIRE)GOTO 800 WRITE(LUNOUT,'(2X,10(E12.5,1X:))') - (AIMAG(SIGMAT(I+II,J+JJ)),JJ=1,MIN(NWIRE-J,10)) 800 CONTINUE 780 CONTINUE 770 CONTINUE WRITE(LUNOUT,'(/'' ++++++ SIGIPR DEBUG : End of the'', - '' inverted capacitance matrix dump.''/)') 760 CONTINUE 750 CONTINUE ENDIF *** Register the amount of CPU time used for these manipulations. CALL TIMLOG('Preparing the ion tail calculation: ') RETURN *** Handle error conditions. 2010 CONTINUE PRINT *,' !!!!!! SIGIPR WARNING : Ion tail preparation stopped'// - ' because of an I/O error; resubmit or set'// - ' fourier to 1 (see writeup)' CALL INPIOS(IOS) CLOSE(UNIT=13,IOSTAT=IOS,ERR=2030) IFAIL=1 RETURN 2030 CONTINUE PRINT *,' ###### SIGIPR ERROR : Problems closing scratch'// - ' data set on unit 13 (used for intermediate'// - ' results)' PRINT *,' CLOSE was attempted because'// - ' of a previous error condition' CALL INPIOS(IOS) IFAIL=1 END +DECK,IPRA00. SUBROUTINE IPRA00(MX,MY) *----------------------------------------------------------------------- * IPRA00 - Routine filling the (MX,MY) th layer of the signal matrix * for cells with non-periodic type A (see SIGIPR). *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,SIGNALMATRIX. +SEQ,CELLDATA. DX=MX*SX DY=MY*SY DO 10 I=1,NWIRE *** DIAGONAL TERMS IF(DX.NE.0.0.OR.DY.NE.0.0)THEN AA=DX**2+DY**2 ELSE AA=0.25*D(I)**2 ENDIF * Take care of single equipotential planes. IF(YNPLAX)AA=AA/((2.0*(X(I)-COPLAX))**2+DY**2) IF(YNPLAY)AA=AA/((2.0*(Y(I)-COPLAY))**2+DX**2) * Take care of pairs of equipotential planes. IF(YNPLAX.AND.YNPLAY)AA=AA*4.*((X(I)-COPLAX)**2+(Y(I)-COPLAY)**2) *** Define the final version of A(I,I). SIGMAT(I,I)=-0.5*LOG(AA) DO 20 J=I+1,NWIRE AA=(X(I)+DX-X(J))**2+(Y(I)+DY-Y(J))**2 * Take care of single planes. IF(YNPLAX)AA=AA/((2.0*COPLAX-X(I)-DX-X(J))**2+(Y(I)+DY-Y(J))**2) IF(YNPLAY)AA=AA/((X(I)+DX-X(J))**2+(2.0*COPLAY-Y(I)-DY-Y(J))**2) * Take care of pairs of planes. IF(YNPLAX.AND.YNPLAY)AA=AA*((2.*COPLAX-X(I)-DX-X(J))**2+ - (2.*COPLAY-Y(I)-DY-Y(J))**2) * Store the true versions after taking LOGs and SQRT's. SIGMAT(I,J)=-0.5*LOG(AA) SIGMAT(J,I)=SIGMAT(I,J) 20 CONTINUE 10 CONTINUE END +DECK,IPRB2X. SUBROUTINE IPRB2X(MY) *----------------------------------------------------------------------- * IPRB2X - Routine filling the MY th layer of the signal matrix * for cells with non-periodic type B2X (see SIGIPR). * (Last changed on 26/ 4/92.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,SIGNALMATRIX. +SEQ,CELLDATA. +SEQ,CONSTANTS. DY=MY*SY *** Loop over all wires and calculate the diagonal elements first. DO 10 I=1,NWIRE XX=(PI/SX)*(X(I)-COPLAN(1)) IF(DY.NE.0.0)THEN AA=(SINH(PI*DY/SX)/SIN(XX))**2 ELSE AA=((0.25*D(I)*PI/SX)/SIN(XX))**2 ENDIF * Take care of a planes at constant y (no dy in this case). IF(YNPLAY)THEN YYMIRR=(PI/SX)*(Y(I)-COPLAY) IF(ABS(YYMIRR).LE.20.0) AA=AA* - (SINH(YYMIRR)**2+SIN(XX)**2)/SINH(YYMIRR)**2 ENDIF * Store the true value of A(I,I). SIGMAT(I,I)=-0.5*LOG(AA) *** Loop over all other wires to obtain off-diagonal elements. DO 20 J=I+1,NWIRE YY=0.5*PI*(Y(I)+DY-Y(J))/SX XX=0.5*PI*(X(I)-X(J))/SX XXNEG=0.5*PI*(X(I)+X(J)-2.0*COPLAN(1))/SX IF(ABS(YY).LT.20.0)THEN AA=(SINH(YY)**2+SIN(XX)**2)/(SINH(YY)**2+SIN(XXNEG)**2) ELSE AA=1.0 ENDIF * Take equipotential planes into account (no dy anyhow). IF(YNPLAY)THEN YYMIRR=0.5*PI*(Y(I)+Y(J)-2.0*COPLAY)/SX IF(ABS(YYMIRR).LE.20.0) AA=AA* - (SINH(YYMIRR)**2+SIN(XXNEG)**2)/(SINH(YYMIRR)**2+SIN(XX)**2) ENDIF *** Store the true value of A(I,J) in both A(I,J) and A(J,I). SIGMAT(I,J)=-0.5*LOG(AA) SIGMAT(J,I)=SIGMAT(I,J) *** Finish the wire loops. 20 CONTINUE *** Fill the B2SIN vector. B2SIN(I)=SIN(PI*(COPLAN(1)-X(I))/SX) 10 CONTINUE END +DECK,IPRB2Y. SUBROUTINE IPRB2Y(MX) *----------------------------------------------------------------------- * IPRB2Y - Routine filling the MX th layer of the signal matrix * for cells with non-periodic type B2Y (see SIGIPR). * (Last changed on 26/ 4/92.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,SIGNALMATRIX. +SEQ,CELLDATA. +SEQ,CONSTANTS. DX=MX*SX *** Loop over all wires and calculate the diagonal elements first. DO 10 I=1,NWIRE YY=(PI/SY)*(Y(I)-COPLAN(3)) IF(DX.NE.0.0)THEN AA=(SINH(PI*DX/SY)/SIN(YY))**2 ELSE AA=((0.25*D(I)*PI/SY)/SIN(YY))**2 ENDIF * Take care of a plane at constant x (no dx in this case). IF(YNPLAX)THEN XXMIRR=(PI/SY)*(X(I)-COPLAX) IF(ABS(XXMIRR).LE.20.0) AA=AA* - (SINH(XXMIRR)**2+SIN(YY)**2)/SINH(XXMIRR)**2 ENDIF * Store the true value of A(I,I). SIGMAT(I,I)=-0.5*LOG(AA) *** Loop over all other wires to obtain off-diagonal elements. DO 20 J=I+1,NWIRE XX=0.5*PI*(X(I)+DX-X(J))/SY YY=0.5*PI*(Y(I)-Y(J))/SY YYNEG=0.5*PI*(Y(I)+Y(J)-2.0*COPLAN(3))/SY IF(ABS(XX).LE.20.0)THEN AA=(SINH(XX)**2+SIN(YY)**2)/(SINH(XX)**2+SIN(YYNEG)**2) ELSE AA=1.0 ENDIF * Take equipotential planes into account (dx=0 anyhow). IF(YNPLAX)THEN XXMIRR=0.5*PI*(X(I)+X(J)-2.0*COPLAX)/SX IF(ABS(XXMIRR).LE.20.0) AA=AA* - (SINH(XXMIRR)**2+SIN(YYNEG)**2)/(SINH(XXMIRR)**2+SIN(YY)**2) ENDIF *** Store the true value of A(I,J) in both A(I,J) and A(J,I). SIGMAT(I,J)=-0.5*LOG(AA) SIGMAT(J,I)=SIGMAT(I,J) *** Finish the wire loops. 20 CONTINUE *** Fill the B2SIN vector. B2SIN(I)=SIN(PI*(COPLAN(3)-Y(I))/SY) 10 CONTINUE END +DECK,IPRC30. SUBROUTINE IPRC30 *----------------------------------------------------------------------- * IPRC30 - Routine filling the signal matrix for cells of type C30. * Since the signal matrix equals the capacitance matrix for * this potential, the routine is identical to SETC30 except * for the C and P parameters. * (Last changed on 11/11/97.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,SIGNALMATRIX. +SEQ,CONSTANTS. INTEGER I,J REAL CX,CY,PH2,PH2LIM EXTERNAL PH2,PH2LIM *** Fill the capacitance matrix. DO 10 I=1,NWIRE CX=COPLAX-SX*ANINT((COPLAX-X(I))/SX) CY=COPLAY-SY*ANINT((COPLAY-Y(I))/SY) DO 20 J=1,NWIRE IF(I.EQ.J)THEN SIGMAT(I,I)=PH2LIM(0.5*D(I))- - PH2(0.0,2*(Y(I)-CY))- - PH2(2*(X(I)-CX),0.0)+ - PH2(2*(X(I)-CX),2*(Y(I)-CY)) ELSE SIGMAT(I,J)=PH2(X(I)-X(J),Y(I)-Y(J))- - PH2(X(I)-X(J),Y(I)+Y(J)-2*CY)- - PH2(X(I)+X(J)-2*CX,Y(I)-Y(J))+ - PH2(X(I)+X(J)-2*CX,Y(I)+Y(J)-2*CY) ENDIF 20 CONTINUE 10 CONTINUE END +DECK,IPRD10. SUBROUTINE IPRD10 *----------------------------------------------------------------------- * IPRD10 - Signal matrix preparation for D1 cells. * VARIABLES : * (Last changed on 2/ 2/93.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,SIGNALMATRIX. COMPLEX ZI,ZJ *** Loop over all wires. DO 10 I=1,NWIRE * Set the diagonal terms. SIGMAT(I,I)=-LOG(0.5*D(I)/(COTUBE-(X(I)**2+Y(I)**2)/COTUBE)) * Set a complex wire-coordinate to make things a little easier. ZI=CMPLX(X(I),Y(I)) *** Loop over all other wires for the off-diagonal elements. DO 20 J=I+1,NWIRE * Set a complex wire-coordinate to make things a little easier. ZJ=CMPLX(X(J),Y(J)) SIGMAT(I,J)=-LOG(ABS((1/COTUBE)*(ZI-ZJ)/ - (1-CONJG(ZI)*ZJ/COTUBE**2))) *** Copy this to A(J,I) since the capacitance matrix is symmetric. SIGMAT(J,I)=SIGMAT(I,J) 20 CONTINUE 10 CONTINUE END +DECK,IPRD30. SUBROUTINE IPRD30 *----------------------------------------------------------------------- * IPRD30 - Signal matrix preparation for polygonal cells (type D3). * Variables : * (Last changed on 19/ 6/97.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,SIGNALMATRIX. INTEGER I,J COMPLEX WD *** Loop over all wire combinations. DO 10 I=1,NWIRE * We need to compute the wire mapping again to obtain WD. CALL EFCMAP(CMPLX(X(I),Y(I))/COTUBE,WMAP(I),WD) * Diagonal elements. SIGMAT(I,I)=-LOG(ABS((0.5*D(I)/COTUBE)*WD/(1-ABS(WMAP(I))**2))) *** Loop over all other wires for the off-diagonal elements. DO 20 J=1,I-1 SIGMAT(I,J)=-LOG(ABS((WMAP(I)-WMAP(J))/ - (1-CONJG(WMAP(I))*WMAP(J)))) *** Copy this to A(J,I) since the capacitance matrix is symmetric. SIGMAT(J,I)=SIGMAT(I,J) 20 CONTINUE 10 CONTINUE END +DECK,SIGPLP. SUBROUTINE SIGPLP(IFAIL) *----------------------------------------------------------------------- * SIGPLP - Computes the weighting field charges for the planes and * the tube. * (Last changed on 14/10/99.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,SIGNALDATA. +SEQ,SIGNALMATRIX. +SEQ,PRINTPLOT. REAL VW INTEGER MX,MY,IFAIL,IFAIL1,I,J *** Identify the routine if requested. IF(LIDENT)PRINT *,' /// ROUTINE SIGPLP ///' *** Assume this will fail. IFAIL=1 *** Loop over the signal layers. DO 100 MX=MXMIN,MXMAX DO 110 MY=MYMIN,MYMAX *** Load the layers of the signal matrices. CALL IONIO(MX,MY,2,0,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! SIGPLP WARNING : Signal matrix'// - ' store error; field for planes not prepared.' RETURN ENDIF *** Initialise the plane matrices. DO 120 I=1,5 DO 130 J=1,NWIRE QPLANE(I,J)=0 130 CONTINUE 120 CONTINUE *** Charges for plane 1, if present. IF(YNPLAN(1))THEN * Set the weighting field voltages. DO 10 I=1,NWIRE IF(YNPLAN(2))THEN VW=-(COPLAN(2)-X(I))/(COPLAN(2)-COPLAN(1)) ELSEIF(PERX)THEN VW=-(COPLAN(1)+SX-X(I))/SX ELSE VW=-1 ENDIF * Multiply with the matrix. DO 20 J=1,NWIRE QPLANE(1,I)=QPLANE(1,I)+SIGMAT(I,J)*VW 20 CONTINUE 10 CONTINUE ENDIF *** Charges for plane 2, if present. IF(YNPLAN(2))THEN * Set the weighting field voltages. DO 30 I=1,NWIRE IF(YNPLAN(1))THEN VW=-(COPLAN(1)-X(I))/(COPLAN(1)-COPLAN(2)) ELSEIF(PERX)THEN VW=-(X(I)-COPLAN(2)+SX)/SX ELSE VW=-1 ENDIF * Multiply with the matrix. DO 40 J=1,NWIRE QPLANE(2,I)=QPLANE(2,I)+SIGMAT(I,J)*VW 40 CONTINUE 30 CONTINUE ENDIF *** Charges for plane 3, if present. IF(YNPLAN(3))THEN * Set the weighting field voltages. DO 50 I=1,NWIRE IF(YNPLAN(4))THEN VW=-(COPLAN(4)-Y(I))/(COPLAN(4)-COPLAN(3)) ELSEIF(PERY)THEN VW=-(COPLAN(3)+SY-Y(I))/SY ELSE VW=-1 ENDIF * Multiply with the matrix. DO 60 J=1,NWIRE QPLANE(3,I)=QPLANE(3,I)+SIGMAT(I,J)*VW 60 CONTINUE 50 CONTINUE ENDIF *** Charges for plane 4, if present. IF(YNPLAN(4))THEN * Set the weighting field voltages. DO 70 I=1,NWIRE IF(YNPLAN(3))THEN VW=-(COPLAN(3)-Y(I))/(COPLAN(3)-COPLAN(4)) ELSEIF(PERY)THEN VW=-(Y(I)-COPLAN(4)+SY)/SY ELSE VW=-1 ENDIF * Multiply with the matrix. DO 80 J=1,NWIRE QPLANE(4,I)=QPLANE(4,I)+SIGMAT(I,J)*VW 80 CONTINUE 70 CONTINUE ENDIF *** Charges for the tube, if present. IF(TUBE)THEN DO 160 I=1,NWIRE DO 90 J=1,NWIRE QPLANE(5,I)=QPLANE(5,I)-SIGMAT(I,J) 90 CONTINUE 160 CONTINUE ENDIF *** Store the plane charges. CALL IPLIO(MX,MY,1,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! SIGPLP WARNING : Plane matrix'// - ' store error; field for planes not prepared.' RETURN ENDIF *** Next set of periodicities. 110 CONTINUE 100 CONTINUE *** Compute the background weighting fields, first in x. IF(YNPLAN(1).AND.YNPLAN(2))THEN EWXCOR(1)=1/(COPLAN(2)-COPLAN(1)) EWXCOR(2)=1/(COPLAN(1)-COPLAN(2)) ELSEIF(YNPLAN(1).AND.PERX)THEN EWXCOR(1)=1/SX EWXCOR(2)=0 ELSEIF(YNPLAN(2).AND.PERX)THEN EWXCOR(1)=0 EWXCOR(2)=-1/SX ELSE EWXCOR(1)=0 EWXCOR(2)=0 ENDIF EWXCOR(3)=0 EWXCOR(4)=0 EWXCOR(5)=0 * Next also in y. EWYCOR(1)=0 EWYCOR(2)=0 IF(YNPLAN(3).AND.YNPLAN(4))THEN EWYCOR(3)=1/(COPLAN(4)-COPLAN(3)) EWYCOR(4)=1/(COPLAN(3)-COPLAN(4)) ELSEIF(YNPLAN(3).AND.PERY)THEN EWYCOR(3)=1/SY EWYCOR(4)=0 ELSEIF(YNPLAN(4).AND.PERY)THEN EWYCOR(3)=0 EWYCOR(4)=-1/SY ELSE EWYCOR(3)=0 EWYCOR(4)=0 ENDIF * The tube has no correction field. EWYCOR(5)=0 *** Debugging output. IF(LDEBUG)THEN WRITE(LUNOUT,'('' ++++++ SIGPLP DEBUG : Charges for'', - '' currents induced in the planes:''/26X, - '' Wire x-Plane 1 x-Plane 2'', - '' y-Plane 1 y-Plane 2'', - '' Tube'')') DO 140 I=1,NWIRE WRITE(LUNOUT,'(26X,I5,5(2X,E15.8))') I,(QPLANE(J,I),J=1,5) 140 CONTINUE WRITE(LUNOUT,'('' ++++++ SIGPLP DEBUG : Bias fields:''/ - 26X,''Plane x-Bias [1/cm] y-Bias [1/cm]'')') DO 150 I=1,5 WRITE(LUNOUT,'(26X,I5,2(2X,E15.8))') I,EWXCOR(I),EWYCOR(I) 150 CONTINUE ENDIF *** Seems to have worked. IFAIL=0 END +DECK,IONBGN. SUBROUTINE IONBGN(IFAIL) *----------------------------------------------------------------------- * IONBGN - Routine initialising the data set for the signal matrices. * VARIABLES : NPEREC : Number of columns per wire record. * NRECMT : Number of records per wire matrix. * IRECP0 : First plane record. * NRECS : Total number of records on unit 13. * OPEN : Used for checking the status of unit 13. * (Last changed on 9/11/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,SIGNALMATRIX. +SEQ,SIGNALDATA. +SEQ,PRINTPLOT. INTEGER IFAIL,NPEREC,NRECMT,NRECS,IOS,IRECP0 LOGICAL OPEN CHARACTER*(MXNAME) FILE +SELF,IF=CMS. CHARACTER*80 FILDEF +SELF. COMMON /FILE13/ NPEREC,NRECMT,IRECP0,NRECS IFAIL=0 *** Identify the routine. IF(LIDENT)PRINT *,' /// ROUTINE IONBGN ///' *** Return if no file is needed. IF(.NOT.(FPERX.OR.FPERY))RETURN IFAIL=1 *** Determine the number of wire columns fitting in a record. NPEREC=INT((MXRECL-4)/(8*NWIRE)) * Stop in case MXRECL is unacceptably small. IF(NPEREC.LE.0)THEN PRINT *,' ###### IONBGN ERROR : Unable to allocate', - ' storage space for the wire matrices, a MXRECL', - ' of at least ',8*NWIRE+4,' is needed;' PRINT *,' Increase MXRECL if', - ' possible or specify FOURIER 1.' RETURN ENDIF * Set NPEREC to NWIRE if the wire matrix fits in single record. IF(NPEREC.GT.NWIRE)NPEREC=NWIRE *** Ensure that the plane matrix fits in a single record. IF(20*NWIRE+4.GT.MXRECL)THEN PRINT *,' ###### IONBGN ERROR : Unable to allocate'// - ' storage space for the plane matrices, a MXRECL'// - ' of at least ',20*NWIRE+4,' is needed;' PRINT *,' Increase MXRECL if'// - ' possible or specify FOURIER 1.' RETURN ENDIF *** Determine number of records, first records per wire matrix. NRECMT=NWIRE/NPEREC IF(NPEREC*NRECMT.LT.NWIRE)NRECMT=NRECMT+1 * Multiply by the number of Fourier copies of the matrix. IF(FPERX.AND.FPERY)THEN NRECS=NFOUR**2*NRECMT ELSEIF(FPERX.OR.FPERY)THEN NRECS=NFOUR*NRECMT ELSE NRECS=1 ENDIF * Record the start of the plane records. IRECP0=NRECS+1 * Add the plane records, each Fourier copy takes 1 record. IF(FPERX.AND.FPERY)THEN NRECS=NRECS+NFOUR**2 ELSEIF(FPERX.OR.FPERY)THEN NRECS=NRECS+NFOUR ELSE NRECS=NRECS+1 ENDIF +SELF,IF=-CMS. * Check that it does not exceed 1000. IF(NRECS.GT.1000)THEN PRINT *,' ###### IONBGN ERROR : Unable to allocate'// - ' storage space for the plane matrices, maximum'// - ' number of records in a direct access' PRINT *,' file would be exceeded;'// - ' decrease the value of FOURIER or increase'// - ' MXRECL if the disks allow.' RETURN ENDIF +SELF. *** Open the dataset, if it is not yet open. INQUIRE(UNIT=13,OPENED=OPEN) IF(OPEN)THEN PRINT *,' !!!!!! IONBGN WARNING : Unit 13 was still open'// - ' and is now being closed (program bug)' CLOSE(UNIT=13,IOSTAT=IOS,ERR=2030) ENDIF +SELF,IF=CMS. WRITE(FILDEF,'(''FILEDEF 13 DISK GARFTEMP SIGNAL A6'', - '' (CHANGE XTENT '',I4)') NRECS CALL VMCMS(FILDEF,IRC) IF(IRC.NE.0)THEN PRINT *,' !!!!!! IONBGN WARNING : Error issuing a'// - ' FILEDEF for the pure signal dataset.' GOTO 2020 ENDIF +SELF. OPEN(UNIT=13,STATUS='SCRATCH',FORM='UNFORMATTED', - ACCESS='DIRECT',RECL=NPEREC*8*NWIRE+4,IOSTAT=IOS,ERR=2020) FILE='' CALL DSNLOG(FILE,'Scratch ','Direct ','Read/Write') * and set IFAIL to 0, since it apparently worked. IFAIL=0 IF(LDEBUG)PRINT *,' ++++++ IONBGN DEBUG : Unit 13 opened', - ' with columns/rec=',NPEREC,', rec/matrix=',NRECMT, - ', recl=',NPEREC*8*NWIRE+4,' byte, records=',NRECS RETURN *** Handle the error conditions. 2020 CONTINUE PRINT *,' ###### IONBGN ERROR : Unable to open scratch'// - ' data set on unit 13 (used for signal matrices);'// - ' ion tails cannot be calculated.' CALL INPIOS(IOS) CLOSE(UNIT=13,IOSTAT=IOS,ERR=2030) RETURN 2030 CONTINUE PRINT *,' ###### IONBGN ERROR : Unable to close scratch'// - ' data set on unit 13 (attempted because of previous'// - ' error condition).' CALL INPIOS(IOS) END +DECK,IONIO. SUBROUTINE IONIO(MX,MY,IMODE,NCOL,IFAIL) *----------------------------------------------------------------------- * IONIO - Performs the external I/O operations for the routine SIGIPR * VARIABLES : MX, MY : Fourier indices of the layers * IMODE : operation mode, 1=write, 2=read * NCOL : columns to be written/read (0 = all) * (see also routine IONBGN) * (Last changed on 12/11/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,SIGNALDATA. +SEQ,SIGNALMATRIX. +SEQ,PRINTPLOT. INTEGER MX,MY,IMODE,NCOL,IFAIL,NPEREC,NRECMT,IRECP0,NRECS,NREC1, - I,II,JJ,JMIN,JMAX,IOS COMMON /FILE13/ NPEREC,NRECMT,IRECP0,NRECS *** Assume the routine will fail. IFAIL=0 *** Find the location of the first record. IF(FPERX.AND.FPERY)THEN NREC1=1+((MX+NFOUR/2-1)*NFOUR+(MY+NFOUR/2-1))*NRECMT ELSEIF(FPERX)THEN NREC1=1+(MX+NFOUR/2-1)*NRECMT ELSEIF(FPERY)THEN NREC1=1+(MY+NFOUR/2-1)*NRECMT ELSE RETURN ENDIF *** Find the relevant columns. DO 10 I=0,NRECMT-1 JMIN=I*NPEREC+1 JMAX=MIN((I+1)*NPEREC,NWIRE) IF(NCOL.NE.0.AND.(NCOL.LT.JMIN.OR.NCOL.GT.JMAX))GOTO 10 IF(NREC1+I.LE.0.OR.NREC1+I.GT.NRECS)THEN PRINT *,' ###### IONIO ERROR : I/O request references', - ' a non existing record on unit 13 (program bug).' IFAIL=1 RETURN ENDIF IF(IMODE.EQ.1)THEN WRITE(UNIT=13,REC=NREC1+I,IOSTAT=IOS,ERR=2010) - ((SIGMAT(II,JJ),II=1,NWIRE),JJ=JMIN,JMAX) ELSEIF(IMODE.EQ.2)THEN READ(UNIT=13,REC=NREC1+I,IOSTAT=IOS,ERR=2010) - ((SIGMAT(II,JJ),II=1,NWIRE),JJ=JMIN,JMAX) ENDIF 10 CONTINUE RETURN *** Handle the error condition. 2010 CONTINUE PRINT *,' ###### IONIO ERROR : Error during I/O'// - ' to scratch data set on unit 13 (signal matrices).' CALL INPIOS(IOS) IF(LDEBUG)PRINT *,' ++++++ IONIO DEBUG : Error occurred at'// - ' block ',I,' of matrix (',MX,',',MY,') REC=',NREC1+I IFAIL=1 END +DECK,IPLIO. SUBROUTINE IPLIO(MX,MY,IMODE,IFAIL) *----------------------------------------------------------------------- * IPLIO - Performs the I/O operations for the routine SIGIPR * storing and retrieving plane weighting charges. * VARIABLES : MX, MY : Fourier indices of the layers * IMODE : operation mode, 1=write, 2=read * (see also routine IONBGN) * (Last changed on 9/11/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,SIGNALDATA. +SEQ,SIGNALMATRIX. +SEQ,PRINTPLOT. INTEGER MX,MY,IMODE,IFAIL,NPEREC,NRECMT,NRECS,I,J,IOS,NREC1, - IRECP0 COMMON /FILE13/ NPEREC,NRECMT,IRECP0,NRECS *** Assume this will work. IFAIL=0 *** Find the location of the first record. IF(FPERX.AND.FPERY)THEN NREC1=IRECP0+(MX+NFOUR/2-1)*NFOUR+MY+NFOUR/2-1 ELSEIF(FPERX)THEN NREC1=IRECP0+MX+NFOUR/2-1 ELSEIF(FPERY)THEN NREC1=IRECP0+MY+NFOUR/2-1 ELSE RETURN ENDIF *** Read or write the matrix. IF(NREC1.LT.IRECP0.OR.NREC1.GT.NRECS)THEN PRINT *,' ###### IPLIO ERROR : I/O request references'// - ' an invalid record on unit 13 (program bug).' IFAIL=1 RETURN ENDIF IF(IMODE.EQ.1)THEN WRITE(UNIT=13,REC=NREC1,IOSTAT=IOS,ERR=2010) - ((QPLANE(I,J),I=1,5),J=1,NWIRE) ELSEIF(IMODE.EQ.2)THEN READ(UNIT=13,REC=NREC1+I,IOSTAT=IOS,ERR=2010) - ((QPLANE(I,J),I=1,5),J=1,NWIRE) ENDIF 10 CONTINUE RETURN *** Handle the error condition. 2010 CONTINUE PRINT *,' ###### IPLIO ERROR : Error during I/O to scratch'// - ' data set on unit 13 (signal plane matrices).' CALL INPIOS(IOS) IF(LDEBUG)PRINT *,' ++++++ IPLIO DEBUG : Error occurred at'// - ' matrix (',MX,',',MY,') REC=',NREC1 IFAIL=1 END +DECK,SIGANG. SUBROUTINE SIGANG(ISOLID,ANGLE,XREF,YREF,ZREF, - XSTART,YSTART,ZSTART) *----------------------------------------------------------------------- * SIGANG - Returns a starting point at angle ANGLE on the surface of * volume ISOLID. * VARIABLES : * (Last changed on 20/ 5/99.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,SOLIDS. +SEQ,PRINTPLOT. DOUBLE PRECISION XREF,YREF,ZREF,R,X0,Y0,Z0,CT,ST,CP,SP,U,V,W REAL ANGLE,XSTART,YSTART,ZSTART INTEGER ISOLID,IREF *** Initial points. XSTART=REAL(XREF) YSTART=REAL(YREF) ZSTART=REAL(ZREF) *** See whether we got a valid solid. IF(ISOLID.LT.1.OR.ISOLID.GT.NSOLID)THEN PRINT *,' !!!!!! SIGANG WARNING : Invalid solid reference'// - ' received; returning reference point.' RETURN *** If this is not a cylinder, simply return. ELSEIF(ISOLTP(ISOLID).NE.1)THEN RETURN *** If a cylinder, process. ELSE * Starting point in buffer. IREF=ISTART(ISOLID) IF(IREF.LT.0.OR.IREF+8.GT.MXSBUF)THEN PRINT *,' !!!!!! SIGANG WARNING : Solid address is'// - ' out of range ; returning reference.' RETURN ENDIF * Extract parameters. R =CBUF(IREF+1) X0=CBUF(IREF+3) Y0=CBUF(IREF+4) Z0=CBUF(IREF+5) CT=CBUF(IREF+10) ST=CBUF(IREF+11) CP=CBUF(IREF+12) SP=CBUF(IREF+13) * Compute thw local W coordinate of reference point. W=+CP*ST*(XREF-X0)+SP*ST*(YREF-Y0)+CT*(ZREF-Z0) * Compute the U and V coordinates. U=R*COS(ANGLE) V=R*SIN(ANGLE) * Transform to space coordinates. XSTART=REAL(X0+CP*CT*U-SP*V+CP*ST*W) YSTART=REAL(Y0+SP*CT*U+CP*V+SP*ST*W) ZSTART=REAL(Z0 -ST*U +CT*W) ENDIF END +DECK,SIGCLS. SUBROUTINE SIGCLS(LDIFF,LAVAL,LATTA,LTRACK,LTRMC,IFAIL) *----------------------------------------------------------------------- * SIGCLS - Subroutine describing the cluster formation, it generates * clusters along the track and assigns a number of secondary * pairs to each cluster. * VARIABLES : * (Last changed on 20/ 5/99.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,GASDATA. +SEQ,PRINTPLOT. +SEQ,DRIFTLINE. +SEQ,PARAMETERS. +SEQ,SIGNALDATA. REAL XCLUST,YCLUST,ZCLUST,ECLUST,XCLPR,YCLPR,Q,RNDEXP, - VXMIN,VYMIN,VXMAX,VYMAX INTEGER I,NCLUST,ISW,IFAIL,IFAIL1,NCSTAT,NNPAIR CHARACTER*50 STATUS LOGICAL LDIFF,LAVAL,LATTA,LTRACK,LTRMC,DONE EXTERNAL RNDEXP *** Identify the routine. IF(LIDENT)PRINT *,' /// ROUTINE SIGCLS ///' *** Set the charge. Q=-1.0 *** Usually this will work. IFAIL=0 *** Check option compatibility. IF(LEPULS.AND.LTRACK)THEN PRINT *,' !!!!!! SIGCLS WARNING : ELECTRON-PULSE'// - ' is incompatible with INTERPOLATE-TRACK;'// - ' INTERPOLATE-TRACK cancelled.' LTRACK=.FALSE. ENDIF IF(LTRMC.AND.LTRACK)THEN PRINT *,' !!!!!! SIGCLS WARNING : MONTE-CARLO-TRACKS'// - ' is incompatible with INTERPOLATE-TRACK;'// - ' INTERPOLATE-TRACK cancelled.' LTRACK=.FALSE. ENDIF *** Initialise clustering. CALL TRACLI NCLUST=0 *** Start a plot of the clusters -if this is requested. IF(LCLPLT)THEN IF(LTRACK)PRINT *,' ------ SIGCLS MESSAGE : Due to the'// - ' INTERPOLATE-TRACK, electrons will not be plotted.' * Layout. CALL GRCELL(VXMIN,VYMIN,VXMAX,VYMAX, - 'Track, clusters and drift lines ') IF(GASID.NE.' ')CALL GRCOMM(2,'Gas: '//GASID) IF(PARTID.NE.'Unknown')CALL GRCOMM(3,'Particle: '//PARTID) ENDIF *** Print a table of the clusters not hitting a wire in the cell. IF(LCLPRT)THEN WRITE(LUNOUT,'('' Table of the clusters''/ - '' =====================''/)') IF(LTRACK)WRITE(LUNOUT,'('' Note: the data contained in '', - ''this table has been obtained via interpolation.''/)') IF(.NOT.POLAR)THEN WRITE(LUNOUT,'(/'' No x-start y-start'', - '' z-start Drift time Diffusion Pairs'', - '' Pair Arrival time Total charge'')') WRITE(LUNOUT,'( '' [cm] [cm]'', - '' [cm] [microsec] [microsec] '', - '' [microsec] [electrons]''/)') ELSE WRITE(LUNOUT,'('' No r-start phi-start'', - '' z-start Drift time Diffusion Pairs'', - '' Pair Arrival time Total charge'')') WRITE(LUNOUT,'( '' [cm] [degrees]'', - '' [cm] [microsec] [microsec] '', - '' [microsec] [electrons]''/)') ENDIF ENDIF *** Start drift lines from the track. 10 CONTINUE * Generate a cluster. CALL TRACLS(XCLUST,YCLUST,ZCLUST,ECLUST,NNPAIR,DONE,IFAIL1) IF(DONE)THEN GOTO 20 ELSEIF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! SIGCLS WARNING : Error generating a'// - ' cluster; clustering ended.' IFAIL=1 GOTO 20 ENDIF NCLUST=NCLUST+1 * Convert cluster position from polar if needed. IF(POLAR)THEN CALL CFMCTP(XCLUST,YCLUST,XCLPR,YCLPR,1) CALL CFMCTR(XCLUST,YCLUST,XCLUST,YCLUST,1) ELSE XCLPR=XCLUST YCLPR=YCLUST ENDIF *** For MC calculation, calculate each electron separately. IF(LTRMC)THEN * Store the number of pairs as 1 (each is different). NPAIR=1 * Print a line for this cluster. IF(LCLPRT)WRITE(LUNOUT,'(1X,I6,3(1X,E12.5),27X,I5)') - NCLUST,XCLPR,YCLPR,ZCLUST,NNPAIR * Loop over the electrons. DO 30 I=1,NNPAIR * Compute the drift line. CALL DLCMC(XCLUST,YCLUST,ZCLUST,Q,1) * Store arrival time, ISTAT code and integrated diff. for later use. TCLUST=TU(NU) ICLUST=ISTAT SCLUST=0 IF(LAVAL.AND. - (AVATYP.EQ.'TOWNSEND'.OR. - AVATYP.EQ.'POLYA-TOWN'.OR. - AVATYP.EQ.'TOWN-FIXED'))CALL DLCTWN(ACLUST) IF(LATTA)CALL DLCATT(BCLUST) * Store incidence angle. CALL DLCPHI(FCLUST) * Print the information for this cluster if requested (MC format). IF(LCLPRT)THEN * Format the status code. CALL DLCSTF(ICLUST,STATUS,NCSTAT) CALL DLCISW(ICLUST,ISW) IF((ICLUST.GE.1.AND.ICLUST.LE.NWIRE).OR. - (ICLUST.GT.2*MXWIRE.AND. - ICLUST.LE.2*MXWIRE+MXSOLI).OR. - (ICLUST.LE.-11.AND.ICLUST.GE.-15))THEN IF(ISW.EQ.0)THEN STATUS=STATUS(1:NCSTAT)//', not read out' NCSTAT=MIN(LEN(STATUS),NCSTAT+14) ELSE STATUS=STATUS(1:NCSTAT)//', read out' NCSTAT=MIN(LEN(STATUS),NCSTAT+10) ENDIF ENDIF * Print a line for this cluster. WRITE(LUNOUT,'(84X,A)') STATUS(1:NCSTAT) ENDIF * Have the signal computed. CALL SIGETR(LDIFF,LAVAL,LATTA,IFAIL1) IF(IFAIL1.NE.0)PRINT *,' !!!!!! SIGCLS WARNING : Error'// - ' tracing an electron; continuing.' * Plot this drift line, if requested - this may destroy (XU,YU). IF(LCLPLT.AND..NOT.LTRACK)CALL DLCPLT * Next pair in the cluster. 30 CONTINUE *** Analytic drifting with treatment of diffusion by Gauss propagation. ELSE * Store the number of pairs. NPAIR=NNPAIR ** In case of interpolation, request data for this cluster position. IF(LTRACK)THEN * Interpolate (also in Cartesian coordinates). CALL DLCTRI(XCLUST,YCLUST,ZCLUST,TCLUST,ICLUST, - SCLUST,ACLUST,BCLUST,FCLUST,LDIFF,LAVAL,LATTA, - IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! SIGCLS WARNING : Interpolation'// - ' failure for a cluster; cluster skipped.' GOTO 10 ENDIF ** Otherwise compute the average drift line now. ELSE * Compute the drift lines. CALL DLCALC(XCLUST,YCLUST,ZCLUST,Q,1) * Store arrival time, ISTAT code and integrated diff. for later use. TCLUST=TU(NU) ICLUST=ISTAT IF(LDIFF)CALL DLCDIF(SCLUST) IF(LAVAL.AND. - (AVATYP.EQ.'TOWNSEND'.OR. - AVATYP.EQ.'POLYA-TOWN'.OR. - AVATYP.EQ.'TOWN-FIXED'))CALL DLCTWN(ACLUST) IF(LATTA)CALL DLCATT(BCLUST) * Store incidence angle. CALL DLCPHI(FCLUST) ENDIF * Print the information for this cluster if requested (normal format). IF(LCLPRT)THEN * Format the status code. CALL DLCSTF(ICLUST,STATUS,NCSTAT) CALL DLCISW(ICLUST,ISW) IF((ICLUST.GE.1.AND.ICLUST.LE.NWIRE).OR. - (ICLUST.GT.2*MXWIRE.AND. - ICLUST.LE.2*MXWIRE+MXSOLI).OR. - (ICLUST.LE.-11.AND.ICLUST.GE.-15))THEN IF(ISW.EQ.0)THEN STATUS=STATUS(1:NCSTAT)//', not read out' NCSTAT=MIN(LEN(STATUS),NCSTAT+14) ELSE STATUS=STATUS(1:NCSTAT)//', read out' NCSTAT=MIN(LEN(STATUS),NCSTAT+14) ENDIF ENDIF * Print a line for this cluster. WRITE(LUNOUT,'(1X,I6,5(1X,E12.5),1X,I5,2X,A)') - NCLUST,XCLPR,YCLPR,ZCLUST,TCLUST,SCLUST,NPAIR, - STATUS(1:NCSTAT) ENDIF * Trace the electron and compute signals. CALL SIGETR(LDIFF,LAVAL,LATTA,IFAIL1) IF(IFAIL1.NE.0)PRINT *,' !!!!!! SIGCLS WARNING : Error'// - ' tracing an electron; continuing.' * Plot this drift line, if requested - this may destroy (XU,YU). IF(LCLPLT.AND..NOT.LTRACK)CALL DLCPLT ENDIF *** Go for a new cluster. GOTO 10 *** End of loop reached. 20 CONTINUE *** Finish the plot of the track and the electron drift lines. IF(LCLPLT)THEN * Draw the track. CALL TRAPLT * Register the plot. CALL GRALOG('Track, cluster and electron drift lines.') * Close the plot. CALL GRNEXT ENDIF *** Check that there is at least one cluster. IF(NCLUST.EQ.0)THEN PRINT *,' !!!!!! SIGCLS WARNING : No clusters have been'// - ' generated.' IFAIL=1 ENDIF END +DECK,SIGETR. SUBROUTINE SIGETR(LDIFF,LAVAL,LATTA,IFAIL) *----------------------------------------------------------------------- * SIGETR - Computes ion tails and electron pulses. * (Last changed on 4/ 2/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,FIELDMAP. +SEQ,SOLIDS. +SEQ,GASDATA. +SEQ,DRIFTLINE. +SEQ,SIGNALDATA. +SEQ,PRINTPLOT. +SEQ,CONSTANTS. CHARACTER*10 VARLIS(MXVAR) DOUBLE PRECISION TIME(MXLIST),SIG(MXLIST), - VDRIFT(3,MXLIST),XAUX1,XAUX2,YAUX1,YAUX2,STEP REAL ORIION(MXLIST),AVAELE(MXLIST),PRSELE(MXLIST),PRSION(MXLIST), - DELION(MXLIST),ANGION(MXORIA),VAR(MXVAR),RES(1),PRSTOT, - SUM,SCALE,TPAIR,QPAIR,EX,EY,EZ,ETOT,VOLT,ANGLE, - GASTWN,GASATT,TWNVEC(MXLIST),DRES,XORIG(MXLIST), - YORIG(MXLIST),ZORIG(MXLIST),XSTART,YSTART,ZSTART, - BX,BY,BZ,BTOT INTEGER MODVAR(MXVAR),MODRES(1),IWION(MXLIST),IW,ISW,JSW,ISOLID, - I,J,IU,IA,IPAIR,IFAIL,IFAIL1,ILOC,ILOCRS,NSIG,NRES, - NERR LOGICAL USE(MXVAR),LDIFF,LAVAL,LATTA,START,OK EXTERNAL GASTWN,GASATT,GASVEL *** Indentify the routine. IF(LIDENT)PRINT *,' /// ROUTINE SIGETR ///' IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ SIGETR DEBUG : Called'', - '' for ion simple('',L1,'')/detailed('',L1, - '')/return('',L1,'')''/ - 26X,''electron('',L1,''), diff/aval/att: '',3L1)') - LITAIL,LDTAIL,LRTAIL,LEPULS,LDIFF,LAVAL,LATTA *** Assume that the routine will fail. IFAIL=1 *** Compute wire and sense wire number if appropriate. IF((ICLUST.GE.1.AND.ICLUST.LE.NWIRE).OR. - (ICLUST.GT.2*MXWIRE.AND.ICLUST.LE.2*MXWIRE+MXSOLI).OR. - (ICLUST.LE.-11.AND.ICLUST.GE.-15))THEN IW=ICLUST ELSE IW=0 ENDIF CALL DLCISW(ICLUST,ISW) IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ SIGETR DEBUG :'', - '' Cluster status code '',I4,'' (electrode '', - I4,'')''/26X,''has '',I4,'' steps, total drift time '', - E12.5,'' microsec.'')') ICLUST,ISW,NU,TCLUST *** Verify that appropriate gas data is available. OK=.TRUE. IF(LEPULS.AND..NOT.GASOK(4))THEN PRINT *,' !!!!!! SIGETR WARNING : No Townsend tables'// - ' found; ELECTRON-PULSE cancelled.' LEPULS=.FALSE. OK=.FALSE. ENDIF IF(LDTAIL.AND..NOT.GASOK(4))THEN PRINT *,' !!!!!! SIGETR WARNING : No Townsend tables'// - ' found; DETAILED-ION-TAIL cancelled.' LDTAIL=.FALSE. OK=.FALSE. ENDIF *** Check that at least one of the flags is still on. IF(LITAIL.AND.LDTAIL)THEN PRINT *,' !!!!!! SIGETR WARNING : Both normal and'// - ' detailed ion tail requested; detailed kept.' LITAIL=.FALSE. OK=.FALSE. ENDIF IF(LITAIL.AND.LRTAIL)THEN PRINT *,' !!!!!! SIGETR WARNING : Both normal and'// - ' nonsampled ion tail requested; nonsampled kept.' LITAIL=.FALSE. OK=.FALSE. ENDIF IF(LDTAIL.AND.LRTAIL)THEN PRINT *,' !!!!!! SIGETR WARNING : Both detailed and'// - ' nonsampled ion tail requested; detailed kept.' LRTAIL=.FALSE. OK=.FALSE. ENDIF IF(.NOT.(LEPULS.OR.LDTAIL.OR.LITAIL.OR.LRTAIL))THEN PRINT *,' !!!!!! SIGETR WARNING : Neither ion'// - ' tail, nor electron pulse remaining; no signal.' IFAIL=1 RETURN ENDIF *** See whether we should proceed. IF(JFAIL.EQ.2.AND..NOT.OK)THEN PRINT *,' ###### SIGETR ERROR : Instruction is not'// - ' carried out because of the above errors.' IFAIL=1 RETURN ELSEIF(JFAIL.EQ.3.AND..NOT.OK)THEN PRINT *,' ###### SIGETR ERROR : Program terminated'// - ' because of the above errors.' IFAIL=1 CALL QUIT ENDIF **** Don't proceed if the drift line has no steps or has zero length. IF((LEPULS.OR.LDTAIL).AND. - (NU.LE.1.OR.TU(MAX(1,NU)).LE.0))THEN IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ SIGETR DEBUG :'', - '' Drift line not processed: NU='',I4,'' TU(NU)='', - E12.5,'' microsec.'')') NU,TU(MAX(1,NU)) IFAIL=0 RETURN ENDIF *** Don't proceed if this is not a sense wire and CROSS-INDUCED is off. IF((IW.EQ.0.AND..NOT.(LCROSS.AND.(LEPULS.OR.LDTAIL))).OR. - (IW.NE.0.AND.ISW.EQ.0.AND.(.NOT.LCROSS)))THEN IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ SIGETR DEBUG :'', - '' Drift line not processed: LCROSS='',L1,'', ISTAT='', - I4,'', ISW='',I4,''.'')') LCROSS,ICLUST,ISW IFAIL=0 RETURN ENDIF *** See whether the angular spread function has been translated. IF(LITAIL.AND.IENANG.LE.0.AND.NCANG.GT.0)THEN * Translate the function. VARLIS(1)='PHI' CALL ALGPRE(FCNANG(1:NCANG),NCANG,VARLIS,1, - NRES,USE,IENANG,IFAIL1) * Check return code. IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! SIGETR WARNING : Unable to'// - ' translate the angular spread function;'// - ' ion origin not smeared.' CALL ALGCLR(IENANG) IENANG=0 * Ensure that the function gives only 1 result. ELSEIF(NRES.NE.1)THEN PRINT *,' !!!!!! SIGETR WARNING : The angular'// - ' spread function does not give 1 result;'// - ' ion origin not smeared.' CALL ALGCLR(IENANG) IENANG=0 ENDIF ENDIF *** Determine the angle of approach for this particular electron. IF(LITAIL)THEN IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ SIGETR DEBUG :'', - '' Incidence angle is '',F10.3,'' degrees.'')') - FCLUST*180/PI ** Smear the angular distribution, if requested. IF(IENANG.NE.0)THEN * Mode of the angle is 2 (number). MODVAR(1)=2 * Initialise the number of arithmetic, mode and value errors to 0. NERR=0 * Initialise the sum of the bins. SUM=0 * Loop over the bins. DO 330 I=1,NORIA * Newton-Raphson integration over the bin. DO 340 J=-NASIMP,+NASIMP IF(NASIMP.GT.0)THEN VAR(1)=2*PI*(REAL(I)+REAL(J)/REAL(2*NASIMP))/ - REAL(NORIA)-FCLUST ELSE VAR(1)=2*PI*REAL(I)/REAL(NORIA)-FCLUST ENDIF IF(VAR(1).GT.+PI)VAR(1)=VAR(1)-2*PI IF(VAR(1).LT.-PI)VAR(1)=VAR(1)+2*PI CALL ALGEXE(IENANG,VAR,MODVAR,1,RES,MODRES,1,IFAIL1) IF(IFAIL1.NE.0.OR.MODRES(1).NE.2.OR.RES(1).LT.0) - NERR=NERR+1 IF(J.EQ.-NASIMP)THEN ANGION(I)=RES(1) ELSEIF(J.EQ.+NASIMP)THEN ANGION(I)=ANGION(I)+RES(1) ELSEIF(J+NASIMP.EQ.2*((J+NASIMP)/2))THEN ANGION(I)=ANGION(I)+2*RES(1) ELSE ANGION(I)=ANGION(I)+4*RES(1) ENDIF 340 CONTINUE * Keep track of the integral. SUM=SUM+ANGION(I) 330 CONTINUE * Check the error count. CALL ALGERR IF(NERR.GT.0)THEN PRINT *,' !!!!!! SIGETR WARNING : Value, type'// - ' or arithmetic errors; no smearing.' IENANG=0 ENDIF ENDIF ** If no smearing has been requested, then simply put all in one bin. IF(IENANG.EQ.0)THEN * Set the whole distribution to zero. DO 350 I=1,NORIA ANGION(I)=0 350 CONTINUE * Transform the angle into an angular bin. IA=NINT(NORIA*MOD(FCLUST-2*PI*ANINT(FCLUST/(2*PI))+ - 2*PI,2*PI)/(2*PI)) IF(IA.EQ.0)IA=NORIA * And set just this element to non-zero. ANGION(IA)=1 SUM=1 ENDIF ** Normalise the distribution. DO 360 I=1,NORIA ANGION(I)=ANGION(I)/SUM 360 CONTINUE ** Output the distribution if debugging has been requested. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ SIGETR DEBUG :'', - '' Angular distribution in %: ''/(2X,20I4/))') - (NINT(ANGION(I)*100),I=1,NORIA) ENDIF *** Follow the electron drift line for electron and detailed ion. IF(LEPULS.OR.LDTAIL)THEN START=.FALSE. * We;ll have to cheat in case the point is located inside a wire. IF(ISTAT.GT.0)THEN ILOCRS=MOD(ISTAT,MXWIRE) DRES=D(ILOCRS) ELSE ILOCRS=0 ENDIF ** Loop over the drift line. DO 100 IU=1,NU * Various initialisations. TWNVEC(IU)=0 AVAELE(IU)=0 VDRIFT(1,IU)=0 VDRIFT(2,IU)=0 VDRIFT(3,IU)=0 ORIION(IU)=0 DELION(IU)=0 XORIG(IU)=0 YORIG(IU)=0 ZORIG(IU)=0 IWION(IU)=0 ** First take care of charge integration. IF(ILOCRS.GT.0)D(ILOCRS)=DRES/2 CALL EFIELD(REAL(XU(IU)),REAL(YU(IU)),REAL(ZU(IU)), - EX,EY,EZ,ETOT,VOLT,0,ILOC) CALL BFIELD(REAL(XU(IU)),REAL(YU(IU)),REAL(ZU(IU)), - BX,BY,BZ,BTOT,VOLT,0,ILOC) IF(ILOCRS.GT.0)D(ILOCRS)=DRES * Get Townsend and attachment coefficients and keep integrating. IF(POLAR)THEN IF(GASOK(4))TWNVEC(IU)=TWNVEC(IU)+ - GASTWN(EX/EXP(REAL(XU(IU))),EY/EXP(REAL(XU(IU))), - EZ,BX,BY,BZ) IF(GASOK(6))TWNVEC(IU)=TWNVEC(IU)- - GASATT(EX/EXP(REAL(XU(IU))),EY/EXP(REAL(XU(IU))), - EZ,BX,BY,BZ) IF(IU.GT.1)THEN CALL CF2RTC(XU(IU),YU(IU),XAUX1,YAUX1,1) CALL CF2RTC(XU(IU-1),YU(IU-1),XAUX2,YAUX2,1) STEP=SQRT((XAUX2-XAUX1)**2+(YAUX2-YAUX1)**2+ - (ZU(IU)-ZU(IU-1))**2) ENDIF ELSE IF(GASOK(4))TWNVEC(IU)=TWNVEC(IU)+GASTWN(EX,EY,EZ, - BX,BY,BZ) IF(GASOK(6))TWNVEC(IU)=TWNVEC(IU)-GASATT(EX,EY,EZ, - BX,BY,BZ) IF(IU.GT.1)STEP=SQRT((XU(IU)-XU(IU-1))**2+ - (YU(IU)-YU(IU-1))**2+(ZU(IU)-ZU(IU-1))**2) ENDIF * Check whether the avalanche has started. IF(TWNVEC(IU).GT.1E-6.AND..NOT.START)THEN IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ SIGETR DEBUG :'', - '' Avalanche starts at step '',I4)') IU START=.TRUE. ENDIF * Update the vector. IF(IU.GT.1)THEN AVAELE(IU)=AVAELE(IU-1)+ - STEP*(TWNVEC(IU)+TWNVEC(IU-1))/2 ELSE AVAELE(IU)=0 ENDIF ** Next compute and store the local electron drift velocity. IF(LEPULS)THEN IF(ILOCRS.GT.0)D(ILOCRS)=DRES/2 CALL DLCVEL(XU(IU),YU(IU),ZU(IU),VDRIFT(1,IU), - -1.0,1,ILOC) IF(ILOCRS.GT.0)D(ILOCRS)=DRES ENDIF ** Compute the 'would have been' origin of the ions. IF(LDTAIL)THEN * In case we don't find any, we need the true starting point. XORIG(IU)=XU(IU) YORIG(IU)=YU(IU) ZORIG(IU)=ZU(IU) ORIION(IU)=0 * Save electron drift line. CALL DLCBCK('SAVE') * Compute the origin of the ion drift line. IF(IU.EQ.1.OR..NOT.START)THEN NU=1 TU(NU)=0 ISTAT=0 ELSE CALL DLCALC(REAL(0.5*(XU(IU)+XU(IU-1))), - REAL(0.5*(YU(IU)+YU(IU-1))), - REAL(0.5*(ZU(IU)+ZU(IU-1))),-1.0,2) ENDIF * Store the data. IF(ISTAT.GE.1.AND.ISTAT.LE.NWIRE)THEN ORIION(IU)=ATAN2(REAL(YU(NU))-Y(ISTAT), - REAL(XU(NU)-X(ISTAT))) DELION(IU)=TU(NU) IWION(IU)=ISTAT XORIG(IU)=0 YORIG(IU)=0 ZORIG(IU)=0 ELSEIF((ISTAT.GT.2*MXWIRE.AND. - ISTAT.LE.2*MXWIRE+MXSOLI).OR. - (ISTAT.LE.-11.AND.ISTAT.GE.-15))THEN ORIION(IU)=0 DELION(IU)=0 IWION(IU)=ISTAT ELSEIF(ISTAT.NE.-3.AND.ISTAT.NE.0.AND.NU.GT.1)THEN ORIION(IU)=0 DELION(IU)=0 IWION(IU)=-1 ELSE IF(LDEBUG)WRITE(LUNOUT, - '('' ++++++ SIGETR DEBUG : Ion line for'', - '' IU='',I4,'' skipped, ISTAT='',I4)') - IU,ISTAT ORIION(IU)=0 DELION(IU)=0 IWION(IU)=0 XORIG(IU)=0 YORIG(IU)=0 ZORIG(IU)=0 ENDIF * Restore the drift line. CALL DLCBCK('RESTORE') ENDIF 100 CONTINUE ENDIF *** Loop over the clusters. DO 200 IPAIR=1,NPAIR * Generate electron arrival time and multiplication. CALL SIGCRN(LDIFF,LAVAL,LATTA,TPAIR,QPAIR) * Print pair data if requested. IF(LCLPRT)WRITE(LUNOUT,'(79X,I5,2(1X,E12.5))') IPAIR,TPAIR,QPAIR *** Compute simple ion currents in wires from the relevant angles. IF(LITAIL.AND.IW.GE.1.AND.IW.LE.NWIRE)THEN DO 480 I=1,NORIA ANGLE=2*PI*REAL(I)/REAL(NORIA) * Skip bins with very small contributions. IF(ANGION(I)*NORIA.LT.1E-3)GOTO 480 ** Cross-induced signals requested, loop over all sense wires. IF(LCROSS)THEN DO 490 JSW=1,NSW * Get the ion tail. CALL SIGION(JSW,IW,ANGLE,NSIG,TIME,SIG,IFAIL1) * And add if it the tail is available. IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! SIGETR WARNING : Unable to'// - ' obtain an ion tail ; tail not added.' ELSE CALL SIGADD(JSW,ISW.NE.JSW,NSIG,TIME,SIG, - ANGION(I)*QPAIR,0.0,TPAIR,IFAIL1) ENDIF 490 CONTINUE ** For only direct signals, don't do the loop. ELSEIF(ISW.NE.0)THEN * Get the ion tail. CALL SIGION(ISW,IW,ANGLE,NSIG,TIME,SIG,IFAIL1) * And add if it the tail is available. IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! SIGETR WARNING : Unable to'// - ' obtain an ion tail ; tail not added.' ELSE CALL SIGADD(ISW,.FALSE.,NSIG,TIME,SIG, - ANGION(I)*QPAIR,0.0,TPAIR,IFAIL1) ENDIF ENDIF ** Next orientation and pair. 480 CONTINUE *** Compute simple ion currents in wires from the relevant angles. ELSEIF(LRTAIL.AND.IW.GE.1.AND.IW.LE.NWIRE)THEN * Starting point. XSTART=REAL(XU(NU)) YSTART=REAL(YU(NU)) ZSTART=REAL(ZU(NU)) ** Cross-induced signals requested, loop over all sense wires. IF(LCROSS)THEN DO 530 JSW=1,NSW * Get the ion tail. CALL SIGIOR(JSW,XSTART,YSTART,ZSTART, - NSIG,TIME,SIG,IFAIL1) * And add if it the tail is available. IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! SIGETR WARNING : Unable to'// - ' compute an ion tail ; tail not added.' ELSE CALL SIGADD(JSW,ISW.NE.JSW,NSIG,TIME,SIG, - QPAIR,0.0,TPAIR,IFAIL1) ENDIF 530 CONTINUE ** For only direct signals, don't do the loop. ELSEIF(ISW.NE.0)THEN * Get the ion tail. CALL SIGIOR(ISW,XSTART,YSTART,ZSTART, - NSIG,TIME,SIG,IFAIL1) * And add if it the tail is available. IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! SIGETR WARNING : Unable to'// - ' compute an ion tail ; tail not added.' ELSE CALL SIGADD(ISW,.FALSE.,NSIG,TIME,SIG, - QPAIR,0.0,TPAIR,IFAIL1) ENDIF ENDIF *** Compute simple ion currents in solids from the relevant angles. ELSEIF(LITAIL.AND.IW.GE.2*MXWIRE+1.AND.IW.LE.2*MXWIRE+NSOLID)THEN * Find out which solid. ISOLID=IW-2*MXWIRE ** If a cylinder, take angular spread into account. IF(ISOLTP(ISOLID).EQ.1)THEN DO 500 I=1,NORIA ANGLE=2*PI*REAL(I)/REAL(NORIA) * Skip bins with very small contributions. IF(ANGION(I)*NORIA.LT.1E-3)GOTO 500 * Compute origin for this angle. CALL SIGANG(ISOLID,ANGLE,XU(NU),YU(NU),ZU(NU), - XSTART,YSTART,ZSTART) * Cross-induced signals requested, loop over all sense wires. IF(LCROSS)THEN DO 510 JSW=1,NSW * Get the ion tail. CALL SIGIOR(JSW,XSTART,YSTART,ZSTART, - NSIG,TIME,SIG,IFAIL1) * And add if it the tail is available. IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! SIGETR WARNING : Unable'// - ' to obtain an ion tail ; tail not'// - ' added.' ELSE CALL SIGADD(JSW,ISW.NE.JSW,NSIG,TIME,SIG, - ANGION(I)*QPAIR,0.0,TPAIR,IFAIL1) ENDIF 510 CONTINUE * For only direct signals, don't do the loop. ELSEIF(ISW.NE.0)THEN * Get the ion tail. CALL SIGIOR(ISW,XSTART,YSTART,ZSTART, - NSIG,TIME,SIG,IFAIL1) * And add if it the tail is available. IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! SIGETR WARNING : Unable'// - ' to obtain an ion tail ; tail not'// - ' added.' ELSE CALL SIGADD(ISW,.FALSE.,NSIG,TIME,SIG, - ANGION(I)*QPAIR,0.0,TPAIR,IFAIL1) ENDIF ENDIF 500 CONTINUE ** For other solids, drift an ion backwards. ELSE * Establish end point. XSTART=REAL(XU(NU)) YSTART=REAL(YU(NU)) ZSTART=REAL(ZU(NU)) * Cross-induced signals requested, loop over all sense wires. IF(LCROSS)THEN DO 520 JSW=1,NSW * Get the ion tail. CALL SIGIOR(JSW,XSTART,YSTART,ZSTART, - NSIG,TIME,SIG,IFAIL1) * And add if it the tail is available. IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! SIGETR WARNING : Unable'// - ' to obtain an ion tail ; tail not'// - ' added.' ELSE CALL SIGADD(JSW,ISW.NE.JSW,NSIG,TIME,SIG, - QPAIR,0.0,TPAIR,IFAIL1) ENDIF 520 CONTINUE * For only direct signals, don't do the loop. ELSEIF(ISW.NE.0)THEN * Get the ion tail. CALL SIGIOR(ISW,XSTART,YSTART,ZSTART, - NSIG,TIME,SIG,IFAIL1) * And add if it the tail is available. IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! SIGETR WARNING : Unable'// - ' to obtain an ion tail ; tail not'// - ' added.' ELSE CALL SIGADD(ISW,.FALSE.,NSIG,TIME,SIG, - QPAIR,0.0,TPAIR,IFAIL1) ENDIF ENDIF ENDIF ENDIF *** Compute scaling for the number of pairs. IF(LEPULS.OR.LDTAIL)THEN IF(IW.EQ.0)THEN SCALE=1 IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ SIGETR DEBUG :'', - '' Avalanche scaling = 1, no electrode hit.'')') ELSEIF(QPAIR.LE.0)THEN SCALE=0 IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ SIGETR DEBUG :'', - '' No avalanche, not scaled.'')') ELSEIF(NU.LE.0)THEN SCALE=1 IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ SIGETR DEBUG :'', - '' Avalanche scaling = 1, no steps.'')') ELSEIF(AVAELE(NU).LE.0)THEN SCALE=1 IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ SIGETR DEBUG :'', - '' Avalanche scaling = 1, no electrons left.'')') ELSE SCALE=LOG(QPAIR)/AVAELE(NU) IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ SIGETR DEBUG :'', - '' Avalanche scaling = '',E12.5)') SCALE ENDIF * Debugging output. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ SIGETR DEBUG : '', - ''Charge from Townsend integration: '',E12.5/ - 26X,''Requested total charge: '',E12.5/ - 26X,''Scaling factor: '',E12.5/ - 2X,''Avalanche development: ''/ - '' Time [microsec] Alpha int Electrons'', - '' Ions Ion origin Ion delay'', - '' Stat'')') EXP(MIN(50.0,AVAELE(NU))),QPAIR,SCALE * Loop over the electron drift line. PRSTOT=0 DO 210 IU=1,NU * Make a table of the number of electrons (integral). IF(AVAELE(IU)*SCALE.LT.LOG(0.5))THEN PRSELE(IU)=0 ELSEIF(AVAELE(IU)*SCALE.LT.LOG(1.5))THEN PRSELE(IU)=1 ELSE PRSELE(IU)=1+EXP(MIN(50.0,AVAELE(IU)*SCALE)) ENDIF * Make a table of the number of ions (differential). IF(IU.EQ.1)THEN PRSION(IU)=0 ELSE PRSION(IU)=MAX(0.0,PRSELE(IU)-PRSELE(IU-1)) ENDIF PRSTOT=PRSTOT+PRSION(IU) * Make a timing table. TIME(IU)=TU(IU)*TPAIR/TU(NU) * Debugging output. IF(LDEBUG)WRITE(LUNOUT,'(2X,I5,6(1X,E12.5),1X,I4)') - IU,TIME(IU),AVAELE(IU),PRSELE(IU),PRSION(IU), - ORIION(IU),DELION(IU),IWION(IU) 210 CONTINUE ENDIF *** Add the electron current. IF(LEPULS)THEN ** Cross induction: loop over all sense wires. IF(LCROSS)THEN * Loop over the sense wires. DO 240 JSW=1,NSW * Compute contribution of the current drift line to the signal DO 250 IU=1,NU CALL SIGFLS(REAL(XU(IU)),REAL(YU(IU)),REAL(ZU(IU)), - EX,EY,EZ,JSW) SIG(IU)=PRSELE(IU)*(VDRIFT(1,IU)*EX+VDRIFT(2,IU)*EY+ - VDRIFT(3,IU)*EZ) 250 CONTINUE * Add this current to the total. CALL SIGADD(JSW,ISW.NE.JSW,NU,TIME,SIG, - -1.0,0.0,0.0,IFAIL1) * Finish loop over the sense wires, 240 CONTINUE ** Otherwise do not do the loop. ELSEIF(ISW.NE.0)THEN * Compute contribution of the current drift line to the signal DO 220 IU=1,NU CALL SIGFLS(REAL(XU(IU)),REAL(YU(IU)),REAL(ZU(IU)), - EX,EY,EZ,ISW) SIG(IU)=PRSELE(IU)*(VDRIFT(1,IU)*EX+VDRIFT(2,IU)*EY+ - VDRIFT(3,IU)*EZ) 220 CONTINUE * Add this current to the total. CALL SIGADD(ISW,.FALSE.,NU,TIME,SIG, - -1.0,0.0,0.0,IFAIL1) ENDIF ENDIF *** Add the ion currents. IF(LDTAIL)THEN * Loop over the electron track. DO 260 IU=2,NU * Skip points where there are no ions yet. IF(PRSION(IU).LT.1.0)GOTO 260 * Skip also points with a negligible contribution. IF(PRSION(IU).LT.PRSTHR*PRSTOT)GOTO 260 * Skip points where the ions don't come from an electrode. IF(IWION(IU).EQ.0)GOTO 260 ** Cross-induced signals requested, loop over all sense wires. IF(LCROSS)THEN DO 270 JSW=1,NSW * Get the ion tail. IF(IWION(IU).GE.1.AND.IWION(IU).LE.NWIRE)THEN CALL SIGION(JSW,IWION(IU),ORIION(IU), - NSIG,TIME,SIG,IFAIL1) ELSE CALL SIGIOR(JSW,XORIG(IU),YORIG(IU),ZORIG(IU), - NSIG,TIME,SIG,IFAIL1) ENDIF * And add if it the tail is available. IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! SIGETR WARNING : Unable to'// - ' obtain an ion tail ; tail not added.' ELSE CALL SIGADD(JSW,ISW.NE.JSW,NSIG,TIME,SIG, - PRSION(IU),DELION(IU),TPAIR-DELION(IU), - IFAIL1) ENDIF 270 CONTINUE ** For only direct signals, only process ions from the same source, ELSEIF(IWION(IU).EQ.IW)THEN * Get the ion tail. IF(IWION(IU).GE.1.AND.IWION(IU).LE.NWIRE)THEN CALL SIGION(ISW,IWION(IU),ORIION(IU), - NSIG,TIME,SIG,IFAIL1) ELSE CALL SIGIOR(ISW,XORIG(IU),YORIG(IU),ZORIG(IU), - NSIG,TIME,SIG,IFAIL1) ENDIF * And add if it the tail is available. IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! SIGETR WARNING : Unable to'// - ' obtain an ion tail ; tail not added.' ELSE CALL SIGADD(ISW,.FALSE.,NSIG,TIME,SIG, - PRSION(IU),DELION(IU),TPAIR-DELION(IU), - IFAIL1) ENDIF ENDIF * Next point on the electron track. 260 CONTINUE ENDIF *** Next cluster. 200 CONTINUE *** Seems to have worked. IFAIL=0 END +DECK,SIGCRN. SUBROUTINE SIGCRN(LDIFF,LAVAL,LATTA,TPAIR,QPAIR) *----------------------------------------------------------------------- * SIGCRN - Generates single electron time and avalanches. * (Last changed on 11/ 6/97.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,SIGNALDATA. +SEQ,PRINTPLOT. REAL TPAIR,QPAIR,RNDNOR LOGICAL LDIFF,LAVAL,LATTA EXTERNAL RNDNOR *** Identify the routine if requested. IF(LIDENT)PRINT *,' /// ROUTINE SIGCRN ///' *** Generate electron-ion pairs using diffusion and energy loss data. IF(LDIFF)THEN TPAIR=RNDNOR(TCLUST,SCLUST) ELSE TPAIR=TCLUST ENDIF *** Avalanche: various distributions, handled by SIGAVA. IF(LAVAL)THEN CALL SIGAVA(QPAIR,ACLUST) ELSE QPAIR=1 ENDIF *** Attachment: take the attachment factor into account. IF(LATTA)QPAIR=BCLUST*QPAIR *** Debugging output if requested. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ SIGCRN DEBUG : Generated'', - '' t='',E12.5,'', Q='',E12.5,'',''/ - 26X,''Diffusion: '',L1,'' avalanche '',L1, - '' attachment '',L1,''.'')') TPAIR,QPAIR,LDIFF,LAVAL,LATTA END +DECK,SIGADD. SUBROUTINE SIGADD(ISW,CROSS,NSIG,TIME,SIG,Q,TMIN,TSHIFT,IFAIL) *----------------------------------------------------------------------- * SIGADD - Adds a signal to the current signal banks. * (Last changed on 6/10/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CONSTANTS. +SEQ,CELLDATA. +SEQ,SIGNALDATA. +SEQ,PRINTPLOT. INTEGER ISW,NSIG,IFAIL,I,J,MSIG,KIORD REAL Q,TMIN,TSHIFT LOGICAL CROSS DOUBLE PRECISION TIME(*),SIG(*),TIMIN,TIMAX,TINT,SUM +SELF,IF=ESSL. INTEGER MXSIMP PARAMETER(MXSIMP=20) DOUBLE PRECISION AUX(MXLIST+2*MXSIMP+1),TVEC(-MXSIMP:MXSIMP), - SVEC(-MXSIMP:MXSIMP) +SELF,IF=-ESSL. DOUBLE PRECISION DIVDF2,TSIMP EXTERNAL DIVDF2 +SELF. *** Identify the routine. +SELF,IF=ESSL. IF(LIDENT)PRINT *,' /// ROUTINE SIGADD (ESSL) ///' +SELF,IF=-ESSL. IF(LIDENT)PRINT *,' /// ROUTINE SIGADD (CERNLIB) ///' +SELF. *** Don't do anything if there are no points on the signal. IF(NSIG.LT.2)THEN IFAIL=0 RETURN ENDIF *** Assume that the routine will fail. IFAIL=1 +SELF,IF=ESSL. *** Check interpolation order. IF(NISIMP.GT.MXSIMP)THEN PRINT *,' !!!!!! SIGADD WARNING : Number of integration'// - ' points exceeds maximum ; set to ',MXSIMP,'.' NISIMP=MXSIMP ENDIF +SELF. *** Debugging output. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ SIGADD DEBUG : Adding a '', - I4,''-vector to sense wire '',I4,'', terms='',I3,'',''/ - 26X,''order='',I3,'', charge='',F10.3,'', tmin='',F10.3, - '',''/26X,''shift='',F10.3)') - NSIG,ISW,NISIMP,JIORD,Q,TMIN,TSHIFT *** Ensure that the sense wire number is in range. IF(ISW.LE.0.OR.ISW.GT.NSW)THEN PRINT *,' !!!!!! SIGADD WARNING : Sense wire number out'// - ' of range; signals not added.' RETURN ENDIF *** Verify that the signal has no 2 equal times in succession. DO 100 I=2,NSIG IF(TIME(I).LE.TIME(I-1))THEN MSIG=I-1 IF(MSIG.LT.NSIG-1)PRINT *,' !!!!!! SIGADD WARNING :'// - ' Cutting signal at step ',MSIG,' out of ',NSIG, - ' (equal time).' GOTO 110 ENDIF 100 CONTINUE MSIG=NSIG 110 CONTINUE *** Store the interpolation order. KIORD=MIN(JIORD,MSIG-1) *** Add the signal to the signal bank. DO 10 I=1,NTIME TINT=TIMSIG(I)-TSHIFT ** Averageing mode: establish integration time window. IF(NISIMP.GT.0)THEN * Truncate the time window to overlap with the computed signal. TIMIN=MAX(TIME(1),TINT-DBLE(TDEV/2),DBLE(TMIN)) TIMAX=MIN(TIME(NSIG),TINT+DBLE(TDEV/2)) * Skip this point if there is no overlap. IF(TIMAX.LE.TIMIN)GOTO 10 ** Sampling mode: just check the point is in the computed signal. ELSE IF(TINT.LT.TIME(1).OR.TINT.GT.TIME(NSIG))GOTO 10 ENDIF * Newton-Raphson integration over this bin. +SELF,IF=-ESSL. IF(NISIMP.LE.0)THEN SUM=DIVDF2(SIG,TIME,MSIG,TINT,JIORD) ELSE DO 20 J=-NISIMP,NISIMP TSIMP=TIMIN+DBLE(J+NISIMP)*(TIMAX-TIMIN)/DBLE(2*NISIMP) IF(J.EQ.-NISIMP)THEN SUM=DIVDF2(SIG,TIME,MSIG,TSIMP,KIORD) ELSEIF(J.EQ.NISIMP)THEN SUM=SUM+DIVDF2(SIG,TIME,MSIG,TSIMP,KIORD) ELSEIF(J+NISIMP.EQ.2*((J+NISIMP)/2))THEN SUM=SUM+2*DIVDF2(SIG,TIME,MSIG,TSIMP,KIORD) ELSE SUM=SUM+4*DIVDF2(SIG,TIME,MSIG,TSIMP,KIORD) ENDIF 20 CONTINUE ENDIF +SELF,IF=ESSL. IF(NISIMP.LE.0)THEN TVEC(0)=TINT CALL DTPINT(TIME,SIG,MSIG,JIORD+1, - TVEC(0),SVEC(0),1,AUX,MXLIST+2*MXSIMP+1) SUM=SVEC(0) ELSE DO 20 J=-NISIMP,NISIMP TVEC(J)=TIMIN+DBLE(J+NISIMP)*(TIMAX-TIMIN)/DBLE(2*NISIMP) 20 CONTINUE CALL DTPINT(TIME,SIG,MSIG,KIORD+1, - TVEC(-NISIMP),SVEC(-NISIMP),2*NISIMP+1, - AUX,MXLIST+2*MXSIMP+1) DO 30 J=-NISIMP,NISIMP IF(J.EQ.-NISIMP)THEN SUM=SVEC(J) ELSEIF(J.EQ.NISIMP)THEN SUM=SUM+SVEC(J) ELSEIF(J+NISIMP.EQ.2*((J+NISIMP)/2))THEN SUM=SUM+2*SVEC(J) ELSE SUM=SUM+4*SVEC(J) ENDIF 30 CONTINUE ENDIF +SELF. * Normalise the integral if Simpson-Raphson was used. IF(NISIMP.GT.0)SUM=SUM*(TIMAX-TIMIN)/(6*NISIMP*TDEV) * Add the result to the signal. IF(CROSS)THEN SIGNAL(I,ISW,2)=SIGNAL(I,ISW,2)-ECHARG*1E12*Q*SUM ELSE SIGNAL(I,ISW,1)=SIGNAL(I,ISW,1)-ECHARG*1E12*Q*SUM ENDIF 10 CONTINUE *** Seems to have worked since we got here. IFAIL=0 END +DECK,SIGADS. SUBROUTINE SIGADS(CROSS,IFAIL) *----------------------------------------------------------------------- * SIGADS - Adds the signals induced by the current drift line. * (Last changed on 6/ 1/01.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,DRIFTLINE. +SEQ,PRINTPLOT. +SEQ,SIGNALDATA. +SEQ,CONSTANTS. LOGICAL CROSS INTEGER ISW,JSW,IU,ILOC,ILOCRS,IFAIL,IFAIL1 REAL EX,EY,EZ,DRES DOUBLE PRECISION VDRIFT(3),TIME(MXLIST),SIG(MXLIST) *** Identification. IF(LIDENT)PRINT *,' /// ROUTINE SIGADS ///' *** Assume the procedure will fail. IFAIL=1 *** Ensure there is a drift line. IF(ISTAT.EQ.0)THEN PRINT *,' !!!!!! SIGADS WARNING : The current drift'// - ' line has no steps; no signals computed.' RETURN ELSEIF(IPTYPE.NE.1.AND.IPTYPE.NE.2)THEN PRINT *,' !!!!!! SIGADS WARNING : Current drift line is'// - ' neither for an e- nor an ion; no signals computed.' RETURN ELSEIF(ABS(QPCHAR).LT.0.1)THEN PRINT *,' !!!!!! SIGADS WARNING : Current drift line is'// - ' for an uncharged particle; no signals computed.' RETURN ENDIF *** Make sure the time resolution has been set. IF(.NOT.RESSET)THEN PRINT *,' !!!!!! SIGADS WARNING : The time resolution has'// - ' not yet been set; no signals computed.' RETURN ENDIF *** Obtain the sense wire number. CALL DLCISW(ISTAT,ISW) * Cheat in case the point is located inside a wire. IF(ISTAT.GT.0)THEN ILOCRS=MOD(ISTAT,MXWIRE) DRES=D(ILOCRS) ELSE ILOCRS=0 DRES=0 ENDIF IF(ILOCRS.GT.0)D(ILOCRS)=DRES/2 ** Cross induction: loop over all sense wires. IF(CROSS)THEN * Loop over the sense wires. DO 10 JSW=1,NSW * Compute contribution of the current drift line to the signal DO 20 IU=1,NU CALL SIGFLS(REAL(XU(IU)),REAL(YU(IU)),REAL(ZU(IU)), - EX,EY,EZ,JSW) CALL DLCVEL(XU(IU),YU(IU),ZU(IU),VDRIFT,QPCHAR,IPTYPE,ILOC) SIG(IU)=(VDRIFT(1)*EX+VDRIFT(2)*EY+VDRIFT(3)*EZ) TIME(IU)=TU(IU) 20 CONTINUE * Add this current to the total. CALL SIGADD(JSW,ISW.NE.JSW,NU,TIME,SIG,QPCHAR,0.0,0.0, - IFAIL1) IF(IFAIL1.NE.0)PRINT *,' !!!!!! SIGADS WARNING : Adding'// - ' the computed signal failed; signal incomplete.' * Finish loop over the sense wires, 10 CONTINUE * Make sure we will know cross induced signals have been computed. LCROSS=.TRUE. ** Otherwise do not do the loop. ELSEIF(ISW.NE.0)THEN * Compute contribution of the current drift line to the signal DO 30 IU=1,NU CALL SIGFLS(REAL(XU(IU)),REAL(YU(IU)),REAL(ZU(IU)), - EX,EY,EZ,ISW) CALL DLCVEL(XU(IU),YU(IU),ZU(IU),VDRIFT,QPCHAR,IPTYPE,ILOC) SIG(IU)=(VDRIFT(1)*EX+VDRIFT(2)*EY+VDRIFT(3)*EZ) TIME(IU)=TU(IU) 30 CONTINUE * Add this current to the total. CALL SIGADD(ISW,.FALSE.,NU,TIME,SIG,QPCHAR,0.0,0.0,IFAIL1) IF(IFAIL1.NE.0)PRINT *,' !!!!!! SIGADS WARNING : Adding'// - ' the computed signal failed; signal incomplete.' * Make sure we will know cross induced signals have not been computed. LCROSS=.FALSE. ENDIF *** Restore the wire diameter. IF(ILOCRS.GT.0)D(ILOCRS)=DRES *** Things seem to have worked. IFAIL=0 END +DECK,SIGAVA. SUBROUTINE SIGAVA(QCL,ACL) *----------------------------------------------------------------------- * SIGAVA - Returns a random number for the cluster size. * (Last changed on 31/10/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,SIGNALDATA. REAL QCL,ACL,RNDEXP,RNDNOR,RNDPOL EXTERNAL RNDEXP,RNDNOR,RNDPOL *** Exponential type. IF(AVATYP.EQ.'EXPONENTIAL')THEN QCL=RNDEXP(AVALAN(1)) *** Fixed factor. ELSEIF(AVATYP.EQ.'FIXED')THEN QCL=AVALAN(1) *** Gaussian distribution. ELSEIF(AVATYP.EQ.'GAUSSIAN')THEN QCL=RNDNOR(AVALAN(1),AVALAN(1)*AVALAN(2)) *** Townsend based exponential distribution. ELSEIF(AVATYP.EQ.'TOWNSEND')THEN QCL=RNDEXP(ACL) *** Townsend without fluctuations. ELSEIF(AVATYP.EQ.'TOWN-FIXED')THEN QCL=ACL *** Polya distributed with fixed mean. ELSEIF(AVATYP.EQ.'POLYA-FIXED')THEN QCL=AVALAN(1)*RNDPOL(AVALAN(2)) *** Polya distributed with Townsend mean. ELSEIF(AVATYP.EQ.'POLYA-TOWN')THEN QCL=ACL*RNDPOL(AVALAN(1)) *** Anything else not known, take the (hopefully meanigful) default. ELSE PRINT *,' !!!!!! SIGAVA WARNING : Unknown avalanche type'// - ' received: '//AVATYP//'; program bug, please report.' QCL=AVALAN(1) ENDIF *** Never accept a multiplication smaller than 1. IF(QCL.LT.1.0)QCL=1.0 END +DECK,SIGION. SUBROUTINE SIGION(ISW,IW,ANGLE,NSIG,TIME,SIG,IFAIL) *----------------------------------------------------------------------- * SIGION - Routine computing the ion tail on sense wire ISW due to an * ion drifting at angle ANGLE from wire IW. * VARIABLES : VDRIFT : Vector storing the drift velocities. * TIME,SIG : Time and currents of the induced signal. * (Last changed on 28/ 4/99.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PARAMETERS. +SEQ,CONSTANTS. +SEQ,CELLDATA. +SEQ,GASDATA. +SEQ,DRIFTLINE. +SEQ,SIGNALDATA. +SEQ,PRINTPLOT. DOUBLE PRECISION VDRIFT(3,MXLIST),TIME(*),SIG(*) INTEGER ISW,IW,IA,IQ,NSIG,IFAIL,IFAIL1,ITYPE,ILOC,I,JSW REAL ANGLE,Q,DRES,EX,EY,EZ *** Identify the routine IF(LIDENT)PRINT *,' /// ROUTINE SIGION ///' *** Assume that this will fail. IFAIL=1 *** Verify the sense wire and wire number. IF(IW.LE.0.OR.NWIRE.GT.NWIRE.OR.ISW.LE.0.OR.ISW.GT.NSW)THEN PRINT *,' !!!!!! SIGION WARNING : Invalid wire or sense'// - ' wire number received ; no ion tail computed.' RETURN ENDIF *** Transform the angle into an angular bin. IA=NINT(NORIA*MOD(ANGLE-2*PI*ANINT(ANGLE/(2*PI))+2*PI, - 2*PI)/(2*PI)) IF(IA.EQ.0)IA=NORIA *** Set charge and part. type and reset the signals if change is .TRUE. Q=+1.0 IQ=+1 ITYPE=2 *** See whether the signal is already in store. CALL SIGIST('READ',NSIG,TIME,SIG,ISW,IW,IA,IQ,IFAIL1) * Check that there was no storage error. IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! SIGION WARNING : Signal store error;'// - ' no ion tail calculated.' NSIG=0 IFAIL=1 RETURN * If it was in store, simply return it, otherwise compute the signals. ELSEIF(NSIG.GE.0)THEN IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ SIGION DEBUG :'', - '' Signal for ISW/IW/IA/IQ='',4I5,'' was in store.'')') - ISW,IW,IA,IQ IFAIL=0 RETURN ENDIF *** Compute ion drift line, first backup the current drift line. CALL DLCBCK('SAVE') * Make wire radius smaller to avoid trap. DRES=D(IW) D(IW)=0.25*D(IW)/RTRAP * Compute the ion drift line. CALL DLCALC(X(IW)+0.5*DRES*COS(ANGLE),Y(IW)+0.5*DRES*SIN(ANGLE), - 0.0,Q,ITYPE) IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ SIGION DEBUG : Wire='',I4, - '', Angle='',E12.5,'' NU='',I4,'' ISTAT='',I5)') - IW,ANGLE,NU,ISTAT * Compute drift velocity. DO 50 I=1,NU CALL DLCVEL(XU(I),YU(I),ZU(I),VDRIFT(1,I),Q,ITYPE,ILOC) 50 CONTINUE * Restore the wire radius. D(IW)=DRES * Issue a warning if there is only one point. IF(NU.LE.2)THEN NSIG=0 TIME(1)=0 SIG(1)=0 PRINT *,' !!!!!! SIGION WARNING : Zero-length ion drift'// - ' line from wire ',IW,' at angle ',ANGLE CALL SIGIST('STORE',NSIG,TIME,SIG,ISW,IW,IA,IQ,IFAIL1) IFAIL=1 CALL DLCBCK('RESTORE') RETURN ENDIF *** Compute ion signal on all electrodes, but ... DO 80 JSW=1,NSW * ... save time if cross induction has not been requested. IF((.NOT.LCROSS).AND.(ISW.NE.JSW))GOTO 80 * Compute contribution of the current drift line to the signal DO 90 I=1,NU CALL SIGFLS(REAL(XU(I)),REAL(YU(I)),REAL(ZU(I)),EX,EY,EZ,JSW) TIME(I)=TU(I) SIG(I)=VDRIFT(1,I)*EX+VDRIFT(2,I)*EY+VDRIFT(3,I)*EZ 90 CONTINUE * Store this signal. CALL SIGIST('STORE',NU,TIME,SIG,JSW,IW,IA,IQ,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! SIGION WARNING : Error storing an ion'// - ' tail; no ion tail returned.' NSIG=0 IFAIL=1 CALL DLCBCK('RESTORE') RETURN ENDIF * Finish loop over the sense wires, 80 CONTINUE *** Plot the drift line if this has been requested. IF(LCLPLT)CALL DLCPLT *** Restore the drift line that was in memory. CALL DLCBCK('RESTORE') *** Retrieve the signal we were asked for in the first place. CALL SIGIST('READ',NSIG,TIME,SIG,ISW,IW,IA,IQ,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! SIGION WARNING : Error retrieving'// - ' a computed ion tail; program bus - please report.' NSIG=0 IFAIL=1 RETURN ENDIF *** Seems to have worked correctly. IFAIL=0 END +DECK,SIGIOR. SUBROUTINE SIGIOR(ISW,XORIG,YORIG,ZORIG,NSIG,TIME,SIG,IFAIL) *----------------------------------------------------------------------- * SIGIOR - Routine computing the ion tail on sense wire ISW due to an * ion drifting from (XORIG,YORIG,ZORIG). * VARIABLES : VDRIFT : Vector storing the drift velocities. * TIME,SIG : Time and currents of the induced signal. * (Last changed on 16/11/99.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PARAMETERS. +SEQ,CONSTANTS. +SEQ,CELLDATA. +SEQ,FIELDMAP. +SEQ,GASDATA. +SEQ,DRIFTLINE. +SEQ,SIGNALDATA. +SEQ,PRINTPLOT. DOUBLE PRECISION VDRIFT(3),TIME(*),SIG(*) INTEGER IW,ISW,IQ,NSIG,IFAIL,ITYPE,ILOC,I REAL Q,EX,EY,EZ,XORIG,YORIG,ZORIG,DRES *** Identify the routine IF(LIDENT)PRINT *,' /// ROUTINE SIGIOR ///' *** Assume that this will fail. IFAIL=1 *** See whether we start from a wire. IF(ICLUST.GE.1.AND.ICLUST.LE.NWIRE)THEN IW=ICLUST ELSE IW=0 ENDIF *** Tempotrarily reduce the wire diameter to avoid trap. IF(IW.GT.0)THEN DRES=D(IW) D(IW)=0.25*D(IW)/RTRAP ENDIF *** Set charge and part. type and reset the signals if change is .TRUE. Q=+1.0 IQ=+1 ITYPE=2 *** Make a backup of the drift line. CALL DLCBCK('SAVE') *** Compute the ion drift line. CALL DLCALC(XORIG,YORIG,ZORIG,Q,ITYPE) IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ SIGIOR DEBUG : Origin =('', - 3E12.5,'') NU='',I4,'' ISTAT='',I5)') XORIG,YORIG,ZORIG, - NU,ISTAT *** Compute contribution of the current drift line to the signal NSIG=NU DO 70 I=1,NU CALL DLCVEL(XU(I),YU(I),ZU(I),VDRIFT,Q,ITYPE,ILOC) CALL SIGFLS(REAL(XU(I)),REAL(YU(I)),REAL(ZU(I)),EX,EY,EZ,ISW) SIG(I)=VDRIFT(1)*EX+VDRIFT(2)*EY+VDRIFT(3)*EZ TIME(I)=TU(I) 70 CONTINUE *** Restore the wire diameter. IF(IW.GT.0)D(IW)=DRES *** Plot the drift line if this has been requested. IF(LCLPLT)CALL DLCPLT *** Restore the drift line that was in memory. CALL DLCBCK('RESTORE') *** Seems to have worked correctly. IFAIL=0 END +DECK,SIGIST,IF=MEMORY. SUBROUTINE SIGIST(ACTION,NSIG,TIME,SIG,ISW,IW,IA,IQ,IFAIL) *----------------------------------------------------------------------- * SIGIST - Routine keeping the various ion signals in a scratch file. * (Last changed on 24/ 2/97.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. +SEQ,SIGNALDATA. INTEGER MXIREC PARAMETER(MXIREC=250) DOUBLE PRECISION SIG(*),TIME(*), - SVEC(MXLIST,MXIREC),TVEC(MXLIST,MXIREC) INTEGER IADREF(MXIREC),NVEC(MXIREC),NREF,ISTATE,IFAIL,NSIG, - NUSED(MXIREC),IAGE(MXIREC),ILEAST,IA,IW,ISW,IQ,IREC,I, - IADDR,ISTORE CHARACTER*(*) ACTION +SELF,IF=SAVE. SAVE IADREF,NREF,ISTATE,SVEC,TVEC,NVEC,NUSED,IAGE,ISTORE +SELF. DATA NREF/0/, ISTATE/0/, ISTORE/0/ *** Identify the routine if required. IF(LIDENT)PRINT *,' /// ROUTINE SIGIST (Memory) ///' *** Assume the operation will fail. IFAIL=1 *** Prepare the memory. IF(ACTION.EQ.'OPEN')THEN ISTATE=1 NREF=0 IFAIL=0 ISTORE=0 *** Reset memory. ELSEIF(ACTION.EQ.'RESET')THEN IF(ISTATE.EQ.0)THEN PRINT *,' !!!!!! SIGIST WARNING : No signal memory'// - ' currently active; not reset.' ELSE NREF=0 IFAIL=0 ISTORE=0 IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ SIGIST DEBUG :'', - '' Signal memory reset.'')') ENDIF *** Store a record. ELSEIF(ACTION.EQ.'STORE')THEN * Check the state of the file. IF(ISTATE.NE.1)THEN PRINT *,' !!!!!! SIGIST WARNING : Request to store'// - ' but signal memory not open; not stored.' RETURN ENDIF * Check address range validity. IF((IA.LT.1.OR.IA.GT.NORIA).OR. - (ISW.LT.1.OR.ISW.GT.MXSW).OR. - (IW.LT.1.OR.IW.GT.MXWIRE).OR. - ABS(IQ).NE.1)THEN PRINT *,' !!!!!! SIGIST WARNING : Signal address'// - ' out of range; not stored.' RETURN ENDIF * Compute reference address. IADDR=IQ*(IA+MXORIA*(ISW-1+MXSW*(IW-1))) * Locate the reference in the tables. ILEAST=1 DO 10 I=1,NREF IF(NUSED(I).LT.NUSED(ILEAST).OR. - (NUSED(I).EQ.NUSED(ILEAST).AND. - IAGE(I).LT.IAGE(ILEAST)))ILEAST=I IF(IADREF(I).EQ.IADDR)THEN IREC=I GOTO 20 ENDIF 10 CONTINUE * New record, allocate space. IF(NREF.LT.MXIREC)THEN NREF=NREF+1 IADREF(NREF)=IADDR IREC=NREF * Or re-use least used record. ELSE IREC=ILEAST IADREF(IREC)=IADDR ENDIF * In either case set the usage counter to 0. NUSED(IREC)=0 * Store the record. 20 CONTINUE DO 25 I=1,NSIG TVEC(I,IREC)=TIME(I) SVEC(I,IREC)=SIG(I) 25 CONTINUE NVEC(IREC)=NSIG IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ SIGIST DEBUG :'', - '' Stored record '',I6,'' for reference '',I6)') - IREC,IADDR * And keep track of the age. ISTORE=ISTORE+1 IAGE(IREC)=ISTORE * Seems to have worked. IFAIL=0 *** Retrieve a record. ELSEIF(ACTION.EQ.'READ')THEN * Check the state of the file. IF(ISTATE.NE.1)THEN PRINT *,' !!!!!! SIGIST WARNING : Request to read'// - ' but signal file not open; not read.' RETURN ENDIF * Check address range validity. IF((IA.LT.1.OR.IA.GT.NORIA).OR. - (ISW.LT.1.OR.ISW.GT.MXSW).OR. - (IW.LT.1.OR.IW.GT.MXWIRE).OR. - ABS(IQ).NE.1)THEN PRINT *,' !!!!!! SIGIST WARNING : Signal address'// - ' out of range; not read.' RETURN ENDIF * Compute reference address. IADDR=IQ*(IA+MXORIA*(ISW-1+MXSW*(IW-1))) * Locate the reference in the tables. DO 30 I=1,NREF IF(IADREF(I).EQ.IADDR)THEN IREC=I GOTO 40 ENDIF 30 CONTINUE * Unknown record, signal this via NSIG. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ SIGIST DEBUG :'', - '' Record '',4I4,'' not known.'')') ISW,IW,IA,IQ NSIG=-1 IFAIL=0 RETURN * Read the record. 40 CONTINUE NSIG=NVEC(IREC) DO 45 I=1,NSIG TIME(I)=TVEC(I,IREC) SIG(I)=SVEC(I,IREC) 45 CONTINUE IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ SIGIST DEBUG :'', - '' Read record '',I6,'' for reference '',I6)') - IREC,IADDR * Increment the usage counter. NUSED(IREC)=NUSED(IREC)+1 * Seems to have worked. IFAIL=0 *** List currently known records. ELSEIF(ACTION.EQ.'LIST')THEN * Print a header. WRITE(LUNOUT,'('' ++++++ SIGIST DEBUG : Overview of'', - '' currently known records:''//'' Record Angle'', - '' Wire Sense Charge Usage Birth''/)') * Loop over the records. DO 50 I=1,NREF IADDR=IADREF(I) IQ=SIGN(1,IADDR) IADDR=ABS(IADDR) IA=MOD(IADDR,MXORIA) IF(IA.EQ.0)IA=MXORIA IADDR=(IADDR-IA)/MXORIA ISW=MOD(IADDR,MXSW)+1 IF(ISW.EQ.0)ISW=MXSW IW=(IADDR-ISW+1)/MXSW+1 WRITE(LUNOUT,'(5(2X,I6))') I,IA,IW,ISW,IQ,NUSED(I),IAGE(I) 50 CONTINUE * Overview. WRITE(LUNOUT,'(/'' Total of '',I6,'' records.'')') NREF * This can not fail. IFAIL=0 *** Close the memory. ELSEIF(ACTION.EQ.'CLOSE')THEN ISTATE=0 NREF=0 IFAIL=0 IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ SIGIST DEBUG :'', - '' Closed signal memory.'')') *** Other actions are not known. ELSE PRINT *,' !!!!!! SIGIST WARNING : Action not known;'// - ' nothing done.' ENDIF END +DECK,SIGIST,IF=-MEMORY. SUBROUTINE SIGIST(ACTION,NSIG,TIME,SIG,ISW,IW,IA,IQ,IFAIL) *----------------------------------------------------------------------- * SIGIST - Routine keeping the various ion signals in a scratch file. * (Last changed on 24/ 2/97.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,SIGNALDATA. +SEQ,PRINTPLOT. INTEGER LUNIST,MXIREC PARAMETER(MXIREC=1000,LUNIST=14) DOUBLE PRECISION SIG(*),TIME(*) INTEGER IADREF(MXIREC),NREF,ISTATE,IFAIL,NSIG,NVEC(MXIREC), - ISW,IW,IA,IQ,NUSED(MXIREC),ILEAST,IREC,I, - ISTORE,IAGE(MXIREC),IADDR,IOS LOGICAL OPEN CHARACTER*(*) ACTION +SELF,IF=SAVE. SAVE IADREF,NREF,ISTATE,NVEC,NUSED,ISTORE,IAGE +SELF. DATA NREF/0/, ISTATE/0/, ISTORE/0/ *** Identify the routine if required. IF(LIDENT)PRINT *,' /// ROUTINE SIGIST (File) ///' *** Assume the operation will fail. IFAIL=1 *** Open the scratch file. IF(ACTION.EQ.'OPEN')THEN * Check that the file is not already open. INQUIRE(UNIT=LUNIST,OPENED=OPEN) * Close if it is. IF(OPEN)THEN PRINT *,' !!!!!! SIGIST WARNING : Ion signal unit'// - ' unexpectedly open; closed.' CLOSE(UNIT=LUNIST,ERR=2030,IOSTAT=IOS) ENDIF * Open the file. +SELF,IF=VAX. OPEN(UNIT=LUNIST,STATUS='SCRATCH',ACCESS='DIRECT', - FORM='UNFORMATTED',ERR=2020,RECL=4*MXLIST, - MAXREC=MXIREC,IOSTAT=IOS) +SELF,IF=CMS. CALL FILEINF(IRC,'MAXREC',MXIREC) OPEN(UNIT=LUNIST,STATUS='SCRATCH',ACCESS='DIRECT', - FORM='UNFORMATTED',ERR=2020,RECL=16*MXLIST, - IOSTAT=IOS) +SELF,IF=-VAX,IF=-CMS. OPEN(UNIT=LUNIST,STATUS='SCRATCH',ACCESS='DIRECT', - FORM='UNFORMATTED',ERR=2020,RECL=16*MXLIST, - IOSTAT=IOS) +SELF. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ SIGIST DEBUG :'', - '' Signal file opened on unit '',I6)') LUNIST * Keep track of this. ISTATE=1 NREF=0 * Reset the number of stores. ISTORE=0 * Seems to have worked. IFAIL=0 *** Reset the file. ELSEIF(ACTION.EQ.'RESET')THEN IF(ISTATE.EQ.0)THEN PRINT *,' !!!!!! SIGIST WARNING : No signal file'// - ' currently active; not reset.' ELSE NREF=0 IFAIL=0 ISTORE=0 IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ SIGIST DEBUG :'', - '' Signal file reset on unit '',I6)') LUNIST ENDIF *** Store a record. ELSEIF(ACTION.EQ.'STORE')THEN * Check the state of the file. IF(ISTATE.NE.1)THEN PRINT *,' !!!!!! SIGIST WARNING : Request to store'// - ' but signal file not open; not stored.' RETURN ENDIF * Check address range validity. IF((IA.LT.1.OR.IA.GT.NORIA).OR. - (ISW.LT.1.OR.ISW.GT.MXSW).OR. - (IW.LT.1.OR.IW.GT.MXWIRE).OR. - ABS(IQ).NE.1)THEN PRINT *,' !!!!!! SIGIST WARNING : Signal address'// - ' out of range; not stored.' RETURN ENDIF * Compute reference address. IADDR=IQ*(IA+MXORIA*(ISW-1+MXSW*(IW-1))) * Locate the reference in the tables and also the least used record. ILEAST=1 DO 10 I=1,NREF IF(NUSED(I).LT.NUSED(ILEAST).OR. - (NUSED(I).EQ.NUSED(ILEAST).AND. - IAGE(I).LT.IAGE(ILEAST)))ILEAST=I IF(IADREF(I).EQ.IADDR)THEN IREC=I GOTO 20 ENDIF 10 CONTINUE * New record, allocate space. IF(NREF.LT.MXIREC)THEN NREF=NREF+1 IADREF(NREF)=IADDR IREC=NREF * Or reuse the least used record sofar. ELSE IREC=ILEAST IADREF(IREC)=IADDR ENDIF * In either case set the usage counter to 0. NUSED(IREC)=0 * Write the record. 20 CONTINUE NVEC(IREC)=NSIG WRITE(UNIT=LUNIST,REC=IREC,ERR=2010,IOSTAT=IOS) - (TIME(I),I=1,NSIG),(SIG(I),I=1,NSIG) IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ SIGIST DEBUG :'', - '' Stored record '',I6,'' for reference '',I6)') - IREC,IADDR * And keep track of the age. ISTORE=ISTORE+1 IAGE(IREC)=ISTORE * Seems to have worked. IFAIL=0 *** Retrieve a record. ELSEIF(ACTION.EQ.'READ')THEN * Check the state of the file. IF(ISTATE.NE.1)THEN PRINT *,' !!!!!! SIGIST WARNING : Request to read'// - ' but signal file not open; not read.' RETURN ENDIF * Check address range validity. IF((IA.LT.1.OR.IA.GT.NORIA).OR. - (ISW.LT.1.OR.ISW.GT.MXSW).OR. - (IW.LT.1.OR.IW.GT.MXWIRE).OR. - ABS(IQ).NE.1)THEN PRINT *,' !!!!!! SIGIST WARNING : Signal address'// - ' out of range; not read.' RETURN ENDIF * Compute reference address. IADDR=IQ*(IA+MXORIA*(ISW-1+MXSW*(IW-1))) * Locate the reference in the tables. DO 30 I=1,NREF IF(IADREF(I).EQ.IADDR)THEN IREC=I GOTO 40 ENDIF 30 CONTINUE * Unknown record, signal this via NSIG. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ SIGIST DEBUG :'', - '' Record '',4I4,'' not known.'')') ISW,IW,IA,IQ NSIG=-1 IFAIL=0 RETURN * Read the record. 40 CONTINUE NSIG=NVEC(IREC) READ(UNIT=LUNIST,REC=IREC,ERR=2010,IOSTAT=IOS) - (TIME(I),I=1,NSIG),(SIG(I),I=1,NSIG) IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ SIGIST DEBUG :'', - '' Read record '',I6,'' for reference '',I6)') - IREC,IADDR * Increment the usage counter. NUSED(IREC)=NUSED(IREC)+1 * Seems to have worked. IFAIL=0 *** List currently known records. ELSEIF(ACTION.EQ.'LIST')THEN * Print a header. WRITE(LUNOUT,'('' ++++++ SIGIST DEBUG : Overview of'', - '' currently known records:''//'' Record Angle'', - '' Wire Sense Charge Usage Birth''/)') * Loop over the records. DO 50 I=1,NREF IADDR=IADREF(I) IQ=SIGN(1,IADDR) IADDR=ABS(IADDR) IA=MOD(IADDR,MXORIA) IF(IA.EQ.0)IA=MXORIA IADDR=(IADDR-IA)/MXORIA ISW=MOD(IADDR,MXSW)+1 IF(ISW.EQ.0)ISW=MXSW IW=(IADDR-ISW+1)/MXSW+1 WRITE(LUNOUT,'(5(2X,I6))') I,IA,IW,ISW,IQ,NUSED(I),IAGE(I) 50 CONTINUE * Overview. WRITE(LUNOUT,'(/'' Total of '',I6,'' records.'')') NREF * This can not fail. IFAIL=0 *** Close the file. ELSEIF(ACTION.EQ.'CLOSE')THEN * Check that the file is indeed open. INQUIRE(UNIT=LUNIST,OPENED=OPEN) * Close if open. IF(.NOT.OPEN)THEN PRINT *,' !!!!!! SIGIST WARNING : Ion signal unit'// - ' is already closed; not closed again.' ELSE CLOSE(UNIT=LUNIST,ERR=2030,IOSTAT=IOS) ENDIF * Keep track of the state. ISTATE=0 NREF=0 * Seems to have worked. IFAIL=0 IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ SIGIST DEBUG :'', - '' Closed signal unit '',I6)') LUNIST *** Other actions are not known. ELSE PRINT *,' !!!!!! SIGIST WARNING : Action not known;'// - ' nothing done.' ENDIF *** I/O error handling. RETURN 2010 CONTINUE PRINT *,' !!!!!! SIGIST WARNING : Read/write error to'// - ' signal file ; action not completed.' CALL INPIOS(IOS) RETURN 2020 CONTINUE PRINT *,' !!!!!! SIGIST WARNING : Open error on'// - ' signal file ; action not completed.' CALL INPIOS(IOS) RETURN 2030 CONTINUE PRINT *,' !!!!!! SIGIST WARNING : Close error on'// - ' signal file ; action not completed.' CALL INPIOS(IOS) END +DECK,SIGFLD. SUBROUTINE SIGFLD(XPOS,YPOS,ZPOS,EX,EY,EZ,MX,MY,IW) *----------------------------------------------------------------------- * SIGFLD - Routine redirecting the calls for reduced periodicity field * vectors. * (Last changed on 4/11/97.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,SIGNALDATA. REAL XPOS,YPOS,ZPOS,EX,EY,EZ INTEGER IW,MX,MY *** Initial settings. EX=0 EY=0 EZ=0 *** Various cell types. IF(FCELTP.EQ.'A ')THEN CALL IONA00(XPOS,YPOS,EX,EY,MX,MY,IW) ELSEIF(FCELTP.EQ.'B2X')THEN CALL IONB2X(XPOS,YPOS,EX,EY ,MY,IW) ELSEIF(FCELTP.EQ.'B2Y')THEN CALL IONB2Y(XPOS,YPOS,EX,EY,MX ,IW) ELSEIF(FCELTP.EQ.'C3 ')THEN CALL IONC30(XPOS,YPOS,EX,EY ,IW) ELSEIF(FCELTP.EQ.'D1 ')THEN CALL IOND10(XPOS,YPOS,EX,EY ,IW) ELSEIF(FCELTP.EQ.'D3 ')THEN CALL IOND30(XPOS,YPOS,EX,EY ,IW) ELSEIF(FCELTP.EQ.'MAP')THEN CALL IONFMP(XPOS,YPOS,ZPOS,EX,EY,EZ,IW) ELSE PRINT *,' ###### SIGFLD ERROR : Unknown signal field'// - ' type ',FCELTP,' received; program error.' ENDIF END +DECK,SIGFLS. SUBROUTINE SIGFLS(XPOS,YPOS,ZPOS,EXSUM,EYSUM,EZSUM,ISW) *----------------------------------------------------------------------- * SIGFLS - Sums the weighting field components at (XPOS,YPOS,ZPOS). * (Last changed on 7/12/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,FIELDMAP. +SEQ,SIGNALDATA. +SEQ,SIGNALMATRIX. REAL XPOS,YPOS,ZPOS,EX,EY,EZ,EXSUM,EYSUM,EZSUM INTEGER MX,MY,IFAIL,IW,ISW,IPLANE,IWMAP,ISTRIP *** Preset the sums. EXSUM=0 EYSUM=0 EZSUM=0 *** Make sure that the signal matrices are present. IF(.NOT.SIGSET)THEN PRINT *,' !!!!!! SIGFLS WARNING : Initialisation of'// - ' signal calculation not yet done; no field.' RETURN ENDIF *** Loop over the signal layers. DO 10 MX=MXMIN,MXMAX DO 20 MY=MYMIN,MYMAX *** Load the layers of the wire matrices. CALL IONIO(MX,MY,2,0,IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! SIGFLS WARNING : Wire matrix'// - ' store error; no weighting field returned.' EXSUM=0 EYSUM=0 EZSUM=0 RETURN ENDIF *** Loop over all wires. DO 30 IW=1,NWIRE * Pick out those wires that are part of this read out group. IF(INDSW(IW).EQ.ISW)THEN IF(FCELTP.EQ.'A ')THEN CALL IONA00(XPOS,YPOS,EX,EY,MX,MY,IW) ELSEIF(FCELTP.EQ.'B2X')THEN CALL IONB2X(XPOS,YPOS,EX,EY ,MY,IW) ELSEIF(FCELTP.EQ.'B2Y')THEN CALL IONB2Y(XPOS,YPOS,EX,EY,MX ,IW) ELSEIF(FCELTP.EQ.'C3 ')THEN CALL IONC30(XPOS,YPOS,EX,EY ,IW) ELSEIF(FCELTP.EQ.'D1 ')THEN CALL IOND10(XPOS,YPOS,EX,EY ,IW) ELSEIF(FCELTP.EQ.'D3 ')THEN CALL IOND30(XPOS,YPOS,EX,EY ,IW) ELSE PRINT *,' ###### SIGFLS ERROR : Unknown signal'// - ' field type ',FCELTP,' received; program error.' EXSUM=0 EYSUM=0 EZSUM=0 RETURN ENDIF EXSUM=EXSUM+EX EYSUM=EYSUM+EY EZSUM=EZSUM+EZ ENDIF 30 CONTINUE *** Load the layers of the plane matrices. CALL IPLIO(MX,MY,2,IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! SIGFLS WARNING : Plane matrix'// - ' store error; no weighting field returned.' EXSUM=0 EYSUM=0 EZSUM=0 RETURN ENDIF *** Loop over all planes. DO 40 IPLANE=1,5 * Pick out those wires that are part of this read out group. IF(INDPLA(IPLANE).EQ.ISW)THEN IF(FCELTP.EQ.'A ')THEN CALL IPLA00(XPOS,YPOS,EX,EY,MX,MY,IPLANE) ELSEIF(FCELTP.EQ.'B2X')THEN CALL IPLB2X(XPOS,YPOS,EX,EY ,MY,IPLANE) ELSEIF(FCELTP.EQ.'B2Y')THEN CALL IPLB2Y(XPOS,YPOS,EX,EY,MX ,IPLANE) ELSEIF(FCELTP.EQ.'C3 ')THEN CALL IPLC30(XPOS,YPOS,EX,EY ,IPLANE) ELSEIF(FCELTP.EQ.'D1 ')THEN CALL IPLD10(XPOS,YPOS,EX,EY ,IPLANE) ELSEIF(FCELTP.EQ.'D3 ')THEN CALL IPLD30(XPOS,YPOS,EX,EY ,IPLANE) ELSE PRINT *,' ###### SIGFLS ERROR : Unknown signal'// - ' field type ',FCELTP,' received; program error.' EXSUM=0 EYSUM=0 EZSUM=0 RETURN ENDIF EXSUM=EXSUM+EX EYSUM=EYSUM+EY EZSUM=EZSUM+EZ ENDIF 40 CONTINUE *** Next signal layer. 20 CONTINUE 10 CONTINUE *** Add the field due to the planes themselves. DO 50 IPLANE=1,5 IF(INDPLA(IPLANE).EQ.ISW)THEN EXSUM=EXSUM+EWXCOR(IPLANE) EYSUM=EYSUM+EWYCOR(IPLANE) ENDIF 50 CONTINUE *** Add the field map, if appropriate. DO 60 IWMAP=1,NWMAP IF(INDEWS(IWMAP).EQ.ISW)THEN CALL IONFMP(XPOS,YPOS,ZPOS,EX,EY,EZ,IWMAP) EXSUM=EXSUM+EX EYSUM=EYSUM+EY EZSUM=EZSUM+EZ ENDIF 60 CONTINUE *** Add strips, if there are any. DO 70 IPLANE=1,5 DO 80 ISTRIP=1,NPSTR1(IPLANE) IF(INDST1(IPLANE,ISTRIP).EQ.ISW)THEN CALL IONEST(XPOS,YPOS,ZPOS,EX,EY,EZ,IPLANE,ISTRIP,1) EXSUM=EXSUM+EX EYSUM=EYSUM+EY EZSUM=EZSUM+EZ ENDIF 80 CONTINUE DO 90 ISTRIP=1,NPSTR2(IPLANE) IF(INDST2(IPLANE,ISTRIP).EQ.ISW)THEN CALL IONEST(XPOS,YPOS,ZPOS,EX,EY,EZ,IPLANE,ISTRIP,2) EXSUM=EXSUM+EX EYSUM=EYSUM+EY EZSUM=EZSUM+EZ ENDIF 90 CONTINUE 70 CONTINUE END +DECK,IONA00. SUBROUTINE IONA00(XPOS,YPOS,EX,EY,MX,MY,ISW) *----------------------------------------------------------------------- * IONA00 - Routine returning the A I,J [MX,MY] * E terms for A cells. * VARIABLES : R2 : Potential before taking -Log(Sqrt(...)) * EX,EY : x,y-Component of the electric field. * ETOT : Magnitude of the electric field. * VOLT : Potential. * EXHELP ETC : One term in the summing series. * (XPOS,YPOS): Position where the field is needed. * (Last changed on 14/ 8/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,SIGNALMATRIX. REAL XPOS,YPOS,EX,EY,XX,XXMIRR,YY,YYMIRR,R2,R2PLAN,EXHELP,EYHELP INTEGER MX,MY,ISW,I *** Initialise the potential and the electric field. EX=0.0 EY=0.0 *** Loop over all wires. DO 10 I=1,NWIRE *** Define a few reduced variables. XX=XPOS-X(I)-MX*SX YY=YPOS-Y(I)-MY*SY *** Calculate the field in case there are no planes. R2=XX**2+YY**2 IF(R2.LE.0)GOTO 10 EXHELP=XX/R2 EYHELP=YY/R2 *** Take care of a planes at constant x. IF(YNPLAX)THEN XXMIRR=XPOS+X(I)-2.0*COPLAX R2PLAN=XXMIRR**2+YY**2 IF(R2PLAN.LE.0)GOTO 10 EXHELP=EXHELP-XXMIRR/R2PLAN EYHELP=EYHELP-YY/R2PLAN ENDIF *** Take care of a plane at constant y. IF(YNPLAY)THEN YYMIRR=YPOS+Y(I)-2.0*COPLAY R2PLAN=XX**2+YYMIRR**2 IF(R2PLAN.LE.0)GOTO 10 EXHELP=EXHELP-XX/R2PLAN EYHELP=EYHELP-YYMIRR/R2PLAN ENDIF *** Take care of pairs of planes. IF(YNPLAX.AND.YNPLAY)THEN R2PLAN=XXMIRR**2+YYMIRR**2 IF(R2PLAN.LE.0)GOTO 10 EXHELP=EXHELP+XXMIRR/R2PLAN EYHELP=EYHELP+YYMIRR/R2PLAN ENDIF *** Calculate the electric field and the potential. EX=EX+REAL(SIGMAT(ISW,I))*EXHELP EY=EY+REAL(SIGMAT(ISW,I))*EYHELP *** Finish the loop over the wires. 10 CONTINUE END +DECK,IONB2X. SUBROUTINE IONB2X(XPOS,YPOS,EX,EY,MY,ISW) *----------------------------------------------------------------------- * IONB2X - Routine calculating the MY contribution to the signal on * wire ISW due to a charge at (XPOS,YPOS) for F-B2Y cells. * VARIABLES : See routine EFCA00 for most of the variables. * Z,ZZMIRR : X + I*Y , XXMIRR + I*YYMIRR ; I**2=-1 * ECOMPL : EX + I*EY ; I**2=-1 * (Last changed on 20/ 2/90.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,CONSTANTS. +SEQ,SIGNALMATRIX. COMPLEX ZZ,ECOMPL,ZZMIRR,ZZNEG,ZZNMIR *** Initialise EX and EY. EX=0.0 EY=0.0 *** Loop over all wires. DO 10 I=1,NWIRE XX=0.5*PI*(XPOS-X(I))/SX YY=0.5*PI*(YPOS-Y(I)-MY*SY)/SX XXNEG=0.5*PI*(XPOS+X(I)-2.0*COPLAN(1))/SX ZZ=CMPLX(XX,YY) ZZNEG=CMPLX(XXNEG,YY) *** Calculate the field in case there are no equipotential planes. ECOMPL=0.0 IF(ABS(YY).LE.20)ECOMPL=-B2SIN(I)/(SIN(ZZ)*SIN(ZZNEG)) *** Take care of a plane at constant y. IF(YNPLAY)THEN YYMIRR=(0.5*PI/SX)*(YPOS+Y(I)-2.0*COPLAY) ZZMIRR=CMPLX(XX,YYMIRR) ZZNMIR=CMPLX(XXNEG,YYMIRR) IF(ABS(YYMIRR).LE.20.0) - ECOMPL=ECOMPL+B2SIN(I)/(SIN(ZZMIRR)*SIN(ZZNMIR)) ENDIF *** Calculate the electric field and the potential. EX=EX+REAL(SIGMAT(ISW,I))*(0.5*PI/SX)*REAL(ECOMPL) EY=EY-REAL(SIGMAT(ISW,I))*(0.5*PI/SX)*AIMAG(ECOMPL) *** Finish the wire loop 10 CONTINUE END +DECK,IONB2Y. SUBROUTINE IONB2Y(XPOS,YPOS,EX,EY,MX,ISW) *----------------------------------------------------------------------- * IONB2Y - Routine calculating the MX contribution to the signal on * wire ISW due to a charge at (XPOS,YPOS) for F-B2X cells. * VARIABLES : See routine EFCA00 for most of the variables. * Z,ZZMIRR : X + I*Y , XXMIRR + I*YYMIRR ; I**2=-1 * ECOMPL : EX + I*EY ; I**2=-1 * (Last changed on 20/ 2/90.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,CONSTANTS. +SEQ,SIGNALMATRIX. COMPLEX ZZ,ECOMPL,ZZMIRR,ZZNEG,ZZNMIR *** Initialise EX and EY. EX=0.0 EY=0.0 *** Loop over all wires. DO 10 I=1,NWIRE XX=0.5*PI*(XPOS-X(I)-MX*SX)/SY YY=0.5*PI*(YPOS-Y(I))/SY YYNEG=0.5*PI*(YPOS+Y(I)-2.0*COPLAN(3))/SY ZZ=CMPLX(XX,YY) ZZNEG=CMPLX(XX,YYNEG) *** Calculate the field in case there are no equipotential planes. ECOMPL=0.0 IF(ABS(XX).LE.20.0) - ECOMPL=ICONS*B2SIN(I)/(SIN(ICONS*ZZ)*SIN(ICONS*ZZNEG)) *** Take care of a plane at constant y. IF(YNPLAX)THEN XXMIRR=(0.5*PI/SY)*(XPOS+X(I)-2.0*COPLAX) ZZMIRR=CMPLX(XXMIRR,YY) ZZNMIR=CMPLX(XXMIRR,YYNEG) IF(ABS(XXMIRR).LE.20.0)ECOMPL=ECOMPL- - ICONS*B2SIN(I)/(SIN(ICONS*ZZMIRR)*SIN(ICONS*ZZNMIR)) ENDIF *** Calculate the electric field and the potential.. EX=EX+REAL(SIGMAT(ISW,I))*(0.5*PI/SY)*REAL(ECOMPL) EY=EY-REAL(SIGMAT(ISW,I))*(0.5*PI/SY)*AIMAG(ECOMPL) *** Finish the wire loop. 10 CONTINUE END +DECK,IONC30. SUBROUTINE IONC30(XPOS,YPOS,EX,EY,ISW) *----------------------------------------------------------------------- * IONC30 - Routine returning the weighting field field in a * configuration with 2 y and 2 x planes. This routine is * basically the same as EFCC30. * (Last changed on 11/11/97.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,CONSTANTS. +SEQ,SIGNALMATRIX. COMPLEX WSUM1,WSUM2,WSUM3,WSUM4,ZSIN,ZCOF,ZU,ZUNEW, - ZTERM1,ZTERM2,ZETA REAL XPOS,YPOS,EX,EY,CX,CY INTEGER I,ISW *** Initial values. WSUM1=0 WSUM2=0 WSUM3=0 WSUM4=0 *** Wire loop. DO 10 I=1,NWIRE * Compute the direct contribution. ZETA=ZMULT*CMPLX(XPOS-X(I),YPOS-Y(I)) IF(AIMAG(ZETA).GT.+15)THEN WSUM1=WSUM1-REAL(SIGMAT(ISW,I))*ICONS ELSEIF(AIMAG(ZETA).LT.-15)THEN WSUM1=WSUM1+REAL(SIGMAT(ISW,I))*ICONS ELSE ZSIN=SIN(ZETA) ZCOF=4*ZSIN**2-2 ZU=-P1-ZCOF*P2 ZUNEW=1-ZCOF*ZU-P2 ZTERM1=(ZUNEW+ZU)*ZSIN ZU=-3*P1-ZCOF*5*P2 ZUNEW=1-ZCOF*ZU-5*P2 ZTERM2=(ZUNEW-ZU)*COS(ZETA) WSUM1=WSUM1+REAL(SIGMAT(ISW,I))*(ZTERM2/ZTERM1) ENDIF * Find the plane nearest to the wire. CX=COPLAX-SX*ANINT((COPLAX-X(I))/SX) * Mirror contribution from the x plane. ZETA=ZMULT*CMPLX(2*CX-XPOS-X(I),YPOS-Y(I)) IF(AIMAG(ZETA).GT.+15)THEN WSUM2=WSUM2-REAL(SIGMAT(ISW,I))*ICONS ELSEIF(AIMAG(ZETA).LT.-15)THEN WSUM2=WSUM2+REAL(SIGMAT(ISW,I))*ICONS ELSE ZSIN=SIN(ZETA) ZCOF=4*ZSIN**2-2 ZU=-P1-ZCOF*P2 ZUNEW=1-ZCOF*ZU-P2 ZTERM1=(ZUNEW+ZU)*ZSIN ZU=-3*P1-ZCOF*5*P2 ZUNEW=1-ZCOF*ZU-5*P2 ZTERM2=(ZUNEW-ZU)*COS(ZETA) WSUM2=WSUM2+REAL(SIGMAT(ISW,I))*(ZTERM2/ZTERM1) ENDIF * Find the plane nearest to the wire. CY=COPLAY-SY*ANINT((COPLAY-Y(I))/SY) * Mirror contribution from the y plane. ZETA=ZMULT*CMPLX(XPOS-X(I),2*CY-YPOS-Y(I)) IF(AIMAG(ZETA).GT.+15)THEN WSUM3=WSUM3-REAL(SIGMAT(ISW,I))*ICONS ELSEIF(AIMAG(ZETA).LT.-15)THEN WSUM3=WSUM3+REAL(SIGMAT(ISW,I))*ICONS ELSE ZSIN=SIN(ZETA) ZCOF=4*ZSIN**2-2 ZU=-P1-ZCOF*P2 ZUNEW=1-ZCOF*ZU-P2 ZTERM1=(ZUNEW+ZU)*ZSIN ZU=-3*P1-ZCOF*5*P2 ZUNEW=1-ZCOF*ZU-5*P2 ZTERM2=(ZUNEW-ZU)*COS(ZETA) WSUM3=WSUM3+REAL(SIGMAT(ISW,I))*(ZTERM2/ZTERM1) ENDIF * Mirror contribution from both the x and the y plane. ZETA=ZMULT*CMPLX(2*CX-XPOS-X(I),2*CY-YPOS-Y(I)) IF(AIMAG(ZETA).GT.+15)THEN WSUM4=WSUM4-REAL(SIGMAT(ISW,I))*ICONS ELSEIF(AIMAG(ZETA).LT.-15)THEN WSUM4=WSUM4+REAL(SIGMAT(ISW,I))*ICONS ELSE ZSIN=SIN(ZETA) ZCOF=4*ZSIN**2-2 ZU=-P1-ZCOF*P2 ZUNEW=1-ZCOF*ZU-P2 ZTERM1=(ZUNEW+ZU)*ZSIN ZU=-3*P1-ZCOF*5*P2 ZUNEW=1-ZCOF*ZU-5*P2 ZTERM2=(ZUNEW-ZU)*COS(ZETA) WSUM4=WSUM4+REAL(SIGMAT(ISW,I))*(ZTERM2/ZTERM1) ENDIF 10 CONTINUE *** Convert the two contributions to a real field. EX=+REAL(ZMULT*(WSUM1+WSUM2-WSUM3-WSUM4)) EY=-AIMAG(ZMULT*(WSUM1-WSUM2+WSUM3-WSUM4)) END +DECK,IOND10. SUBROUTINE IOND10(XPOS,YPOS,EX,EY,ISW) *----------------------------------------------------------------------- * IOND10 - Subroutine computing the signal on wire ISW due to a charge * at (XPOS,YPOS). This is effectively routine EFCD10. * VARIABLES : EX, EY, VOLT:Electric field and potential. * ETOT, VOLT : Magnitude of electric field, potential. * (XPOS,YPOS): The position where the field is calculated. * ZI, ZPOS : Shorthand complex notations. * (Last changed on 2/ 2/93.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,SIGNALMATRIX. COMPLEX ZI,ZPOS *** Initialise the potential and the electric field. EX=0.0 EY=0.0 * Set the complex position coordinates. ZPOS=CMPLX(XPOS,YPOS) *** Loop over all wires. DO 10 I=1,NWIRE * Set the complex version of the wire-coordinate for simplicity. ZI=CMPLX(X(I),Y(I)) * Compute the contribution to the electric field, always. EX=EX+REAL(SIGMAT(ISW,I))*REAL(1/CONJG(ZPOS-ZI)+ - ZI/(COTUBE**2-CONJG(ZPOS)*ZI)) EY=EY+REAL(SIGMAT(ISW,I))*AIMAG(1/CONJG(ZPOS-ZI)+ - ZI/(COTUBE**2-CONJG(ZPOS)*ZI)) *** Finish the loop over the wires. 10 CONTINUE END +DECK,IOND30. SUBROUTINE IOND30(XPOS,YPOS,EX,EY,ISW) *----------------------------------------------------------------------- * IOND30 - Subroutine computing the weighting field for a polygonal * cells without periodicities, type D3. * VARIABLES : EX, EY :Electric field * (XPOS,YPOS): The position where the field is calculated. * ZI, ZPOS : Shorthand complex notations. * (Last changed on 19/ 6/97.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,SIGNALMATRIX. REAL EX,EY,XPOS,YPOS INTEGER I,ISW COMPLEX WPOS,WDPOS *** Initialise electric field. EX=0.0 EY=0.0 * Get the mapping of the position. CALL EFCMAP(CMPLX(XPOS,YPOS)/COTUBE,WPOS,WDPOS) *** Loop over all wires. DO 10 I=1,NWIRE * Compute the contribution to the electric field. EX=EX+(SIGMAT(ISW,I)/COTUBE)*REAL(WDPOS*(1-ABS(WMAP(I))**2)/ - ((WPOS-WMAP(I))*(1-CONJG(WMAP(I))*WPOS))) EY=EY-(SIGMAT(ISW,I)/COTUBE)*AIMAG(WDPOS*(1-ABS(WMAP(I))**2)/ - ((WPOS-WMAP(I))*(1-CONJG(WMAP(I))*WPOS))) *** Finish the loop over the wires. 10 CONTINUE END +DECK,SIGPLA. SUBROUTINE SIGPLA(XPOS,YPOS,ZPOS,EX,EY,EZ,MX,MY,IPLANE) *----------------------------------------------------------------------- * SIGPLA - Routine redirecting the calls for reduced periodicity field * vectors. * (Last changed on 12/11/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,SIGNALDATA. +SEQ,SIGNALMATRIX. REAL XPOS,YPOS,ZPOS,EX,EY,EZ INTEGER IPLANE,MX,MY *** Initial settings. EX=0 EY=0 EZ=0 *** Various cell types. IF(FCELTP.EQ.'A ')THEN CALL IPLA00(XPOS,YPOS,EX,EY,MX,MY,IPLANE) ELSEIF(FCELTP.EQ.'B2X')THEN CALL IPLB2X(XPOS,YPOS,EX,EY ,MY,IPLANE) ELSEIF(FCELTP.EQ.'B2Y')THEN CALL IPLB2Y(XPOS,YPOS,EX,EY,MX ,IPLANE) ELSEIF(FCELTP.EQ.'C3 ')THEN CALL IPLC30(XPOS,YPOS,EX,EY ,IPLANE) ELSEIF(FCELTP.EQ.'D1 ')THEN CALL IPLD10(XPOS,YPOS,EX,EY ,IPLANE) ELSEIF(FCELTP.EQ.'D3 ')THEN CALL IPLD30(XPOS,YPOS,EX,EY ,IPLANE) ELSE PRINT *,' ###### SIGPLA ERROR : Unknown signal field'// - ' type ',FCELTP,' received; program error.' ENDIF *** Add the field due to the planes themselves. EX=EX+EWXCOR(IPLANE) EY=EY+EWYCOR(IPLANE) END +DECK,IPLA00. SUBROUTINE IPLA00(XPOS,YPOS,EX,EY,MX,MY,IPLANE) *----------------------------------------------------------------------- * IPLA00 - Routine returning the A I,J [MX,MY] * E terms for A cells. * VARIABLES : R2 : Potential before taking -Log(Sqrt(...)) * EX,EY : x,y-Component of the electric field. * EXHELP ETC : One term in the summing series. * (XPOS,YPOS): Position where the field is needed. * (Last changed on 9/11/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,SIGNALMATRIX. REAL XPOS,YPOS,EX,EY,XX,XXMIRR,YY,YYMIRR,R2,R2PLAN,EXHELP,EYHELP INTEGER MX,MY,IPLANE,I *** Initialise the electric field. EX=0 EY=0 *** Loop over all wires. DO 10 I=1,NWIRE *** Define a few reduced variables. XX=XPOS-X(I)-MX*SX YY=YPOS-Y(I)-MY*SY *** Calculate the field in case there are no planes. R2=XX**2+YY**2 IF(R2.LE.0)GOTO 10 EXHELP=XX/R2 EYHELP=YY/R2 *** Take care of a planes at constant x. IF(YNPLAX)THEN XXMIRR=XPOS+X(I)-2.0*COPLAX R2PLAN=XXMIRR**2+YY**2 IF(R2PLAN.LE.0)GOTO 10 EXHELP=EXHELP-XXMIRR/R2PLAN EYHELP=EYHELP-YY/R2PLAN ENDIF *** Take care of a plane at constant y. IF(YNPLAY)THEN YYMIRR=YPOS+Y(I)-2.0*COPLAY R2PLAN=XX**2+YYMIRR**2 IF(R2PLAN.LE.0)GOTO 10 EXHELP=EXHELP-XX/R2PLAN EYHELP=EYHELP-YYMIRR/R2PLAN ENDIF *** Take care of pairs of planes. IF(YNPLAX.AND.YNPLAY)THEN R2PLAN=XXMIRR**2+YYMIRR**2 IF(R2PLAN.LE.0)GOTO 10 EXHELP=EXHELP+XXMIRR/R2PLAN EYHELP=EYHELP+YYMIRR/R2PLAN ENDIF *** Calculate the electric field. EX=EX+QPLANE(IPLANE,I)*EXHELP EY=EY+QPLANE(IPLANE,I)*EYHELP *** Finish the loop over the wires. 10 CONTINUE END +DECK,IPLB2X. SUBROUTINE IPLB2X(XPOS,YPOS,EX,EY,MY,IPLANE) *----------------------------------------------------------------------- * IPLB2X - Routine calculating the MY contribution to the signal on * wire IPLANE due to a charge at (XPOS,YPOS) for F-B2Y cells. * VARIABLES : See routine EFCA00 for most of the variables. * Z,ZZMIRR : X + I*Y , XXMIRR + I*YYMIRR ; I**2=-1 * ECOMPL : EX + I*EY ; I**2=-1 * (Last changed on 12/11/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,CONSTANTS. +SEQ,SIGNALMATRIX. REAL XPOS,YPOS,EX,EY,XX,YY,XXNEG,YYMIRR INTEGER I,MY,IPLANE COMPLEX ZZ,ECOMPL,ZZMIRR,ZZNEG,ZZNMIR *** Initialise EX and EY. EX=0 EY=0 *** Loop over all wires. DO 10 I=1,NWIRE XX=0.5*PI*(XPOS-X(I))/SX YY=0.5*PI*(YPOS-Y(I)-MY*SY)/SX XXNEG=0.5*PI*(XPOS+X(I)-2*COPLAN(1))/SX ZZ=CMPLX(XX,YY) ZZNEG=CMPLX(XXNEG,YY) *** Calculate the field in case there are no equipotential planes. IF(ABS(YY).LE.20)THEN ECOMPL=-B2SIN(I)/(SIN(ZZ)*SIN(ZZNEG)) ELSE ECOMPL=0 ENDIF *** Take care of a plane at constant y. IF(YNPLAY)THEN YYMIRR=(0.5*PI/SX)*(YPOS+Y(I)-2.0*COPLAY) ZZMIRR=CMPLX(XX,YYMIRR) ZZNMIR=CMPLX(XXNEG,YYMIRR) IF(ABS(YYMIRR).LE.20) - ECOMPL=ECOMPL+B2SIN(I)/(SIN(ZZMIRR)*SIN(ZZNMIR)) ENDIF *** Calculate the electric field. EX=EX+QPLANE(IPLANE,I)*(0.5*PI/SX)*REAL(ECOMPL) EY=EY-QPLANE(IPLANE,I)*(0.5*PI/SX)*AIMAG(ECOMPL) *** Finish the wire loop 10 CONTINUE END +DECK,IPLB2Y. SUBROUTINE IPLB2Y(XPOS,YPOS,EX,EY,MX,IPLANE) *----------------------------------------------------------------------- * IPLB2Y - Routine calculating the MX contribution to the signal on * wire IPLANE due to a charge at (XPOS,YPOS) for F-B2X cells. * VARIABLES : See routine EFCA00 for most of the variables. * Z,ZZMIRR : X + I*Y , XXMIRR + I*YYMIRR ; I**2=-1 * ECOMPL : EX + I*EY ; I**2=-1 * (Last changed on 12/11/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,CONSTANTS. +SEQ,SIGNALMATRIX. REAL XPOS,YPOS,EX,EY,XX,YY,YYNEG,XXMIRR INTEGER I,MX,IPLANE COMPLEX ZZ,ECOMPL,ZZMIRR,ZZNEG,ZZNMIR *** Initialise EX and EY. EX=0 EY=0 *** Loop over all wires. DO 10 I=1,NWIRE XX=0.5*PI*(XPOS-X(I)-MX*SX)/SY YY=0.5*PI*(YPOS-Y(I))/SY YYNEG=0.5*PI*(YPOS+Y(I)-2*COPLAN(3))/SY ZZ=CMPLX(XX,YY) ZZNEG=CMPLX(XX,YYNEG) *** Calculate the field in case there are no equipotential planes. IF(ABS(XX).LE.20)THEN ECOMPL=ICONS*B2SIN(I)/(SIN(ICONS*ZZ)*SIN(ICONS*ZZNEG)) ELSE ECOMPL=0 ENDIF *** Take care of a plane at constant y. IF(YNPLAX)THEN XXMIRR=(0.5*PI/SY)*(XPOS+X(I)-2.0*COPLAX) ZZMIRR=CMPLX(XXMIRR,YY) ZZNMIR=CMPLX(XXMIRR,YYNEG) IF(ABS(XXMIRR).LE.20)ECOMPL=ECOMPL- - ICONS*B2SIN(I)/(SIN(ICONS*ZZMIRR)*SIN(ICONS*ZZNMIR)) ENDIF *** Calculate the electric field. EX=EX+QPLANE(IPLANE,I)*(0.5*PI/SY)*REAL(ECOMPL) EY=EY-QPLANE(IPLANE,I)*(0.5*PI/SY)*AIMAG(ECOMPL) *** Finish the wire loop. 10 CONTINUE END +DECK,IPLC30. SUBROUTINE IPLC30(XPOS,YPOS,EX,EY,IPLANE) *----------------------------------------------------------------------- * IPLC30 - Routine returning the weighting field field in a * configuration with 2 y and 2 x planes. This routine is * basically the same as EFCC30. * (Last changed on 9/11/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,CONSTANTS. +SEQ,SIGNALMATRIX. COMPLEX WSUM1,WSUM2,WSUM3,WSUM4,ZSIN,ZCOF,ZU,ZUNEW, - ZTERM1,ZTERM2,ZETA REAL XPOS,YPOS,EX,EY,CX,CY INTEGER I,IPLANE *** Initial values. WSUM1=0 WSUM2=0 WSUM3=0 WSUM4=0 *** Wire loop. DO 10 I=1,NWIRE * Compute the direct contribution. ZETA=ZMULT*CMPLX(XPOS-X(I),YPOS-Y(I)) IF(AIMAG(ZETA).GT.+15)THEN WSUM1=WSUM1-ICONS ELSEIF(AIMAG(ZETA).LT.-15)THEN WSUM1=WSUM1+ICONS ELSE ZSIN=SIN(ZETA) ZCOF=4*ZSIN**2-2 ZU=-P1-ZCOF*P2 ZUNEW=1-ZCOF*ZU-P2 ZTERM1=(ZUNEW+ZU)*ZSIN ZU=-3*P1-ZCOF*5*P2 ZUNEW=1-ZCOF*ZU-5*P2 ZTERM2=(ZUNEW-ZU)*COS(ZETA) WSUM1=WSUM1+ZTERM2/ZTERM1 ENDIF * Find the plane nearest to the wire. CX=COPLAX-SX*ANINT((COPLAX-X(I))/SX) * Mirror contribution from the x plane. ZETA=ZMULT*CMPLX(2*CX-XPOS-X(I),YPOS-Y(I)) IF(AIMAG(ZETA).GT.+15)THEN WSUM2=WSUM2-ICONS ELSEIF(AIMAG(ZETA).LT.-15)THEN WSUM2=WSUM2+ICONS ELSE ZSIN=SIN(ZETA) ZCOF=4*ZSIN**2-2 ZU=-P1-ZCOF*P2 ZUNEW=1-ZCOF*ZU-P2 ZTERM1=(ZUNEW+ZU)*ZSIN ZU=-3*P1-ZCOF*5*P2 ZUNEW=1-ZCOF*ZU-5*P2 ZTERM2=(ZUNEW-ZU)*COS(ZETA) WSUM2=WSUM2+ZTERM2/ZTERM1 ENDIF * Find the plane nearest to the wire. CY=COPLAY-SY*ANINT((COPLAY-Y(I))/SY) * Mirror contribution from the y plane. ZETA=ZMULT*CMPLX(XPOS-X(I),2*CY-YPOS-Y(I)) IF(AIMAG(ZETA).GT.+15)THEN WSUM3=WSUM3-ICONS ELSEIF(AIMAG(ZETA).LT.-15)THEN WSUM3=WSUM3+ICONS ELSE ZSIN=SIN(ZETA) ZCOF=4*ZSIN**2-2 ZU=-P1-ZCOF*P2 ZUNEW=1-ZCOF*ZU-P2 ZTERM1=(ZUNEW+ZU)*ZSIN ZU=-3*P1-ZCOF*5*P2 ZUNEW=1-ZCOF*ZU-5*P2 ZTERM2=(ZUNEW-ZU)*COS(ZETA) WSUM3=WSUM3+ZTERM2/ZTERM1 ENDIF * Mirror contribution from both the x and the y plane. ZETA=ZMULT*CMPLX(2*CX-XPOS-X(I),2*CY-YPOS-Y(I)) IF(AIMAG(ZETA).GT.+15)THEN WSUM4=WSUM4-ICONS ELSEIF(AIMAG(ZETA).LT.-15)THEN WSUM4=WSUM4+ICONS ELSE ZSIN=SIN(ZETA) ZCOF=4*ZSIN**2-2 ZU=-P1-ZCOF*P2 ZUNEW=1-ZCOF*ZU-P2 ZTERM1=(ZUNEW+ZU)*ZSIN ZU=-3*P1-ZCOF*5*P2 ZUNEW=1-ZCOF*ZU-5*P2 ZTERM2=(ZUNEW-ZU)*COS(ZETA) WSUM4=WSUM4+ZTERM2/ZTERM1 ENDIF 10 CONTINUE *** Convert the two contributions to a real field. EX=+QPLANE(IPLANE,I)*REAL(ZMULT*(WSUM1+WSUM2-WSUM3-WSUM4)) EY=-QPLANE(IPLANE,I)*AIMAG(ZMULT*(WSUM1-WSUM2+WSUM3-WSUM4)) END +DECK,IPLD10. SUBROUTINE IPLD10(XPOS,YPOS,EX,EY,IPLANE) *----------------------------------------------------------------------- * IPLD10 - Subroutine computing the signal on wire IPLANE due to a * charge at (XPOS,YPOS). This is effectively routine EFCD10. * VARIABLES : EX, EY : Electric field. * (XPOS,YPOS): The position where the field is calculated. * ZI, ZPOS : Shorthand complex notations. * (Last changed on 9/11/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,SIGNALMATRIX. REAL XPOS,YPOS,EX,EY INTEGER IPLANE,I COMPLEX ZI,ZPOS *** Initialise the electric field. EX=0 EY=0 * Set the complex position coordinates. ZPOS=CMPLX(XPOS,YPOS) *** Loop over all wires. DO 10 I=1,NWIRE * Set the complex version of the wire-coordinate for simplicity. ZI=CMPLX(X(I),Y(I)) * Compute the contribution to the electric field, always. EX=EX+QPLANE(IPLANE,I)*REAL(1/CONJG(ZPOS-ZI)+ - ZI/(COTUBE**2-CONJG(ZPOS)*ZI)) EY=EY+QPLANE(IPLANE,I)*AIMAG(1/CONJG(ZPOS-ZI)+ - ZI/(COTUBE**2-CONJG(ZPOS)*ZI)) *** Finish the loop over the wires. 10 CONTINUE END +DECK,IPLD30. SUBROUTINE IPLD30(XPOS,YPOS,EX,EY,IPLANE) *----------------------------------------------------------------------- * IPLD30 - Subroutine computing the weighting field for a polygonal * cells without periodicities, type D3. * VARIABLES : EX, EY : Electric field * (XPOS,YPOS): The position where the field is calculated. * ZI, ZPOS : Shorthand complex notations. * (Last changed on 9/11/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,SIGNALMATRIX. REAL EX,EY,XPOS,YPOS INTEGER I,IPLANE COMPLEX WPOS,WDPOS *** Initialise weighting field. EX=0.0 EY=0.0 * Get the mapping of the position. CALL EFCMAP(CMPLX(XPOS,YPOS)/COTUBE,WPOS,WDPOS) *** Loop over all wires. DO 10 I=1,NWIRE * Compute the contribution to the electric field. EX=EX+QPLANE(IPLANE,I)*REAL(WDPOS*(1-ABS(WMAP(I))**2)/ - ((WPOS-WMAP(I))*(1-CONJG(WMAP(I))*WPOS)))/COTUBE EY=EY-QPLANE(IPLANE,I)*AIMAG(WDPOS*(1-ABS(WMAP(I))**2)/ - ((WPOS-WMAP(I))*(1-CONJG(WMAP(I))*WPOS)))/COTUBE *** Finish the loop over the wires. 10 CONTINUE END +DECK,IONEST. SUBROUTINE IONEST(XPOS,YPOS,ZPOS,EX,EY,EZ,IP,IS,IT) *----------------------------------------------------------------------- * IONEST - Weighting field for strips. * (Last changed on 6/12/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,CONSTANTS. REAL XPOS,YPOS,ZPOS,EX,EY,EZ,GAP,WIDTH,S,C,E1,E2,XW,YW,EWX,EWY INTEGER IP,IS,IT *** Initialise weighting field. EX=0.0 EY=0.0 EZ=0.0 *** Transform to normalised coordinates. IF(IP.EQ.1)THEN IF(IT.EQ.1)THEN XW=-YPOS+(PLSTR1(IP,IS,1)+PLSTR1(IP,IS,2))/2 YW=XPOS-COPLAN(IP) ELSE XW=-ZPOS+(PLSTR2(IP,IS,1)+PLSTR2(IP,IS,2))/2 YW=XPOS-COPLAN(IP) ENDIF ELSEIF(IP.EQ.2)THEN IF(IT.EQ.1)THEN XW=YPOS-(PLSTR1(IP,IS,1)+PLSTR1(IP,IS,2))/2 YW=COPLAN(IP)-XPOS ELSE XW=ZPOS-(PLSTR2(IP,IS,1)+PLSTR2(IP,IS,2))/2 YW=COPLAN(IP)-XPOS ENDIF ELSEIF(IP.EQ.3)THEN IF(IT.EQ.1)THEN XW=XPOS-(PLSTR1(IP,IS,1)+PLSTR1(IP,IS,2))/2 YW=YPOS-COPLAN(IP) ELSE XW=ZPOS-(PLSTR2(IP,IS,1)+PLSTR2(IP,IS,2))/2 YW=YPOS-COPLAN(IP) ENDIF ELSEIF(IP.EQ.4)THEN IF(IT.EQ.1)THEN XW=-XPOS+(PLSTR1(IP,IS,1)+PLSTR1(IP,IS,2))/2 YW=COPLAN(IP)-YPOS ELSE XW=-ZPOS+(PLSTR2(IP,IS,1)+PLSTR2(IP,IS,2))/2 YW=COPLAN(IP)-YPOS ENDIF ELSE RETURN ENDIF *** Store the gap and strip width. IF(IT.EQ.1)THEN WIDTH=ABS(PLSTR1(IP,IS,2)-PLSTR1(IP,IS,1)) GAP=PLSTR1(IP,IS,3) ELSE WIDTH=ABS(PLSTR2(IP,IS,2)-PLSTR2(IP,IS,1)) GAP=PLSTR2(IP,IS,3) ENDIF *** Make sure we're in the fiducial part of the weighting map. IF(YW.LE.0.OR.YW.GT.GAP)THEN EX=0 EY=0 EZ=0 RETURN ENDIF *** Evaluate the weighting field, define shorthand notations. S=SIN(PI*YW/GAP) C=COS(PI*YW/GAP) E1=EXP( PI*(WIDTH/2-XW)/GAP) E2=EXP(-PI*(WIDTH/2+XW)/GAP) * Check for singularities. IF(C.EQ.E1.OR.C.EQ.E2)THEN EWX=0 EWY=0 * Evaluate the field. ELSE EWX=E1*S/(GAP*(C-E1)**2*(1+S**2/(C-E1)**2))- - E2*S/(GAP*(C-E2)**2*(1+S**2/(C-E2)**2)) EWY=((C/(C-E2)+S**2/(C-E2)**2)/(1+S**2/(C-E2)**2)- - (C/(C-E1)+S**2/(C-E1)**2)/(1+S**2/(C-E1)**2))/GAP ENDIF *** Rotate the field back to the original coordinates. IF(IP.EQ.1)THEN IF(IT.EQ.1)THEN EX=EWY EY=-EWX EZ=0 ELSE EX=EWY EY=0 EZ=-EWX ENDIF ELSEIF(IP.EQ.2)THEN IF(IT.EQ.1)THEN EX=-EWY EY=EWX EZ=0 ELSE EX=-EWY EY=0 EZ=EWX ENDIF ELSEIF(IP.EQ.3)THEN IF(IT.EQ.1)THEN EX=EWX EY=EWY EZ=0 ELSE EX=0 EY=EWY EZ=EWX ENDIF ELSEIF(IP.EQ.4)THEN IF(IT.EQ.1)THEN EX=-EWX EY=-EWY EZ=0 ELSE EX=0 EY=-EWY EZ=-EWX ENDIF ELSE EX=0 EY=0 EZ=0 ENDIF END +DECK,IONFMP. SUBROUTINE IONFMP(XIN,YIN,ZIN,EX,EY,EZ,ISW) *----------------------------------------------------------------------- * IONFMP - Interpolates the weighting field map at (XPOS,YPOS,ZPOS). * (Last changed on 4/ 9/99.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,FIELDMAP. +SEQ,CELLDATA. +SEQ,CONSTANTS. REAL XIN,YIN,ZIN,XPOS,YPOS,ZPOS,EX,EY,EZ,XNEW,YNEW,ZNEW, - T1,T2,T3,T4,AUXR,AUXPHI,AROT,XAUX,YAUX,ER,EAXIS,RCOOR,ZCOOR INTEGER IMAP,NX,NY,NZ,ISW LOGICAL MIRRX,MIRRY,MIRRZ *** Initial values. EX=0 EY=0 EZ=0 XPOS=XIN YPOS=YIN ZPOS=ZIN *** First see whether we at all have a grid. IF(.NOT.MAPFLG(1))RETURN *** If chamber is periodic, reduce to the cell volume. MIRRX=.FALSE. IF(PERX)THEN XPOS=XMMIN+MOD(XPOS-XMMIN,XMMAX-XMMIN) IF(XPOS.LT.XMMIN)XPOS=XPOS+(XMMAX-XMMIN) ELSEIF(PERMX)THEN XNEW=XMMIN+MOD(XPOS-XMMIN,XMMAX-XMMIN) IF(XNEW.LT.XMMIN)XNEW=XNEW+(XMMAX-XMMIN) NX=NINT((XNEW-XPOS)/(XMMAX-XMMIN)) IF(NX.NE.2*(NX/2))THEN XNEW=XMMIN+XMMAX-XNEW MIRRX=.TRUE. ENDIF XPOS=XNEW ENDIF IF(PERAX.AND.(ZPOS.NE.0.OR.YPOS.NE.0))THEN AUXR=SQRT(ZPOS**2+YPOS**2) AUXPHI=ATAN2(ZPOS,YPOS) AROT=(XAMAX-XAMIN)*ANINT((AUXPHI-0.5*(XAMIN+XAMAX))/ - (XAMAX-XAMIN)) IF(AUXPHI-AROT.LT.XAMIN)AROT=AROT-(XAMAX-XAMIN) IF(AUXPHI-AROT.GT.XAMAX)AROT=AROT+(XAMAX-XAMIN) AUXPHI=AUXPHI-AROT YPOS=AUXR*COS(AUXPHI) ZPOS=AUXR*SIN(AUXPHI) ENDIF MIRRY=.FALSE. IF(PERY)THEN YPOS=YMMIN+MOD(YPOS-YMMIN,YMMAX-YMMIN) IF(YPOS.LT.YMMIN)YPOS=YPOS+(YMMAX-YMMIN) ELSEIF(PERMY)THEN YNEW=YMMIN+MOD(YPOS-YMMIN,YMMAX-YMMIN) IF(YNEW.LT.YMMIN)YNEW=YNEW+(YMMAX-YMMIN) NY=NINT((YNEW-YPOS)/(YMMAX-YMMIN)) IF(NY.NE.2*(NY/2))THEN YNEW=YMMIN+YMMAX-YNEW MIRRY=.TRUE. ENDIF YPOS=YNEW ENDIF IF(PERAY.AND.(XPOS.NE.0.OR.ZPOS.NE.0))THEN AUXR=SQRT(XPOS**2+ZPOS**2) AUXPHI=ATAN2(XPOS,ZPOS) AROT=(YAMAX-YAMIN)*ANINT((AUXPHI-0.5*(YAMIN+YAMAX))/ - (YAMAX-YAMIN)) IF(AUXPHI-AROT.LT.YAMIN)AROT=AROT-(YAMAX-YAMIN) IF(AUXPHI-AROT.GT.YAMAX)AROT=AROT+(YAMAX-YAMIN) AUXPHI=AUXPHI-AROT ZPOS=AUXR*COS(AUXPHI) XPOS=AUXR*SIN(AUXPHI) ENDIF MIRRZ=.FALSE. IF(PERZ)THEN ZPOS=ZMMIN+MOD(ZPOS-ZMMIN,ZMMAX-ZMMIN) IF(ZPOS.LT.ZMMIN)ZPOS=ZPOS+(ZMMAX-ZMMIN) ELSEIF(PERMZ)THEN ZNEW=ZMMIN+MOD(ZPOS-ZMMIN,ZMMAX-ZMMIN) IF(ZNEW.LT.ZMMIN)ZNEW=ZNEW+(ZMMAX-ZMMIN) NZ=NINT((ZNEW-ZPOS)/(ZMMAX-ZMMIN)) IF(NZ.NE.2*(NZ/2))THEN ZNEW=ZMMIN+ZMMAX-ZNEW MIRRZ=.TRUE. ENDIF ZPOS=ZNEW ENDIF IF(PERAZ.AND.(YPOS.NE.0.OR.XPOS.NE.0))THEN AUXR=SQRT(YPOS**2+XPOS**2) AUXPHI=ATAN2(YPOS,XPOS) AROT=(ZAMAX-ZAMIN)*ANINT((AUXPHI-0.5*(ZAMIN+ZAMAX))/ - (ZAMAX-ZAMIN)) IF(AUXPHI-AROT.LT.ZAMIN)AROT=AROT-(ZAMAX-ZAMIN) IF(AUXPHI-AROT.GT.ZAMAX)AROT=AROT+(ZAMAX-ZAMIN) AUXPHI=AUXPHI-AROT XPOS=AUXR*COS(AUXPHI) YPOS=AUXR*SIN(AUXPHI) ENDIF *** If we have a rotationally symmetric field map, store coordinates. IF(PERRX)THEN RCOOR=SQRT(YPOS**2+ZPOS**2) ZCOOR=XPOS ELSEIF(PERRY)THEN RCOOR=SQRT(XPOS**2+ZPOS**2) ZCOOR=YPOS ELSEIF(PERRZ)THEN RCOOR=SQRT(XPOS**2+YPOS**2) ZCOOR=ZPOS ENDIF IF(PERRX.OR.PERRY.OR.PERRZ)THEN XPOS=RCOOR YPOS=ZCOOR ZPOS=0 ENDIF *** Locate the point. CALL MAPIND(XPOS,YPOS,ZPOS,T1,T2,T3,T4,IMAP) IF(IMAP.LE.0.OR.IMAP.GT.NMAP)RETURN *** Next perform a linear 3-dimensional interpolation. IF((MAPTYP.EQ.11.OR.MAPTYP.EQ.12.OR.MAPTYP.EQ.13).AND. - MAPORD.EQ.1)THEN IF(MAPFLG(10+3*ISW-2))EX= - EWXMAP(IMAP,1,ISW)*T1+EWXMAP(IMAP,2,ISW)*T2+ - EWXMAP(IMAP,3,ISW)*T3+EWXMAP(IMAP,4,ISW)*T4 IF(MAPFLG(11+3*ISW-2))EY= - EWYMAP(IMAP,1,ISW)*T1+EWYMAP(IMAP,2,ISW)*T2+ - EWYMAP(IMAP,3,ISW)*T3+EWYMAP(IMAP,4,ISW)*T4 IF(MAPFLG(12+3*ISW-2))EZ= - EWZMAP(IMAP,1,ISW)*T1+EWZMAP(IMAP,2,ISW)*T2+ - EWZMAP(IMAP,3,ISW)*T3+EWZMAP(IMAP,4,ISW)*T4 * Or a 3-dimensional quadratic interpolation. ELSEIF(MAPTYP.EQ.12.AND.MAPORD.EQ.2)THEN IF(MAPFLG(10+3*ISW-2))EX= - EWXMAP(IMAP,1,ISW)*T1*(2*T1-1)+ - EWXMAP(IMAP,2,ISW)*T2*(2*T2-1)+ - EWXMAP(IMAP,3,ISW)*T3*(2*T3-1)+ - EWXMAP(IMAP,4,ISW)*T4*(2*T4-1)+ - 4*EWXMAP(IMAP,5,ISW)*T1*T2+4*EWXMAP(IMAP,6,ISW)*T1*T3+ - 4*EWXMAP(IMAP,7,ISW)*T1*T4+4*EWXMAP(IMAP,8,ISW)*T2*T3+ - 4*EWXMAP(IMAP,9,ISW)*T2*T4+4*EWXMAP(IMAP,10,ISW)*T3*T4 IF(MAPFLG(11+3*ISW-2))EY= - EWYMAP(IMAP,1,ISW)*T1*(2*T1-1)+ - EWYMAP(IMAP,2,ISW)*T2*(2*T2-1)+ - EWYMAP(IMAP,3,ISW)*T3*(2*T3-1)+ - EWYMAP(IMAP,4,ISW)*T4*(2*T4-1)+ - 4*EWYMAP(IMAP,5,ISW)*T1*T2+4*EWYMAP(IMAP,6,ISW)*T1*T3+ - 4*EWYMAP(IMAP,7,ISW)*T1*T4+4*EWYMAP(IMAP,8,ISW)*T2*T3+ - 4*EWYMAP(IMAP,9,ISW)*T2*T4+4*EWYMAP(IMAP,10,ISW)*T3*T4 IF(MAPFLG(12+3*ISW-2))EZ= - EWZMAP(IMAP,1,ISW)*T1*(2*T1-1)+ - EWZMAP(IMAP,2,ISW)*T2*(2*T2-1)+ - EWZMAP(IMAP,3,ISW)*T3*(2*T3-1)+ - EWZMAP(IMAP,4,ISW)*T4*(2*T4-1)+ - 4*EWZMAP(IMAP,5,ISW)*T1*T2+4*EWZMAP(IMAP,6,ISW)*T1*T3+ - 4*EWZMAP(IMAP,7,ISW)*T1*T4+4*EWZMAP(IMAP,8,ISW)*T2*T3+ - 4*EWZMAP(IMAP,9,ISW)*T2*T4+4*EWZMAP(IMAP,10,ISW)*T3*T4 *** Or a linear 2-dimensional interpolation. ELSEIF((MAPTYP.EQ.1.OR.MAPTYP.EQ.2.OR.MAPTYP.EQ.3).AND. - MAPORD.EQ.1)THEN IF(MAPFLG(10+3*ISW-2))EX=EWXMAP(IMAP,1,ISW)*T1+ - EWXMAP(IMAP,2,ISW)*T2+EWXMAP(IMAP,3,ISW)*T3 IF(MAPFLG(11+3*ISW-2))EY=EWYMAP(IMAP,1,ISW)*T1+ - EWYMAP(IMAP,2,ISW)*T2+EWYMAP(IMAP,3,ISW)*T3 IF(MAPFLG(12+3*ISW-2))EZ=EWZMAP(IMAP,1,ISW)*T1+ - EWZMAP(IMAP,2,ISW)*T2+EWZMAP(IMAP,3,ISW)*T3 * Or a 2-dimensional quadratic interpolation. ELSEIF(MAPTYP.EQ.2.AND.MAPORD.EQ.2)THEN IF(MAPFLG(10+3*ISW-2))EX= - EWXMAP(IMAP,1,ISW)*T1*(2*T1-1)+ - EWXMAP(IMAP,2,ISW)*T2*(2*T2-1)+ - EWXMAP(IMAP,3,ISW)*T3*(2*T3-1)+ - 4*EWXMAP(IMAP,4,ISW)*T1*T2+ - 4*EWXMAP(IMAP,5,ISW)*T1*T3+ - 4*EWXMAP(IMAP,6,ISW)*T2*T3 IF(MAPFLG(11+3*ISW-2))EY= - EWYMAP(IMAP,1,ISW)*T1*(2*T1-1)+ - EWYMAP(IMAP,2,ISW)*T2*(2*T2-1)+ - EWYMAP(IMAP,3,ISW)*T3*(2*T3-1)+ - 4*EWYMAP(IMAP,4,ISW)*T1*T2+ - 4*EWYMAP(IMAP,5,ISW)*T1*T3+ - 4*EWYMAP(IMAP,6,ISW)*T2*T3 IF(MAPFLG(12+3*ISW-2))EZ= - EWZMAP(IMAP,1,ISW)*T1*(2*T1-1)+ - EWZMAP(IMAP,2,ISW)*T2*(2*T2-1)+ - EWZMAP(IMAP,3,ISW)*T3*(2*T3-1)+ - 4*EWZMAP(IMAP,4,ISW)*T1*T2+ - 4*EWZMAP(IMAP,5,ISW)*T1*T3+ - 4*EWZMAP(IMAP,6,ISW)*T2*T3 * Other elements. ELSE PRINT *,' !!!!!! IONFMP WARNING : Unknown element ',MAPTYP RETURN ENDIF *** Apply mirror imaging. IF(MIRRX)EX=-EX IF(MIRRY)EY=-EY IF(MIRRZ)EZ=-EZ *** Rotate the field. IF(PERAX)THEN CALL CFMCTP(EY,EZ,XAUX,YAUX,1) YAUX=YAUX+AROT*180/PI CALL CFMPTC(XAUX,YAUX,EY,EZ,1) ENDIF IF(PERAY)THEN CALL CFMCTP(EZ,EX,XAUX,YAUX,1) YAUX=YAUX+AROT*180/PI CALL CFMPTC(XAUX,YAUX,EZ,EX,1) ENDIF IF(PERAZ)THEN CALL CFMCTP(EX,EY,XAUX,YAUX,1) YAUX=YAUX+AROT*180/PI CALL CFMPTC(XAUX,YAUX,EX,EY,1) ENDIF *** And take care of symmetry. ER=EX EAXIS=EZ IF(PERRX)THEN IF(RCOOR.LE.0)THEN EX=EAXIS EY=0 EZ=0 ELSE EX=EAXIS EY=ER*YIN/RCOOR EZ=ER*ZIN/RCOOR ENDIF ENDIF IF(PERRY)THEN IF(RCOOR.LE.0)THEN EX=0 EY=EAXIS EZ=0 ELSE EX=ER*XIN/RCOOR EY=EAXIS EZ=ER*ZIN/RCOOR ENDIF ENDIF IF(PERRZ)THEN IF(RCOOR.LE.0)THEN EX=0 EY=0 EZ=EAXIS ELSE EX=ER*XIN/RCOOR EY=ER*YIN/RCOOR EZ=EAXIS ENDIF ENDIF END +DECK,SIGPLT. SUBROUTINE SIGPLT *----------------------------------------------------------------------- * SIGPLT - Routine plotting the signal induced on the sense wires * VARIABLES : * (Last changed on 21/ 1/01.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,GASDATA. +SEQ,SIGNALDATA. +SEQ,PARAMETERS. +SEQ,PRINTPLOT. +SEQ,DRIFTLINE. CHARACTER*50 AUX REAL TPLMIN,TPLMAX,TMIN,TMAX,SPLMIN,SPLMAX,SIGMIN,SIGMAX, - TMINR,TMAXR,SMINR,SMAXR INTEGER INPCMP,INPTYP,I,J,INEXT,ISW,JSW,JW,NC,NPLOT,NWORD, - IFAIL1,IFAIL2,NFOUND,ITMIN,ITMAX LOGICAL FLAT,PLOT(MXSW),TAUTO,SAUTO,LPLCR,LPLDIR,FLAG(MXWORD) EXTERNAL INPCMP,INPTYP *** Identify the routine. IF(LIDENT)PRINT *,' /// ROUTINE SIGPLT ///' *** Initialise the time window. TMIN=TIMSIG(1) TMAX=TIMSIG(NTIME) TAUTO=.FALSE. * Preset the signal range. SAUTO=.TRUE. * The wire plot flags (sense wires with non-flat signal). DO 10 ISW=1,MXSW PLOT(ISW)=.FALSE. IF(ISW.LE.NSW)THEN DO 20 J=1,NTIME IF(SIGNAL(J,ISW,1).NE.0.OR. - (LCROSS.AND.SIGNAL(J,ISW,2).NE.0))PLOT(ISW)=.TRUE. 20 CONTINUE ENDIF 10 CONTINUE * Plotting options. LPLCR=LCROSS LPLDIR=.TRUE. *** Read the command line arguments. CALL INPNUM(NWORD) * Mark keyword. DO 25 I=1,MXWORD IF(I.GT.NWORD)THEN FLAG(I)=.TRUE. ELSEIF(INPCMP(I,'TIME-#WINDOW')+INPCMP(I,'WIN#DOW')+ - INPCMP(I,'RAN#GE')+INPCMP(I,'SC#ALE')+ - INPCMP(I+1,'AUTO#MATIC')+INPCMP(I,'WIRE#S')+ - INPCMP(I,'CR#OSS-#INDUCED-#SIGNALS')+ - INPCMP(I,'NOCR#OSS-#INDUCED-#SIGNALS')+ - INPCMP(I,'DIR#ECT-#SIGNALS')+INPCMP(I,'NODIR#ECT-#SIGNALS')+ - INPCMP(I,'ALL')+INPCMP(I,'ACT#IVE').NE.0)THEN FLAG(I)=.TRUE. ELSE FLAG(I)=.FALSE. ENDIF 25 CONTINUE * Loop over the words. INEXT=2 DO 30 I=2,NWORD IF(I.LT.INEXT)GOTO 30 ** Time window. IF(INPCMP(I,'TIME-#WINDOW')+INPCMP(I,'WIN#DOW').NE.0)THEN * Automatic window. IF(INPCMP(I+1,'AUTO#MATIC').NE.0)THEN TAUTO=.TRUE. INEXT=I+2 * No arguments. ELSEIF(NWORD.LT.I+2.OR.FLAG(I+1).OR.FLAG(I+2))THEN CALL INPMSG(I,'Arguments missing') * Arguments, but not integer, real or *. ELSEIF((INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2.AND. - INPTYP(I+1).NE.4).OR.(INPTYP(I+2).NE.1.AND. - INPTYP(I+2).NE.2.AND.INPTYP(I+2).NE.4))THEN CALL INPMSG(I,'Arguments of wrong type') * Two arguments: establish the range. ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPCHK(I+2,2,IFAIL2) CALL INPRDR(I+1,TMINR,TMIN) CALL INPRDR(I+2,TMAXR,TMAX) IF(TMINR.EQ.TMAXR.OR. - IFAIL1.NE.0.OR.IFAIL2.NE.0.OR. - MIN(TMINR,TMAXR).GT.TIMSIG(NTIME).OR. - MAX(TMINR,TMAXR).LT.TIMSIG(1))THEN CALL INPMSG(I+1,'Invalid range') CALL INPMSG(I+2,'Invalid range') ELSE TMIN=MIN(TMINR,TMAXR) TMAX=MAX(TMINR,TMAXR) TAUTO=.FALSE. ENDIF INEXT=I+3 ENDIF ** Signal range. ELSEIF(INPCMP(I,'RAN#GE')+INPCMP(I,'SC#ALE').NE.0)THEN * Automatic window. IF(INPCMP(I+1,'AUTO#MATIC').NE.0)THEN SAUTO=.TRUE. INEXT=I+2 * No arguments. ELSEIF(NWORD.LT.I+2.OR.FLAG(I+1).OR.FLAG(I+2))THEN CALL INPMSG(I,'Arguments missing') * Arguments, but not integer, real or *. ELSEIF((INPTYP(I+1).NE.1.AND.INPTYP(I+1).NE.2).OR. - (INPTYP(I+2).NE.1.AND.INPTYP(I+2).NE.2))THEN CALL INPMSG(I,'Arguments of wrong type') * Two arguments: establish the range. ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPCHK(I+2,2,IFAIL2) CALL INPRDR(I+1,SMINR,0.0) CALL INPRDR(I+2,SMAXR,0.0) IF(SMINR.EQ.SMAXR.OR. - IFAIL1.NE.0.OR.IFAIL2.NE.0)THEN CALL INPMSG(I+1,'Invalid range') CALL INPMSG(I+2,'Invalid range') ELSE SPLMIN=MIN(SMINR,SMAXR) SPLMAX=MAX(SMINR,SMAXR) SAUTO=.FALSE. ENDIF INEXT=I+3 ENDIF ** Direct / Cross-induced / both. ELSEIF(INPCMP(I,'CR#OSS-#INDUCED-#SIGNALS').NE.0)THEN IF(.NOT.LCROSS)THEN CALL INPMSG(I,'Option CROSS-INDUCED is off') ELSE LPLCR=.TRUE. ENDIF ELSEIF(INPCMP(I,'NOCR#OSS-#INDUCED-#SIGNALS').NE.0)THEN LPLCR=.FALSE. ELSEIF(INPCMP(I,'DIR#ECT-#SIGNALS').NE.0)THEN LPLDIR=.TRUE. ELSEIF(INPCMP(I,'NODIR#ECT-#SIGNALS').NE.0)THEN LPLDIR=.FALSE. ** Wire selections. ELSEIF(INPCMP(I,'WIRE#S').NE.0)THEN * All wires are selected. IF(INPCMP(I+1,'ALL').NE.0)THEN DO 40 ISW=1,NSW PLOT(ISW)=.TRUE. 40 CONTINUE INEXT=I+2 * All wires which have a signal. ELSEIF(INPCMP(I+1,'ACT#IVE').NE.0)THEN DO 50 ISW=1,NSW DO 60 J=1,NTIME IF(SIGNAL(J,ISW,1).NE.0.OR. - (LCROSS.AND.SIGNAL(J,ISW,2).NE.0))PLOT(ISW)=.TRUE. 60 CONTINUE 50 CONTINUE INEXT=I+2 ELSE DO 70 J=I+1,NWORD * Leave when hitting a keyword. IF(FLAG(J))THEN INEXT=J GOTO 90 * Selection by wire number. ELSEIF(INPTYP(J).EQ.1)THEN CALL INPCHK(J,1,IFAIL1) CALL INPRDI(J,JW,0) IF(JW.GE.1.AND.JW.LE.NWIRE)THEN JSW=INDSW(JW) IF(JSW.NE.0)PLOT(JSW)=.TRUE. ELSE CALL INPMSG(J,'Not a valid wire number') ENDIF * Selection by wire code. ELSEIF(INPTYP(J).EQ.0)THEN CALL INPSTR(J,J,AUX,NC) NFOUND=0 DO 80 JW=1,NWIRE IF(WIRTYP(JW).EQ.AUX(1:1))THEN JSW=INDSW(JW) IF(JSW.NE.0)THEN PLOT(JSW)=.TRUE. NFOUND=NFOUND+1 ENDIF ENDIF 80 CONTINUE IF(NFOUND.EQ.0)CALL INPMSG(J, - 'Not a known sense-wire code.') ELSE INEXT=J GOTO 90 ENDIF 70 CONTINUE INEXT=NWORD+1 90 CONTINUE ENDIF * Other keywords are not known. ELSEIF(FLAG(I))THEN CALL INPMSG(I,'Valid keyword out of context') ELSE CALL INPMSG(I,'Not a known keyword') ENDIF 30 CONTINUE *** Print error messages. CALL INPERR *** Make sure at least a bit of plotting is requested. IF(.NOT.(LPLCR.OR.LPLDIR))THEN PRINT *,' !!!!!! SIGPLT WARNING : No plot output has'// - ' been requested ; no plot made.' RETURN ENDIF *** Loop over all (groups of) sense wires, count the number of plots. NPLOT=0 DO 100 ISW=1,NSW IF(.NOT.PLOT(ISW))GOTO 100 * Find a proper time range. IF(TAUTO)THEN DO 120 J=1,NTIME IF((LPLDIR.AND.SIGNAL(J,ISW,1).NE.0).OR. - (LCROSS.AND.LPLCR.AND.SIGNAL(J,ISW,2).NE.0))THEN ITMIN=J TMIN=TIMSIG(J) GOTO 130 ENDIF 120 CONTINUE PRINT *,' !!!!!! SIGPLT WARNING : Start time of signal'// - ' not found ; program bug, please report.' GOTO 100 130 CONTINUE DO 140 J=NTIME,1,-1 IF((LPLDIR.AND.SIGNAL(J,ISW,1).NE.0).OR. - (LCROSS.AND.LPLCR.AND.SIGNAL(J,ISW,2).NE.0))THEN ITMAX=J TMAX=TIMSIG(J) GOTO 150 ENDIF 140 CONTINUE PRINT *,' !!!!!! SIGPLT WARNING : End time of signal'// - ' not found ; program bug, please report.' GOTO 100 150 CONTINUE TPLMIN=TMIN-0.1*(TMAX-TMIN) TPLMAX=TMAX+0.1*(TMAX-TMIN) ELSE TPLMIN=TMIN TPLMAX=TMAX ITMIN=1 ITMAX=NTIME DO 160 J=1,NTIME IF(TIMSIG(J).LT.TMIN)ITMIN=J IF(TIMSIG(NTIME-J+1).GT.TMAX)ITMAX=NTIME-J+1 160 CONTINUE ENDIF * Make sure the signal is not flat and find default signal range. FLAT=.TRUE. IF(LPLDIR)THEN SIGMIN=SIGNAL(ITMIN,ISW,1) SIGMAX=SIGNAL(ITMIN,ISW,1) ELSE SIGMIN=SIGNAL(ITMIN,ISW,2) SIGMAX=SIGNAL(ITMIN,ISW,2) ENDIF DO 110 J=ITMIN,ITMAX IF((LPLDIR.AND.SIGNAL(J,ISW,1).NE.0).OR. - (LCROSS.AND.LPLCR.AND.SIGNAL(J,ISW,2).NE.0))FLAT=.FALSE. IF(LPLDIR)SIGMIN=MIN(SIGMIN,SIGNAL(J,ISW,1)) IF(LPLCR.AND.LCROSS)SIGMIN=MIN(SIGMIN,SIGNAL(J,ISW,2)) IF(LPLDIR)SIGMAX=MAX(SIGMAX,SIGNAL(J,ISW,1)) IF(LPLCR.AND.LCROSS)SIGMAX=MAX(SIGMAX,SIGNAL(J,ISW,2)) 110 CONTINUE * Print a warning if the signal is flat. IF(FLAT)THEN PRINT *,' !!!!!! SIGPLT WARNING : The signal on group ', - ISW,' is zero within time window; not plotted.' GOTO 100 ENDIF * Set the signal plot range. IF(SAUTO)THEN SPLMIN=SIGMIN-0.1*(SIGMAX-SIGMIN) SPLMAX=SIGMAX+0.1*(SIGMAX-SIGMIN) ENDIF * Open a frame for the plot. CALL OUTFMT(REAL(ISW),2,AUX,NC,'LEFT') CALL GRCART(TPLMIN,SPLMIN,TPLMAX,SPLMAX, - 'Time [microsec]','Current [microamp]', - 'Induced currents on group '//AUX(1:NC)) IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) IF(GASID.NE.' ')CALL GRCOMM(2,'Gas: '//GASID) IF(PARTID.NE.'Unknown') - CALL GRCOMM(3,'Particle: '//PARTID) AUX(1:10)='Ion tail: ' NC=10 IF(LITAIL)THEN AUX(NC+1:NC+9)='present, ' NC=NC+9 ELSEIF(LRTAIL)THEN AUX(NC+1:NC+13)='not sampled, ' NC=NC+13 ELSEIF(LDTAIL)THEN AUX(NC+1:NC+10)='detailed, ' NC=NC+10 ELSE AUX(NC+1:NC+8)='absent, ' NC=NC+8 ENDIF AUX(NC+1:NC+16)='electron pulse: ' NC=NC+16 IF(LEPULS)THEN AUX(NC+1:NC+7)='present' NC=NC+7 ELSE AUX(NC+1:NC+6)='absent' NC=NC+6 ENDIF CALL GRCOMM(4,AUX(1:NC)) * Plot the direct signal of the wire. IF(LPLDIR)THEN CALL GRATTS('FUNCTION-1','POLYLINE') CALL GRLINE(ITMAX-ITMIN+1,TIMSIG(ITMIN),SIGNAL(ITMIN,ISW,1)) ENDIF * Plot the cross induced signal for the wire. IF(LCROSS.AND.LPLCR)THEN CALL GRATTS('FUNCTION-2','POLYLINE') CALL GRLINE(ITMAX-ITMIN+1,TIMSIG(ITMIN),SIGNAL(ITMIN,ISW,2)) ENDIF * Remember that we plotted a signal. NPLOT=NPLOT+1 * Close the plot. CALL GRNEXT * Log the plot, CALL OUTFMT(REAL(ISW),2,AUX,NC,'LEFT') CALL GRALOG('Signals on group '//AUX(1:NC)//'.') 100 CONTINUE *** Print a warning if no plot was made. IF(NPLOT.EQ.0)PRINT *,' !!!!!! SIGPLT WARNING : No signal'// - ' eligible for plotting found.' *** Register the amount of CPU time used. CALL TIMLOG('Plotting the signals: ') END +DECK,SIGCNV. SUBROUTINE SIGCNV(IFAIL) *----------------------------------------------------------------------- * SIGCNV - Convolutes the signals with a transfer function. * VARIABLES : * (Last changed on 1/ 2/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,SIGNALDATA. +SEQ,CELLDATA. +SEQ,GLOBALS. +SEQ,PRINTPLOT. CHARACTER*(MXCHAR) FCNCNV,FCNADD CHARACTER*10 VAR(MXVAR),NAME LOGICAL USE(MXVAR) INTEGER MODVAR(MXVAR),MODRES(1),IENTRY,IENADD,NCCNV,NCADD,IORD, - IORDR,I,J,K,IFAIL,IRTRAN,ISTRAN,IRTIME,ISTIME,MATSLT,NCNAME, - NERR,NRES,ISW,IFAIL1,IFAIL2,INEXT,NWORD,INPCMP REAL RES(1),AUX(MXLIST),CNVTAB(1-MXLIST:MXLIST-1), - VAL(MXVAR),CNVMIN,CNVMAX,CNVMIR,CNVMAR EXTERNAL MATSLT,INPCMP +SELF,IF=SAVE. SAVE FCNCNV,NCCNV,CNVMIN,CNVMAX,IENTRY,IRTRAN,IRTIME,IORD +SELF. DATA FCNCNV(1:1)/' '/ DATA NCCNV /1/, CNVMIN /0.0/, CNVMAX /1.0E10/, IENTRY /0/, - IRTRAN /0/, IRTIME /0/, IORD /2/ *** Identify the routine. IF(LIDENT)PRINT *,' /// ROUTINE SIGCNV ///' *** Reset the add-on function each time. NCADD=1 IENADD=0 FCNADD=' ' *** Reset matrix slot numbers. ISTIME=0 ISTRAN=0 *** Get hold of the number of words. CALL INPNUM(NWORD) *** Read the words. INEXT=1 DO 100 I=2,NWORD IF(INEXT.GT.I)GOTO 100 * Check for TRANSFER-FUNCTION. IF(INPCMP(I,'TR#ANSFER-F#UNCTION').NE.0)THEN IF(I+1.GT.NWORD)THEN CALL INPMSG(I,'The function is not specified.') ELSEIF(INPCMP(I+2,'VS').NE.0.AND.I+3.LE.NWORD)THEN IRTIME=0 IRTRAN=0 CALL INPSTR(I+1,I+1,NAME,NCNAME) DO 110 J=1,NGLB IF(GLBMOD(J).EQ.5.AND.GLBVAR(J).EQ.NAME(1:NCNAME)) - IRTRAN=NINT(GLBVAL(J)) 110 CONTINUE ISTRAN=MATSLT(IRTRAN) CALL INPSTR(I+3,I+3,NAME,NCNAME) DO 120 J=1,NGLB IF(GLBMOD(J).EQ.5.AND.GLBVAR(J).EQ.NAME(1:NCNAME)) - IRTIME=NINT(GLBVAL(J)) 120 CONTINUE ISTIME=MATSLT(IRTIME) IF(ISTIME.EQ.0)CALL INPMSG(I+1,'Not a known matrix') IF(ISTRAN.EQ.0)CALL INPMSG(I+3,'Not a known matrix') INEXT=I+4 IF(IENTRY.GT.0)THEN CALL ALGCLR(IENTRY) IENTRY=0 ENDIF ELSE CALL INPSTR(I+1,I+1,FCNCNV,NCCNV) IF(NCCNV.GT.0.AND.IENTRY.GT.0)THEN CALL ALGCLR(IENTRY) IENTRY=0 ENDIF INEXT=I+2 IRTIME=0 IRTRAN=0 ENDIF * Check for ADD. ELSEIF(INPCMP(I,'ADD-#ON-#FUNCTION').NE.0)THEN IF(I+1.GT.NWORD)THEN CALL INPMSG(I,'The function is not specified.') ELSE CALL INPSTR(I+1,I+1,FCNADD,NCADD) ENDIF INEXT=I+2 * Check for RANGE. ELSEIF(INPCMP(I,'RAN#GE').NE.0)THEN IF(I+2.GT.NWORD)THEN CALL INPMSG(I,'RANGE incompletely specified.') ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPCHK(I+2,2,IFAIL2) CALL INPRDR(I+1,CNVMIR,0.0) CALL INPRDR(I+2,CNVMAR,1.0E10) IF(IFAIL1.NE.0.OR.IFAIL2.NE.0)THEN CNVMIN=0.0 CNVMAX=1.0E10 ELSEIF(CNVMIR.EQ.CNVMAR)THEN CALL INPMSG(I+1,'Zero range not permitted.') CALL INPMSG(I+2,'See previous message.') CNVMIN=0.0 CNVMAX=1.0E10 ELSE CNVMIN=MIN(CNVMIR,CNVMAR) CNVMAX=MAX(CNVMIR,CNVMAR) ENDIF ENDIF INEXT=I+3 * Check for ORDER. ELSEIF(INPCMP(I,'ORD#ER').NE.0)THEN IF(I+1.GT.NWORD)THEN CALL INPMSG(I,'ORDER incompletely specified.') ELSE CALL INPCHK(I+1,1,IFAIL1) CALL INPRDI(I+1,IORDR,IORD) IF(IFAIL1.EQ.0.AND.IORDR.GE.1)THEN IORD=IORDR ELSEIF(IFAIL1.EQ.0)THEN CALL INPMSG(I+1,'Should be 1 or larger.') ENDIF ENDIF INEXT=I+2 * Other keywords are not recognised. ELSE CALL INPMSG(I,'Unknown keyword.') ENDIF 100 CONTINUE *** Print error messages. CALL INPERR *** Debugging output. IF(LDEBUG)THEN IF(NCCNV.LE.0)THEN WRITE(LUNOUT,'('' ++++++ SIGCNV DEBUG : No'', - '' transfer function, IENTRY='',I5)') IENTRY ELSE WRITE(LUNOUT,'('' ++++++ SIGCNV DEBUG :'', - '' Transfer function: '',A/26X,''Valid for '', - E15.8,'' <= t <= '',E15.8,'' [microsec]''/26X, - ''Add-on function: '',A/26X, - ''Interpolate global '',I5,'' vs '',I5/26X, - ''Entry point transfer function: '',I5)') - FCNCNV(1:MAX(1,NCCNV)),CNVMIN,CNVMAX, - FCNADD(1:MAX(1,NCADD)),IRTRAN,IRTIME,IENTRY ENDIF ENDIF *** Ensure that there is a transfer function. IF(IENTRY.LE.0.AND. - (ISTIME.LE.0.OR.ISTRAN.LE.0).AND. - (NCCNV.LE.0.OR.FCNCNV.EQ.' '))THEN PRINT *,' !!!!!! SIGCNV WARNING : No transfer function'// - ' available ; no convolution done.' IFAIL=1 RETURN ENDIF *** Test for the time range. IF(.NOT.RESSET)THEN PRINT *,' !!!!!! SIGCNV WARNING : The time window has'// - ' not yet been set; no convolution done.' IFAIL=1 RETURN ENDIF *** Translate the transfer function, if there is no entry point yet. IF(IENTRY.LE.0.AND.(ISTIME.LE.0.OR.ISTRAN.LE.0))THEN VAR(1)='T ' CALL ALGPRE(FCNCNV(1:NCCNV),NCCNV,VAR,1, - NRES,USE,IENTRY,IFAIL1) * Verify that the translation worked correctly. IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! SIGCNV WARNING : Transfer function'// - ' could not be translated ; no convolutions done.' CALL ALGCLR(IENTRY) IENTRY=0 NCCNV=0 IFAIL=1 RETURN * Make sure that there is only one result coming back. ELSEIF(NRES.NE.1)THEN PRINT *,' !!!!!! SIGCNV WARNING : The transfer'// - ' function does not return 1 result ; no'// - ' convolutions done.' CALL ALGCLR(IENTRY) IENTRY=0 NCCNV=0 IFAIL=1 RETURN * Ensure there is a time dependence. ELSEIF(.NOT.USE(1))THEN PRINT *,' ------ SIGCNV MESSAGE : The transfer'// - ' function does not depend on T.' ENDIF ENDIF *** Translate the add function, if there is no entry point yet. IF(FCNADD.NE.' ')THEN VAR(1)='T ' VAR(2)='SIGNAL ' CALL ALGPRE(FCNADD(1:NCADD),NCADD,VAR,2, - NRES,USE,IENADD,IFAIL1) * Verify that the translation worked correctly. IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! SIGCNV WARNING : The add function'// - ' could not be translated ; nothing added.' CALL ALGCLR(IENADD) IENADD=0 NCADD=0 * Make sure that there is only one result coming back. ELSEIF(NRES.NE.1)THEN PRINT *,' !!!!!! SIGCNV WARNING : The add-on'// - ' function does not return 1 result ; nothing'// - ' added.' CALL ALGCLR(IENADD) IENADD=0 NCADD=0 ENDIF ELSE IENADD=0 ENDIF *** Reset the error counter. NERR=0 *** Evaluate the transfer function. ISTIME=0 ISTRAN=0 DO 90 I=1,NTIME * Negative time part. VAL(1)=TIMSIG(1)-TIMSIG(I) MODVAR(1)=2 IF(VAL(1).LT.CNVMIN.OR.VAL(1).GT.CNVMAX)THEN CNVTAB(1-I)=0 ELSEIF(IENTRY.GT.0)THEN CALL ALGEXE(IENTRY,VAL,MODVAR,1,RES,MODRES,1,IFAIL1) IF(IFAIL1.EQ.0.AND.MODRES(1).EQ.2)THEN CNVTAB(1-I)=RES(1) ELSE CNVTAB(1-I)=0 NERR=NERR+1 ENDIF ELSE IF(NERR.EQ.0)THEN CALL MATIN1(IRTIME,IRTRAN,1,VAL(1),CNVTAB(1-I), - ISTIME,ISTRAN,IORD,IFAIL1) IF(IFAIL1.NE.0)NERR=NERR+1 ELSE CNVTAB(1-I)=0 NERR=NERR+1 ENDIF ENDIF * Positive time part. IF(I.EQ.1)GOTO 90 VAL(1)=TIMSIG(I)-TIMSIG(1) MODVAR(1)=2 IF(VAL(1).LT.CNVMIN.OR.VAL(1).GT.CNVMAX)THEN CNVTAB(I-1)=0 ELSEIF(IENTRY.GT.0)THEN CALL ALGEXE(IENTRY,VAL,MODVAR,1,RES,MODRES,1,IFAIL1) IF(IFAIL1.EQ.0.AND.MODRES(1).EQ.2)THEN CNVTAB(I-1)=RES(1) ELSE CNVTAB(I-1)=0 NERR=NERR+1 ENDIF ELSE IF(NERR.EQ.0)THEN CALL MATIN1(IRTIME,IRTRAN,1,VAL(1),CNVTAB(I-1), - ISTIME,ISTRAN,IORD,IFAIL1) IF(IFAIL1.NE.0)NERR=NERR+1 ELSE NERR=NERR+1 CNVTAB(I-1)=0 ENDIF ENDIF 90 CONTINUE *** Print error messages, if applicable. IF(NERR.NE.0)PRINT *,' !!!!!! SIGCNV WARNING : In total ',NERR, - ' terms skipped in convolutions for arithmetic/mode errors.' CALL ALGERR NERR=0 *** Loop over all (groups of) sense wires. DO 10 ISW=1,NSW DO 20 J=1,NTIME * Add the add-on function. IF(IENADD.GT.0)THEN VAL(1)=TIMSIG(J) MODVAR(1)=2 VAL(2)=SIGNAL(J,ISW,1) MODVAR(2)=2 CALL ALGEXE(IENADD,VAL,MODVAR,2,RES,MODRES,1,IFAIL1) IF(IFAIL1.NE.0.OR.MODRES(1).NE.2)THEN AUX(J)=0 NERR=NERR+1 ELSE AUX(J)=RES(1) ENDIF ELSE AUX(J)=0 ENDIF * Do the actual convolution. DO 30 K=1,NTIME AUX(J)=AUX(J)+TDEV*CNVTAB(J-K)*SIGNAL(K,ISW,1) 30 CONTINUE 20 CONTINUE DO 70 J=1,NTIME SIGNAL(J,ISW,1)=AUX(J) 70 CONTINUE ** Cross induced signals. IF(LCROSS)THEN DO 40 J=1,NTIME * Add the add-on function. IF(IENADD.GT.0)THEN VAL(1)=TIMSIG(J) MODVAR(1)=2 VAL(2)=SIGNAL(J,ISW,2) MODVAR(2)=2 CALL ALGEXE(IENADD,VAL,MODVAR,2,RES,MODRES,1,IFAIL1) IF(IFAIL1.NE.0.OR.MODRES(1).NE.2)THEN AUX(J)=0 NERR=NERR+1 ELSE AUX(J)=RES(1) ENDIF ELSE AUX(J)=0 ENDIF * Do the actual convolutions. DO 50 K=1,NTIME AUX(J)=AUX(J)+TDEV*CNVTAB(J-K)*SIGNAL(K,ISW,2) 50 CONTINUE 40 CONTINUE ENDIF DO 60 J=1,NTIME SIGNAL(J,ISW,2)=AUX(J) 60 CONTINUE 10 CONTINUE *** Print error messages. IF(NERR.NE.0)PRINT *,' !!!!!! SIGCNV WARNING : In total ',NERR, - ' add-on terms skipped for arithmetic/mode errors.' CALL ALGERR *** Get rid of add function. IF(IENADD.GT.0)CALL ALGCLR(IENADD) *** Things seem to have worked. IFAIL=0 *** Register the amount of CPU time used. CALL TIMLOG('Convoluting with transfer function: ') END +DECK,SIGNOI. SUBROUTINE SIGNOI(IFAIL) *----------------------------------------------------------------------- * SIGNOI - Adds noise to the signals, * VARIABLES : * (Last changed on 16/ 1/00.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,SIGNALDATA. +SEQ,CELLDATA. +SEQ,PRINTPLOT. CHARACTER*(MXCHAR) FCNNOI CHARACTER*10 VAR(MXVAR) LOGICAL USE(MXVAR) INTEGER MODVAR(MXVAR),MODRES(1),IENTRY,NCNOI,I,J,INEXT,IFAIL, - IFAIL1,NRES,NWORD,ISW,NERR,INPCMP REAL RES(1),AUX(MXLIST),VAL(MXVAR) EXTERNAL INPCMP +SELF,IF=SAVE. SAVE FCNNOI,NCNOI,IENTRY +SELF. DATA FCNNOI(1:1)/' '/ DATA NCNOI /1/, IENTRY /0/ *** Identify the routine. IF(LIDENT)PRINT *,' /// ROUTINE SIGNOI ///' *** Get hold of the number of words. CALL INPNUM(NWORD) *** Read the words. INEXT=1 DO 100 I=2,NWORD IF(INEXT.GT.I)GOTO 100 * Check for NOISE-FUNCTION. IF(INPCMP(I,'NOISE-#FUNCTION').NE.0)THEN IF(I+1.GT.NWORD)THEN CALL INPMSG(I,'The function is not specified.') ELSE CALL INPSTR(I+1,I+1,FCNNOI,NCNOI) IF(NCNOI.GT.0.AND.IENTRY.GT.0)THEN CALL ALGCLR(IENTRY) IENTRY=0 ENDIF ENDIF INEXT=I+2 * Other keywords are not known. ELSE CALL INPMSG(I,'Unknown keyword.') ENDIF 100 CONTINUE *** Print error messages. CALL INPERR *** Debugging output. IF(LDEBUG)THEN IF(NCNOI.LE.0)THEN WRITE(LUNOUT,'('' ++++++ SIGNOI DEBUG : No'', - '' noise function, IENTRY='',I5)') IENTRY ELSE WRITE(LUNOUT,'('' ++++++ SIGNOI DEBUG :'', - '' Noise function: '',A/26X,''Entry='',I5)') - FCNNOI(1:NCNOI),IENTRY ENDIF ENDIF *** Ensure that there is a noise function. IF(IENTRY.LE.0.AND.(NCNOI.LE.0.OR.FCNNOI.EQ.' '))THEN PRINT *,' !!!!!! SIGNOI WARNING : No noise function'// - ' available ; no noise added.' IFAIL=1 RETURN ENDIF *** Test for the time range. IF(.NOT.RESSET)THEN PRINT *,' !!!!!! SIGNOI WARNING : The time window has'// - ' not yet been set; no noise added.' IFAIL=1 RETURN ENDIF *** Translate the noise function, if there is no entry point yet. IF(IENTRY.LE.0)THEN VAR(1)='T ' CALL ALGPRE(FCNNOI(1:NCNOI),NCNOI,VAR,1, - NRES,USE,IENTRY,IFAIL1) * Verify that the translation worked correctly. IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! SIGNOI WARNING : Noise function'// - ' could not be translated ; no noise added.' CALL ALGCLR(IENTRY) IENTRY=0 NCNOI=0 IFAIL=1 RETURN * Make sure that there is only one result coming back. ELSEIF(NRES.NE.1)THEN PRINT *,' !!!!!! SIGNOI WARNING : The noise'// - ' function does not return 1 result ; no'// - ' noise added.' CALL ALGCLR(IENTRY) IENTRY=0 NCNOI=0 IFAIL=1 RETURN * Ensure there is a time dependence. C ELSEIF(.NOT.USE(1))THEN C PRINT *,' ------ SIGNOI WARNING : The noise'// C - ' function does not depend on T.' ENDIF ENDIF *** Reset the error counter. NERR=0 *** Loop over all (groups of) sense wires. DO 10 ISW=1,NSW DO 20 J=1,NTIME VAL(1)=TIMSIG(J) MODVAR(1)=2 CALL ALGEXE(IENTRY,VAL,MODVAR,1,RES,MODRES,1,IFAIL1) IF(IFAIL1.EQ.0.AND.MODRES(1).EQ.2)THEN AUX(J)=RES(1) ELSE AUX(J)=0 NERR=NERR+1 ENDIF 20 CONTINUE DO 30 J=1,NTIME SIGNAL(J,ISW,1)=SIGNAL(J,ISW,1)+AUX(J) IF(LCROSS)SIGNAL(J,ISW,2)=SIGNAL(J,ISW,2)+AUX(J) 30 CONTINUE 10 CONTINUE *** Print error messages, if applicable. IF(NERR.NE.0)PRINT *,' !!!!!! SIGNOI WARNING : In total ',NERR, - ' noise terms skipped for arithmetic/mode errors.' CALL ALGERR *** Things seem to have worked. IFAIL=0 *** Register the amount of CPU time used. CALL TIMLOG('Adding noise to the signals: ') END +DECK,SIGTHC. SUBROUTINE SIGTHC(ISW,SCR,OPTION,NCR,TCR,IFAIL) *----------------------------------------------------------------------- * SIGTHC - Computes threshold crossings * (Last changed on 8/ 9/99.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,SIGNALDATA. +SEQ,PRINTPLOT. +SEQ,PARAMETERS. REAL TCR(MXLIST),SCR,VEC(MXLIST),VNEW,XPL(2),YPL(2),VECMIN, - VECMAX,DIVDIF INTEGER ISW,NCR,IDIR,IORD,JORD,I,IFAIL,NC,IORG,NVEC LOGICAL LPLOT CHARACTER*(*) OPTION CHARACTER*20 AUX EXTERNAL DIVDIF *** Assume this will fail. IFAIL=1 *** Initial settings. NCR=0 *** Check the sense wire group. IF(ISW.LE.0.OR.ISW.GT.NSW)THEN PRINT *,' !!!!!! SIGTRC WARNING : Electrode group is'// - ' out of range; no crossings computed.' RETURN ENDIF *** Decode the option string. IDIR=+1 LPLOT=.FALSE. JORD=1 IF(INDEX(OPTION,'RISING').NE.0) IDIR=+1 IF(INDEX(OPTION,'UP').NE.0) IDIR=+1 IF(INDEX(OPTION,'TRAILING').NE.0) IDIR=-1 IF(INDEX(OPTION,'FALLING').NE.0) IDIR=-1 IF(INDEX(OPTION,'DOWN').NE.0) IDIR=-1 IF(INDEX(OPTION,'PLOT').NE.0) LPLOT=.TRUE. IF(INDEX(OPTION,'NOPLOT').NE.0) LPLOT=.FALSE. IF(INDEX(OPTION,'LINEAR').NE.0) JORD=1 IF(INDEX(OPTION,'PARABOLA').NE.0) JORD=2 IF(INDEX(OPTION,'PARABOLIC').NE.0)JORD=2 IF(INDEX(OPTION,'QUADRATIC').NE.0)JORD=2 IF(INDEX(OPTION,'CUBIC').NE.0) JORD=3 *** Debugging output. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ SIGTHC DEBUG : Computing'', - '' threshold crossings for''/ - 26X,''sense wire number '',I3/ - 26X,''polynomial order '',I3/ - 26X,''rising/falling '',I3/ - 26X,''plot interpolation '',L3)') ISW,JORD,IDIR,LPLOT *** Prepare the plot frame if required. IF(LPLOT)THEN * Prepare vectors, establish range. DO 100 I=1,NTIME VEC(I)=SIGNAL(I,ISW,1) IF(LCROSS)VEC(I)=VEC(I)+SIGNAL(I,ISW,2) IF(I.EQ.1)THEN VECMAX=VEC(1) VECMIN=VEC(1) ELSE VECMAX=MAX(VECMAX,VEC(I)) VECMIN=MIN(VECMIN,VEC(I)) ENDIF 100 CONTINUE * Plot the frame. CALL GRCART(TIMSIG(1),VECMIN-0.1*(VECMAX-VECMIN), - TIMSIG(NTIME),VECMAX+0.1*(VECMAX-VECMIN), - 'Time [microsec]','Signal [microamp]', - 'Check on threshold crossings') * Plot the signal. CALL GRATTS('FUNCTION-1','POLYLINE') CALL GRLINE(NTIME,TIMSIG,VEC) * Next are the signal segments, plotted as FUNCTION-2. CALL GRATTS('FUNCTION-2','POLYLINE') ENDIF *** Scan the signal vectors, initialise. NVEC=1 IORG=1 VEC(1)=SIGNAL(1,ISW,1) IF(LCROSS)VEC(1)=VEC(1)+SIGNAL(1,ISW,2) * Loop over the elements. DO 10 I=2,NTIME * Compute the vector element. VNEW=SIGNAL(I,ISW,1) IF(LCROSS)VNEW=VNEW+SIGNAL(I,ISW,2) * If still increasing or decreasing, add to the vector. IF((IDIR.GT.0.AND.VNEW.GT.VEC(NVEC)).OR. - (IDIR.LT.0.AND.VNEW.LT.VEC(NVEC)))THEN NVEC=NVEC+1 VEC(NVEC)=VNEW * Otherwise see whether we crossed the threshold level. ELSEIF((VEC(1)-SCR)*(SCR-VEC(NVEC)).GE.0.AND. - NVEC.GT.1.AND. - ((IDIR.GT.0.AND.VEC(NVEC).GT.VEC(1)).OR. - (IDIR.LT.0.AND.VEC(NVEC).LT.VEC(1))))THEN NCR=NCR+1 IORD=MIN(NVEC-1,JORD) TCR(NCR)=DIVDIF(TIMSIG(IORG),VEC,NVEC,SCR,IORD) IF(LPLOT)CALL GRLINE(NVEC,TIMSIG(IORG),VEC) NVEC=1 IORG=I VEC(NVEC)=VNEW * No crossing, simply reset the vector. ELSE NVEC=1 IORG=I VEC(NVEC)=VNEW ENDIF 10 CONTINUE *** Check the final vector. IF((VEC(1)-SCR)*(SCR-VEC(NVEC)).GE.0.AND. - NVEC.GT.1.AND. - ((IDIR.GT.0.AND.VEC(NVEC).GT.VEC(1)).OR. - (IDIR.LT.0.AND.VEC(NVEC).LT.VEC(1))))THEN NCR=NCR+1 IORD=MIN(NVEC-1,JORD) TCR(NCR)=DIVDIF(TIMSIG(IORG),VEC,NVEC,SCR,IORD) IF(LPLOT)CALL GRLINE(NVEC,TIMSIG(IORG),VEC) ENDIF *** Finish the plot if required. IF(LPLOT)THEN CALL GRATTS('FUNCTION-3','POLYLINE') * Plot the threshold level. XPL(1)=TIMSIG(1) XPL(2)=TIMSIG(NTIME) YPL(1)=SCR YPL(2)=SCR CALL GRLINE(2,XPL,YPL) * Plot each of the times. DO 120 I=1,NCR XPL(1)=TCR(I) XPL(2)=TCR(I) YPL(1)=VECMIN-0.1*(VECMAX-VECMIN) YPL(2)=SCR CALL GRLINE(2,XPL,YPL) 120 CONTINUE * And add some comment strings. CALL OUTFMT(REAL(NCR),2,AUX,NC,'LEFT') CALL GRCOMM(1,'Crossings: '//AUX(1:NC)) CALL OUTFMT(REAL(JORD),2,AUX,NC,'LEFT') CALL GRCOMM(3,'Interpolation order: '//AUX(1:NC)) IF(IDIR.EQ.+1)THEN CALL GRCOMM(2,'Hunting: rising edges') ELSE CALL GRCOMM(2,'Hunting: falling edges') ENDIF IF(PARTID.NE.'Unknown') - CALL GRCOMM(4,'Particle: '//PARTID) * Close the frame. CALL GRNEXT ENDIF *** Things seem to have worked. IFAIL=0 END +DECK,SIGMCA. SUBROUTINE SIGMCA(X1,Y1,Z1,NETOT,NITOT,STAT, - NHIST,IHIST,ITYPE,IENTRY,OPTION) *----------------------------------------------------------------------- * SIGMCA - Subroutine that computes a drift line using a Monte-Carlo * technique to take account of diffusion and of avalanche * formation. Adds optionally the induced currents. * VARIABLES : * REFERENCE : * (Last changed on 7/ 3/01.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,GASDATA. +SEQ,PARAMETERS. +SEQ,DRIFTLINE. +SEQ,PRINTPLOT. +SEQ,CONSTANTS. INTEGER MXVEC PARAMETER(MXVEC=10000) REAL XLIST(MXMCA),YLIST(MXMCA),ZLIST(MXMCA),TLIST(MXMCA), - Q,X1,Y1,Z1,GASTWN,GASATT,PROBTH,PALPHA,PETA,TOFF, - ALPHA(MXLIST),ETA(MXLIST),RVECU(MXVEC),RVECN(MXVEC) INTEGER IFAIL,NLIST(MXMCA),NMCA,IPART,I,J,K,L,IMCA,NINTER, - NELEC,NION,NETOT,NITOT,NHIST,IHIST(*),IENTRY(*),ITYPE(2,*), - IVECU,IVECN,NEW,NMAX LOGICAL LELEPL,LIONPL,LTOWN,LATTA,STAT(4),CROSS,LESIG,LISIG, - LPRINT COMMON /MCAMAT/ XLIST,YLIST,ZLIST,TLIST,NLIST CHARACTER*(*) OPTION EXTERNAL GASTWN,GASATT *** Identify the routine if requested. IF(LIDENT)PRINT *,' /// ROUTINE SIGMCA ///' *** Initial debugging output. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ SIGMCA DEBUG : MC drift'', - '' from ('',E15.8,'','',E15.8,'','',E15.8,'')'')') X1,Y1,Z1 *** Make sure that electron drift velocities are available. IF(.NOT.GASOK(1))THEN PRINT *,' !!!!!! SIGMCA WARNING : Electron drift velocity'// - ' data missing; no avalanche.' RETURN ENDIF *** Obtain the matrix to store the avalanche development. CALL BOOK('BOOK','MCAMAT','MCA',IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! SIGMCA WARNING : Unable to obtain'// - ' storage for the avalanche; avalanche not computed.' RETURN ENDIF *** Default options. LELEPL=.FALSE. LIONPL=.FALSE. LTOWN=GASOK(4) LATTA=GASOK(6) NMAX=0 LESIG=.FALSE. LISIG=.TRUE. CROSS=.TRUE. LPRINT=.FALSE. *** Default settings of parameters. PROBTH=0.01 *** Decode the options. IF(INDEX(OPTION,'NOION-TAIL').NE.0)THEN LISIG=.FALSE. ELSEIF(INDEX(OPTION,'ION-TAIL').NE.0)THEN LISIG=.TRUE. ENDIF IF(INDEX(OPTION,'NOELECTRON-PULSE').NE.0)THEN LESIG=.FALSE. ELSEIF(INDEX(OPTION,'ELECTRON-PULSE').NE.0)THEN LESIG=.TRUE. ENDIF IF(INDEX(OPTION,'NOCROSS')+INDEX(OPTION,'DIRECT').NE.0)THEN CROSS=.FALSE. ELSEIF(INDEX(OPTION,'CROSS').NE.0)THEN CROSS=.TRUE. ENDIF IF(INDEX(OPTION,'NOPLOT-ELECTRON').NE.0)THEN LELEPL=.FALSE. ELSEIF(INDEX(OPTION,'PLOT-ELECTRON').NE.0)THEN LELEPL=.TRUE. ENDIF IF(INDEX(OPTION,'NOPLOT-ION').NE.0)THEN LIONPL=.FALSE. ELSEIF(INDEX(OPTION,'PLOT-ION').NE.0)THEN IF(.NOT.GASOK(2))THEN PRINT *,' !!!!!! SIGMCA WARNING : Ion mobilities are'// - ' absent; can not compute ion drift lines.' ELSE LIONPL=.TRUE. ENDIF ENDIF IF(INDEX(OPTION,'NOTOWNSEND').NE.0)THEN LTOWN=.FALSE. ELSEIF(INDEX(OPTION,'TOWNSEND').NE.0.AND..NOT.GASOK(4))THEN PRINT *,' !!!!!! SIGMCA WARNING : Townsend data is not'// - ' present; TOWNSEND option not valid.' ELSEIF(INDEX(OPTION,'TOWNSEND').NE.0)THEN LTOWN=.TRUE. ENDIF IF(INDEX(OPTION,'NOATTACHMENT').NE.0)THEN LATTA=.FALSE. ELSEIF(INDEX(OPTION,'ATTACHMENT').NE.0.AND..NOT.GASOK(6))THEN PRINT *,' !!!!!! SIGMCA WARNING : Attachment data is not'// - ' present; ATTACHMENT option not valid.' ELSEIF(INDEX(OPTION,'ATTACHMENT').NE.0)THEN LATTA=.TRUE. ENDIF IF(INDEX(OPTION,'ABORT-100000').NE.0)THEN NMAX=100000 ELSEIF(INDEX(OPTION,'ABORT-10000').NE.0)THEN NMAX=10000 ELSEIF(INDEX(OPTION,'ABORT-1000').NE.0)THEN NMAX=1000 ELSEIF(INDEX(OPTION,'ABORT-100').NE.0)THEN NMAX=100 ENDIF IF(INDEX(OPTION,'NOPRINT').NE.0)THEN LPRINT=.FALSE. ELSEIF(INDEX(OPTION,'PRINT').NE.0)THEN LPRINT=.TRUE. ENDIF *** Make sure that some kind of output has been requested. IF(.NOT.(LATTA.OR.LTOWN))THEN PRINT *,' !!!!!! SIGMCA WARNING : Neither attachment not'// - ' multiplication to be included; no avalanche.' CALL BOOK('RELEASE','MCAMAT','MCA',IFAIL) RETURN ENDIF *** Initialise the avalanche table. NMCA=1 XLIST(1)=X1 YLIST(1)=Y1 ZLIST(1)=Z1 TLIST(1)=0 NLIST(1)=1 NETOT=1 NITOT=0 *** Loop over the table. IMCA=0 100 CONTINUE * Check we are still in the table. IMCA=IMCA+1 IF(IMCA.GT.NMCA)THEN CALL BOOK('RELEASE','MCAMAT','MCA',IFAIL) RETURN ENDIF *** Loop over the electrons at this location. DO 40 J=1,NLIST(IMCA) * Compute an electron drift line. Q=-1 IPART=1 CALL DLCMC(XLIST(IMCA),YLIST(IMCA),ZLIST(IMCA),Q,IPART) * Compute alpha and eta vectors. CALL DLCEQU(ALPHA,ETA,IFAIL) * Offset the time of the electrons by the starting time. DO 10 I=1,NU TU(I)=TU(I)+TLIST(IMCA) 10 CONTINUE *** Follow the avalanche development DO 20 I=1,NU-1 * Set initial number of electrons and ions. NELEC=1 NION=0 * Compute the number of subdivisions. NINTER=(ALPHA(I)+ETA(I))/PROBTH IF(NINTER.LT.1)NINTER=1 *** Loop over the subdivisions. DO 50 K=1,NINTER * Probabilities for gain and loss. PALPHA=ALPHA(I)/REAL(NINTER) PETA=ETA(I)/REAL(NINTER) * Gaussian approximation. IF(NELEC.GT.100)THEN DATA IVECN/0/ IF(IVECN.EQ.0.OR.IVECN+2.GT.MXVEC)THEN CALL RNORML(RVECN,MXVEC) IVECN=1 ENDIF IF(LTOWN)THEN NELEC=NELEC+NINT(REAL(NELEC)*PALPHA+RVECN(IVECN)* - SQRT(REAL(NELEC)*PALPHA*(1-PALPHA))) NION=NION+NINT(REAL(NELEC)*PALPHA+RVECN(IVECN)* - SQRT(REAL(NELEC)*PALPHA*(1-PALPHA))) IVECN=IVECN+1 ENDIF IF(LATTA)THEN NELEC=NELEC-NINT(REAL(NELEC)*PETA+RVECN(IVECN)* - SQRT(REAL(NELEC)*PETA*(1-PETA))) IVECN=IVECN+1 ENDIF * Binomial approximation. ELSE NEW=0 DO 80 L=1,NELEC DATA IVECU/0/ IF(IVECU.EQ.0.OR.IVECU+2.GT.MXVEC)THEN CALL RANLUX(RVECU,MXVEC) IVECU=1 ENDIF IF(LTOWN)THEN IF(RVECU(IVECU).LT.PALPHA)THEN NEW=NEW+1 NION=NION+1 ENDIF IVECU=IVECU+1 ENDIF IF(LATTA)THEN IF(RVECU(IVECU).LT.PETA)NEW=NEW-1 IVECU=IVECU+1 ENDIF 80 CONTINUE NELEC=NELEC+NEW ENDIF * Verify that there still is an electron. IF(NELEC.LE.0)THEN NETOT=NETOT-1 IF(STAT(2))CALL DLCMCF(REAL(XU(I)+XU(I+1))/2, - REAL(YU(I)+YU(I+1))/2,REAL(ZU(I)+ZU(I+1))/2, - REAL(TU(I)+TU(I+1))/2,1,NHIST,IHIST, - ITYPE,IENTRY,2) IF(LPRINT)WRITE(LUNOUT,'('' Electron '',I5,''/'',I5, - '' attached at t='',E15.8)') - J,IMCA,REAL(TU(I)+TU(I+1))/2 GOTO 60 ENDIF * Next subdivision. 50 CONTINUE 60 CONTINUE *** If at least 1 new electron has been created, add to the table. IF(NELEC.GT.1)THEN * Ensure we do not pass the maximum permitted avalanche size. IF(NMCA+1.GT.NMAX.AND.NMAX.GT.0)THEN PRINT *,' !!!!!! SIGMCA WARNING : Avalanche exceeds'// - ' maximum permitted size; avalanche ended.' CALL BOOK('RELEASE','MCAMAT','MCA',IFAIL) RETURN * Ensure there is still space in the table. ELSEIF(NMCA+1.GT.MXMCA)THEN PRINT *,' !!!!!! SIGMCA WARNING : Overflow of'// - ' secondary electron table; avalanche ended.' CALL BOOK('RELEASE','MCAMAT','MCA',IFAIL) RETURN ENDIF * Add the point to the table, NMCA=NMCA+1 XLIST(NMCA)=XU(I+1) YLIST(NMCA)=YU(I+1) ZLIST(NMCA)=ZU(I+1) TLIST(NMCA)=TU(I+1) NLIST(NMCA)=NELEC-1 * And also enter in the overall statistics. NETOT=NETOT+NELEC-1 * And enter the newly created electrons in the histograms. IF(STAT(1))CALL DLCMCF(REAL(XU(I)+XU(I+1))/2, - REAL(YU(I)+YU(I+1))/2,REAL(ZU(I)+ZU(I+1))/2, - REAL(TU(I)+TU(I+1))/2,NELEC-1,NHIST,IHIST, - ITYPE,IENTRY,1) IF(LPRINT)WRITE(LUNOUT,'('' Electron '',I5,''/'',I5, - '' creates '',I5,'' pairs called '',I5, - '' at t='',E15.8)') - J,IMCA,NLIST(NMCA),NMCA,TLIST(NMCA) ENDIF *** Also compute the newly produced ions if requested. IF(NION.GE.1.AND.(LIONPL.OR.STAT(4).OR.LISIG))THEN * Store offset time. TOFF=TU(I+1) * Make a backup of the electron drift line. CALL DLCBCK('SAVE') DO 30 K=1,NION * Compute the ion drift lines. Q=+1 IPART=2 CALL DLCMC(XLIST(NMCA),YLIST(NMCA),ZLIST(NMCA),Q,IPART) * Offset the time of the ions by the starting time. DO 90 L=1,NU TU(L)=TU(L)+TOFF 90 CONTINUE * Add the signals. IF(LISIG)CALL SIGADS(CROSS,IFAIL) * Enter the ion end point in the histograms if requested. IF(STAT(4))CALL DLCMCF(REAL(XU(NU)),REAL(YU(NU)), - REAL(ZU(NU)),REAL(TU(NU)),1, - NHIST,IHIST,ITYPE,IENTRY,4) IF(LPRINT)WRITE(LUNOUT,'('' Ion '',I5,''/'',I5, - '' stops at t='',E15.8)') J,IMCA,TU(NU) * Plot the ion drift line. IF(LIONPL)CALL DLCPLT 30 CONTINUE * Restore electron drift line. CALL DLCBCK('RESTORE') ENDIF *** Keep track of ion statistics. NITOT=NITOT+NION *** Make sure the electron is still alive. IF(NELEC.LE.0)THEN NU=I GOTO 70 ENDIF 20 CONTINUE * If electron survived, register its end point. IF(STAT(3))CALL DLCMCF(REAL(XU(NU)), - REAL(YU(NU)),REAL(ZU(NU)),REAL(TU(NU)),1, - NHIST,IHIST,ITYPE,IENTRY,3) IF(LPRINT)WRITE(LUNOUT,'('' Electron '',I5,''/'',I5, - '' stops at t='',E15.8)') J,IMCA,TU(NU) 70 CONTINUE * Add the signals. IF(LESIG)CALL SIGADS(CROSS,IFAIL) * Plot the electron if requested. IF(LELEPL)CALL DLCPLT * Proceed with next electron. 40 CONTINUE *** And proceed with the next table entry. GOTO 100 END +DECK,SIGCAL. SUBROUTINE SIGCAL(INSTR,IFAIL) *----------------------------------------------------------------------- * SIGCAL - Processes signal related procedure calls. * (Last changed on 6/ 1/01.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,SIGNALDATA. +SEQ,CELLDATA. +SEQ,GASDATA. +SEQ,MATDATA. +SEQ,ALGDATA. +SEQ,CONSTANTS. +SEQ,DRIFTLINE. INTEGER MXAHIS PARAMETER(MXAHIS=20) INTEGER MATSLT,IPROC,IWRONG,NC,NARG,IFAIL,IFAIL1,IFAIL2,IFAIL3, - NCR,IQ,IA,IW,ISW,ISIZ(MXMDIM),INSTR,IRTIM,ISTIM,IRDIR,ISDIR, - IRCROS,ISCROS,NSIG,IREF(6),ISLOT(6),NDAT,IDIM, - I,J,JTYPE,NCOPT,NREXP,ITYPE(2,MXAHIS),NHIST, - NETOT,NITOT,IENTRY(MXAHIS),IHIST(MXAHIS) LOGICAL USE(MXVAR),STAT(4) CHARACTER*(MXINCH) TITLE,OPT CHARACTER*10 VARLIS(16) REAL TCR(MXLIST),EX,EY,EZ,QDRIFT DOUBLE PRECISION TIME(MXLIST),SIG(MXLIST),TMIN,TMAX EXTERNAL MATSLT *** Assume the CALL will fail. IFAIL=1 *** Check the signal initialisation has been done. IF(.NOT.CELSET)THEN PRINT *,' !!!!!! SIGCAL WARNING : Cell data not'// - ' available ; procedure not executed.' RETURN ELSEIF(.NOT.GASSET)THEN PRINT *,' !!!!!! SIGCAL WARNING : Gas data not'// - ' available ; procedure not executed.' RETURN ELSEIF(.NOT.SIGSET)THEN CALL SIGINI(IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! SIGCAL WARNING : Initialisation of'// - ' signal calculation failed; no signals.' RETURN ENDIF ENDIF *** Some easy reference variables. NARG=INS(INSTR,3) IPROC=INS(INSTR,1) *** Threshold crossings. IF(IPROC.EQ.-70)THEN * Check number and type of arguments. IWRONG=0 DO 150 I=4,NARG IF(ARGREF(I,1).GE.2)IWRONG=1 150 CONTINUE IF(MODARG(1).NE.2.OR.MODARG(2).NE.2.OR.MODARG(3).NE.1.OR. - NARG.LT.5.OR.IWRONG.EQ.1)THEN PRINT *,' !!!!!! SIGCAL WARNING : Incorrect argument'// - ' list provided for THRESHOLD_CROSSING.' RETURN ENDIF * Fetch the option string. CALL STRBUF('READ',NINT(ARG(3)),TITLE,NC,IFAIL1) CALL CLTOU(TITLE(1:NC)) * Clear previous use of storage for the results. DO 160 I=4,NARG CALL ALGREU(NINT(ARG(I)),MODARG(I),ARGREF(I,1)) 160 CONTINUE * Get the threshold crossings. CALL SIGTHC(NINT(ARG(1)),ARG(2), - TITLE(1:NC),NCR,TCR,IFAIL1) ARG(4)=REAL(NCR) MODARG(4)=2 DO 170 I=1,MIN(NCR,MXARG-4) ARG(4+I)=TCR(I) MODARG(4+I)=2 170 CONTINUE * Check the error flag. IF(IFAIL1.NE.0)PRINT *,' !!!!!! SIGCAL WARNING : Error'// - ' computing threshold crossings.' *** Return a signal. ELSEIF(IPROC.EQ.-71)THEN * Check argument list validity. IF(NARG.LT.3.OR.NARG.GT.4.OR. - MODARG(1).NE.2.OR. - ARGREF(2,1).GE.2.OR.ARGREF(3,1).GE.2.OR. - (NARG.GE.4.AND.ARGREF(4,1).GE.2))THEN PRINT *,' !!!!!! SIGCAL WARNING : Incorrect argument'// - ' list given to GET_SIGNAL; no signal returned.' RETURN ENDIF * Verify the electrode number. ISW=NINT(ARG(1)) IF(ISW.LT.0.OR.ISW.GT.NSW)THEN PRINT *,' !!!!!! SIGCAL WARNING : Invalid electrode'// - ' number given to GET_SIGNAL; no signal returned.' RETURN ENDIF * De-allocate the current arguments. CALL ALGREU(NINT(ARG(2)),MODARG(2),ARGREF(2,1)) CALL ALGREU(NINT(ARG(3)),MODARG(3),ARGREF(3,1)) IF(NARG.GE.4)CALL ALGREU(NINT(ARG(4)),MODARG(4),ARGREF(4,1)) * Allocate matrices. ISIZ(1)=NTIME CALL MATADM('ALLOCATE',IRTIM,1,ISIZ,2,IFAIL1) CALL MATADM('ALLOCATE',IRDIR,1,ISIZ,2,IFAIL2) IF(NARG.GE.4)THEN CALL MATADM('ALLOCATE',IRCROS,1,ISIZ,2,IFAIL3) ELSE IRCROS=0 IFAIL3=0 ENDIF ISTIM=MATSLT(IRTIM) ISDIR=MATSLT(IRDIR) IF(NARG.GE.4)THEN ISCROS=MATSLT(IRCROS) ELSE ISCROS=0 ENDIF IF(IFAIL1.NE.0.OR.IFAIL2.NE.0.OR.IFAIL3.NE.0.OR. - ISTIM.LE.0.OR.ISDIR.LE.0.OR. - (NARG.GE.4.AND.ISCROS.LE.0))THEN PRINT *,' !!!!!! SIGCAL WARNING : Failure to'// - ' allocate output matrices; signal not returned.' RETURN ENDIF * Copy the signals. DO 10 I=1,NTIME MVEC(MORG(ISTIM)+I)=TIMSIG(I) MVEC(MORG(ISDIR)+I)=SIGNAL(I,ISW,1) IF(NARG.GE.4)MVEC(MORG(ISCROS)+I)=SIGNAL(I,ISW,2) 10 CONTINUE * And save the matrices. ARG(2)=IRTIM MODARG(2)=5 ARG(3)=IRDIR MODARG(3)=5 IF(NARG.GE.4)THEN ARG(4)=IRCROS MODARG(4)=5 ENDIF *** Store a signal. ELSEIF(IPROC.EQ.-72)THEN * Check argument list validity. IF(NARG.LT.2.OR.NARG.GT.3.OR. - MODARG(1).NE.2.OR.MODARG(2).NE.5.OR. - (NARG.GE.3.AND.MODARG(3).NE.5))THEN PRINT *,' !!!!!! SIGCAL WARNING : Incorrect argument'// - ' list given to STORE_SIGNAL; no signal saved.' RETURN ENDIF * Verify the wire number. ISW=NINT(ARG(1)) IF(ISW.LE.0.OR.ISW.GT.NSW)THEN PRINT *,' !!!!!! SIGCAL WARNING : Invalid electrode'// - ' number given to STORE_SIGNAL; no signal saved.' RETURN ENDIF * Locate the matrices. ISDIR=MATSLT(NINT(ARG(2))) IF(NARG.GE.3)THEN ISCROS=MATSLT(NINT(ARG(3))) ELSE ISCROS=0 ENDIF IF(ISDIR.LE.0.OR.(NARG.GE.3.AND.ISCROS.LE.0))THEN PRINT *,' !!!!!! SIGCAL WARNING : Failure to'// - ' locate a signal vector; signal not saved.' RETURN ELSEIF(MLEN(ISDIR).NE.NTIME.OR. - (NARG.GE.3.AND.MLEN(ISCROS).NE.NTIME))THEN PRINT *,' !!!!!! SIGCAL WARNING : Signal vector'// - ' has wrong length; signal not saved.' RETURN ENDIF * Copy the signals. DO 20 I=1,NTIME SIGNAL(I,ISW,1)=MVEC(MORG(ISDIR)+I) IF(NARG.GE.3)SIGNAL(I,ISW,2)=MVEC(MORG(ISCROS)+I) TIMSIG(I)=TSTART+(I-1)*TDEV 20 CONTINUE *** Extract a raw signal. ELSEIF(IPROC.EQ.-73)THEN * Check argument list validity. IF(NARG.NE.6.OR.MODARG(1).NE.1.OR.MODARG(2).NE.2.OR. - MODARG(3).NE.2.OR.MODARG(4).NE.2.OR. - ARGREF(5,1).GE.2.OR.ARGREF(6,1).GE.2)THEN PRINT *,' !!!!!! SIGCAL WARNING : Incorrect argument'// - ' list for GET_RAW_SIGNAL; no signal returned.' RETURN ENDIF * Get the type. CALL STRBUF('READ',NINT(ARG(1)),TITLE,NC,IFAIL1) CALL CLTOU(TITLE(1:NC)) IF(TITLE(1:NC).EQ.'E-'.OR.TITLE(1:NC).EQ.'-'.OR. - TITLE(1:NC).EQ.'ELECTRON')THEN IQ=-1 ELSEIF(TITLE(1:NC).EQ.'ION'.OR.TITLE(1:NC).EQ.'+')THEN IQ=+1 ELSE PRINT *,' !!!!!! SIGCAL WARNING : Signal type '// - TITLE(1:NC)//' not known; assuming ION.' IQ=+1 ENDIF * Verify the sense wire number. ISW=NINT(ARG(2)) IF(ISW.LE.0.OR.ISW.GT.NSW)THEN PRINT *,' !!!!!! SIGCAL WARNING : Invalid electrode'// - ' number given to GET_RAW_SIGNAL;'// - ' no signal returned.' RETURN ENDIF * Verify the avalanche wire number. IW=NINT(ARG(3)) IF(IW.LE.0.OR.IW.GT.NWIRE)THEN PRINT *,' !!!!!! SIGCAL WARNING : Invalid avalanche'// - ' wire number given to GET_RAW_SIGNAL;'// - ' no signal returned.' RETURN ENDIF * Get the incidence angle. IA=NINT(NORIA*MOD(ARG(4)-2*PI*ANINT(ARG(4)/(2*PI))+2*PI, - 2*PI)/(2*PI)) IF(IA.EQ.0)IA=NORIA * Fetch the signal. CALL SIGIST('READ',NSIG,TIME,SIG,ISW,IW,IA,IQ,IFAIL1) IF(IFAIL1.NE.0.OR.NSIG.LE.0)THEN PRINT *,' !!!!!! SIGCAL WARNING : Requested signal'// - ' is not in store; no signal returned.' RETURN ENDIF * De-allocate the current arguments. CALL ALGREU(NINT(ARG(5)),MODARG(5),ARGREF(5,1)) CALL ALGREU(NINT(ARG(6)),MODARG(6),ARGREF(6,1)) * Allocate matrices. ISIZ(1)=NSIG CALL MATADM('ALLOCATE',IRTIM,1,ISIZ,2,IFAIL1) CALL MATADM('ALLOCATE',IRDIR,1,ISIZ,2,IFAIL2) ISTIM=MATSLT(IRTIM) ISDIR=MATSLT(IRDIR) IF(IFAIL1.NE.0.OR.IFAIL2.NE.0.OR.IFAIL3.NE.0.OR. - ISTIM.LE.0.OR.ISDIR.LE.0)THEN PRINT *,' !!!!!! SIGCAL WARNING : Failure to'// - ' allocate output matrices; signal not returned.' RETURN ENDIF * Copy the signals. DO 40 I=1,NSIG MVEC(MORG(ISTIM)+I)=TIME(I) MVEC(MORG(ISDIR)+I)=SIG(I) 40 CONTINUE * And save the matrices. ARG(5)=IRTIM MODARG(5)=5 ARG(6)=IRDIR MODARG(6)=5 *** List the raw signals. ELSEIF(IPROC.EQ.-74)THEN IF(NARG.NE.0)PRINT *,' !!!!!! SIGCAL WARNING :'// - ' LIST_RAW_SIGNALS doesn''t have arguments.' CALL SIGIST('LIST',NSIG,TIME,SIG,ISW,IW,IA,IQ,IFAIL1) *** Compute the weighting field. ELSEIF(IPROC.EQ.-75)THEN * Check number of arguments. IF(NARG.NE.6)THEN PRINT *,' !!!!!! SIGCAL WARNING : Incorrect number'// - ' of arguments for WEIGHTING_FIELD.' RETURN * Check argument mode. ELSEIF((MODARG(1).NE.2.AND.MODARG(1).NE.5).OR. - (MODARG(2).NE.2.AND.MODARG(2).NE.5).OR. - MODARG(6).NE.2)THEN PRINT *,' !!!!!! SIGCAL WARNING : Some arguments of'// - ' WEIGHTING_FIELD are of incorrect type.' RETURN * Check the the results can be transferred back. ELSEIF(ARGREF(3,1).GE.2.OR.ARGREF(4,1).GE.2.OR. - ARGREF(5,1).GE.2)THEN PRINT *,' !!!!!! SIGCAL WARNING : Some arguments'// - ' of WEIGHTING_FIELD can not be modified.' RETURN ENDIF * Get sense wire number etc. ISW=NINT(ARG(6)) IF(ISW.LE.0.OR.ISW.GT.NSW)THEN PRINT *,' !!!!!! SIGCAL WARNING : Sense wire'// - ' number out of range.' RETURN ENDIF * Variables already in use ? CALL ALGREU(NINT(ARG(3)),MODARG(3),ARGREF(3,1)) CALL ALGREU(NINT(ARG(4)),MODARG(4),ARGREF(4,1)) CALL ALGREU(NINT(ARG(5)),MODARG(5),ARGREF(5,1)) ** Carry out the calculation for scalar coordinates. IF(MODARG(1).EQ.2.AND.MODARG(2).EQ.2)THEN CALL SIGFLS(ARG(1),ARG(2),0.0,EX,EY,EZ,ISW) ARG(3)=EX ARG(4)=EY ARG(5)=EZ MODARG(3)=2 MODARG(4)=2 MODARG(5)=2 ** At least one of them is a matrix. ELSE * Figure out what the dimensions are. NDAT=-1 DO 30 I=1,2 IF(MODARG(I).EQ.5)THEN IREF(I)=NINT(ARG(I)) ISLOT(I)=MATSLT(IREF(I)) IF(ISLOT(I).LE.0)THEN PRINT *,' !!!!!! SIGCAL WARNING : Unable'// - ' locate a input matrix.' RETURN ELSEIF(MMOD(ISLOT(I)).NE.2)THEN PRINT *,' !!!!!! SIGCAL WARNING : x Or y'// - ' matrix is of incorrect type.' RETURN ENDIF IF(NDAT.LT.0)THEN NDAT=MLEN(ISLOT(I)) DO 130 J=1,MDIM(ISLOT(I)) ISIZ(J)=MSIZ(ISLOT(I),J) 130 CONTINUE IDIM=MDIM(ISLOT(I)) ELSEIF(NDAT.NE.MLEN(ISLOT(I)))THEN PRINT *,' !!!!!! SIGCAL WARNING : x And y'// - ' have inconsistent lengths.' RETURN ENDIF ENDIF 30 CONTINUE IF(NDAT.LT.1)THEN PRINT *,' !!!!!! SIGCAL WARNING : Unable'// - ' to find an x or y matrix.' RETURN ENDIF * Now book matrices for the missing elements and initialise them. DO 60 I=1,2 IF(MODARG(I).NE.5)THEN CALL MATADM('ALLOCATE',IREF(I),IDIM,ISIZ,2,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! SIGCAL WARNING : Unable'// - ' to get a replacement matrix.' RETURN ENDIF ISLOT(I)=MATSLT(IREF(I)) IF(ISLOT(I).LE.0)THEN PRINT *,' !!!!!! SIGCAL WARNING : Unable'// - ' to locate a replacement matrix.' RETURN ENDIF DO 70 J=1,MLEN(ISLOT(I)) MVEC(MORG(ISLOT(I))+J)=ARG(I) 70 CONTINUE ENDIF 60 CONTINUE * Allocate the output arrays (Ewx, Ewy, Ewz). DO 140 I=4,6 CALL MATADM('ALLOCATE',IREF(I),IDIM,ISIZ,2,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! SIGCAL WARNING : Unable'// - ' to get an output matrix.' RETURN ENDIF 140 CONTINUE * And finally locate all matrices. DO 180 I=1,6 IF(I.EQ.3)GOTO 180 ISLOT(I)=MATSLT(IREF(I)) IF(ISLOT(I).LE.0)THEN PRINT *,' !!!!!! SIGCAL WARNING : Unable'// - ' to locate an input or output matrix.' RETURN ENDIF 180 CONTINUE * And compute the data. DO 90 I=1,NDAT CALL SIGFLS(MVEC(MORG(ISLOT(1))+I), - MVEC(MORG(ISLOT(2))+I),0.0,EX,EY,EZ,ISW) MVEC(MORG(ISLOT(4))+I)=EX MVEC(MORG(ISLOT(5))+I)=EY MVEC(MORG(ISLOT(6))+I)=EZ 90 CONTINUE ARG(3)=IREF(4) ARG(4)=IREF(5) ARG(5)=IREF(6) MODARG(3)=5 MODARG(4)=5 MODARG(5)=5 * Delete temporary input matrices. DO 120 I=1,2 IF(MODARG(I).NE.5)THEN ISIZ(1)=NDAT CALL MATADM('DELETE',IREF(I),1,ISIZ,2,IFAIL1) IF(IFAIL1.NE.0)PRINT *,' !!!!!! SIGCAL WARNING'// - ' : Unable to delete a replacement matrix.' ENDIF 120 CONTINUE ENDIF *** Compute the weighting field in 3 dimensions. ELSEIF(IPROC.EQ.-76)THEN * Check number of arguments. IF(NARG.NE.7)THEN PRINT *,' !!!!!! SIGCAL WARNING : Incorrect number'// - ' of arguments for WEIGHTING_FIELD_3.' RETURN * Check argument mode. ELSEIF((MODARG(1).NE.2.AND.MODARG(1).NE.5).OR. - (MODARG(2).NE.2.AND.MODARG(2).NE.5).OR. - (MODARG(3).NE.2.AND.MODARG(3).NE.5).OR. - MODARG(7).NE.2)THEN PRINT *,' !!!!!! SIGCAL WARNING : Some arguments of'// - ' WEIGHTING_FIELD_3 are of incorrect type.' RETURN * Check the the results can be transferred back. ELSEIF(ARGREF(4,1).GE.2.OR.ARGREF(5,1).GE.2.OR. - ARGREF(6,1).GE.2)THEN PRINT *,' !!!!!! SIGCAL WARNING : Some arguments'// - ' of WEIGHTING_FIELD_3 can not be modified.' RETURN ENDIF * Get sense wire number etc. ISW=NINT(ARG(7)) IF(ISW.LE.0.OR.ISW.GT.NSW)THEN PRINT *,' !!!!!! SIGCAL WARNING : Sense wire'// - ' number out of range.' RETURN ENDIF * Variables already in use ? 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)) ** Carry out the calculation for scalar coordinates. IF(MODARG(1).EQ.2.AND.MODARG(2).EQ.2.AND.MODARG(3).EQ.2)THEN CALL SIGFLS(ARG(1),ARG(2),ARG(3),EX,EY,EZ,ISW) ARG(4)=EX ARG(5)=EY ARG(6)=EZ MODARG(4)=2 MODARG(5)=2 MODARG(6)=2 ** At least one of them is a matrix. ELSE * Figure out what the dimensions are. NDAT=-1 DO 220 I=1,3 IF(MODARG(I).EQ.5)THEN IREF(I)=NINT(ARG(I)) ISLOT(I)=MATSLT(IREF(I)) IF(ISLOT(I).LE.0)THEN PRINT *,' !!!!!! SIGCAL WARNING : Unable'// - ' locate a input matrix.' RETURN ELSEIF(MMOD(ISLOT(I)).NE.2)THEN PRINT *,' !!!!!! SIGCAL WARNING : x, y'// - ' Or z matrix is of incorrect type.' RETURN ENDIF IF(NDAT.LT.0)THEN NDAT=MLEN(ISLOT(I)) DO 230 J=1,MDIM(ISLOT(I)) ISIZ(J)=MSIZ(ISLOT(I),J) 230 CONTINUE IDIM=MDIM(ISLOT(I)) ELSEIF(NDAT.NE.MLEN(ISLOT(I)))THEN PRINT *,' !!!!!! SIGCAL WARNING : x, y'// - ' And z have inconsistent lengths.' RETURN ENDIF ENDIF 220 CONTINUE IF(NDAT.LT.1)THEN PRINT *,' !!!!!! SIGCAL WARNING : Unable'// - ' to find an x, y or z matrix.' RETURN ENDIF * Now book matrices for the missing elements and initialise them. DO 240 I=1,3 IF(MODARG(I).NE.5)THEN CALL MATADM('ALLOCATE',IREF(I),IDIM,ISIZ,2,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! SIGCAL WARNING : Unable'// - ' to get a replacement matrix.' RETURN ENDIF ISLOT(I)=MATSLT(IREF(I)) IF(ISLOT(I).LE.0)THEN PRINT *,' !!!!!! SIGCAL WARNING : Unable'// - ' to locate a replacement matrix.' RETURN ENDIF DO 250 J=1,MLEN(ISLOT(I)) MVEC(MORG(ISLOT(I))+J)=ARG(I) 250 CONTINUE ENDIF 240 CONTINUE * Allocate the output arrays (Ewx, Ewy, Ewz). DO 260 I=4,6 CALL MATADM('ALLOCATE',IREF(I),IDIM,ISIZ,2,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! SIGCAL WARNING : Unable'// - ' to get an output matrix.' RETURN ENDIF 260 CONTINUE * And finally locate all matrices. DO 270 I=1,6 ISLOT(I)=MATSLT(IREF(I)) IF(ISLOT(I).LE.0)THEN PRINT *,' !!!!!! SIGCAL WARNING : Unable'// - ' to locate an input or output matrix.' RETURN ENDIF 270 CONTINUE * And compute the data. DO 280 I=1,NDAT CALL SIGFLS(MVEC(MORG(ISLOT(1))+I), - MVEC(MORG(ISLOT(2))+I), - MVEC(MORG(ISLOT(3))+I), - EX,EY,EZ,ISW) MVEC(MORG(ISLOT(4))+I)=EX MVEC(MORG(ISLOT(5))+I)=EY MVEC(MORG(ISLOT(6))+I)=EZ 280 CONTINUE ARG(4)=IREF(4) ARG(5)=IREF(5) ARG(6)=IREF(6) MODARG(4)=5 MODARG(5)=5 MODARG(6)=5 * Delete temporary input matrices. DO 310 I=1,3 IF(MODARG(I).NE.5)THEN ISIZ(1)=NDAT CALL MATADM('DELETE',IREF(I),1,ISIZ,2,IFAIL1) IF(IFAIL1.NE.0)PRINT *,' !!!!!! SIGCAL WARNING'// - ' : Unable to delete a replacement matrix.' ENDIF 310 CONTINUE ENDIF *** Induced charge. ELSEIF(IPROC.EQ.-77)THEN IF((NARG.NE.6.AND.NARG.NE.8).OR. - MODARG(1).NE.2.OR.MODARG(2).NE.2.OR.MODARG(3).NE.2.OR. - (NARG.EQ.8.AND.(MODARG(6).NE.2.OR.MODARG(7).NE.2)).OR. - MODARG(4).NE.1.OR.MODARG(5).NE.2)THEN PRINT *,' !!!!!! SIGCAL WARNING : Incorrect argument'// - ' list for INDUCED_CHARGE; not executed.' RETURN ELSEIF(ARGREF(NARG,1).GE.2)THEN PRINT *,' !!!!!! SIGCAL WARNING : An argument of'// - ' INDUCED_CHARGE can not be modified.' RETURN ENDIF * Fetch particle type. CALL STRBUF('READ',NINT(ARG(4)),TITLE,NC,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! SIGCAL WARNING : Error retrieving'// - ' the INDUCED_CHARGE particle type.' RETURN ENDIF IF(NC.GE.1)CALL CLTOU(TITLE(1:NC)) * Decode it. IF(TITLE(1:NC).EQ.'ELECTRON'.OR.TITLE(1:NC).EQ.'E-')THEN JTYPE=1 QDRIFT=-1 ELSEIF(TITLE(1:NC).EQ.'POSITRON'.OR.TITLE(1:NC).EQ.'E+')THEN JTYPE=1 QDRIFT=+1 ELSEIF(TITLE(1:NC).EQ.'ION'.OR.TITLE(1:NC).EQ.'ION+')THEN JTYPE=2 QDRIFT=+1 ELSEIF(TITLE(1:NC).EQ.'ION-')THEN JTYPE=2 QDRIFT=-1 ELSE PRINT *,' !!!!!! SIGCAL WARNING : Unknown particle'// - ' type received by INDUCED_CHARGE.' RETURN ENDIF * Pick up the electrode number. ISW=NINT(ARG(5)) IF(ISW.LE.0.OR.ISW.GT.NSW)THEN PRINT *,' !!!!!! SIGCAL WARNING : INDUCED_CHARGE'// - ' received an invalid group number.' RETURN ENDIF * Delete old contents of return variable. CALL ALGREU(NINT(ARG(NARG)),MODARG(NARG),ARGREF(NARG,1)) * Compute the drift line. CALL DLCALC(ARG(1),ARG(2),ARG(3),QDRIFT,JTYPE) * Time limits. IF(NARG.EQ.6)THEN TMIN=TU(1) TMAX=TU(NU) ELSE TMIN=ARG(6) TMAX=ARG(7) ENDIF * Compute the induced charge. CALL SIGQIN(ARG(NARG),ISW,TMIN,TMAX) MODARG(NARG)=2 *** Add a signal. ELSEIF(IPROC.EQ.-78)THEN * Check argument list. IF(NARG.GE.2.OR.(NARG.EQ.1.AND.MODARG(1).NE.1))THEN PRINT *,' !!!!!! SIGCAL WARNING : Incorrect argument'// - ' list received for ADD_SIGNALS; not called.' RETURN ENDIF * Fetch options. IF(NARG.GE.1)THEN CALL STRBUF('READ',NINT(ARG(1)),TITLE,NC,IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! SIGCAL WARNING : Error'// - ' retrieving the ADD_SIGNALS options.' RETURN ENDIF IF(NC.GE.1)CALL CLTOU(TITLE(1:NC)) ELSE TITLE='CROSS' NC=5 ENDIF * Call the procedure. IF(INDEX(TITLE(1:NC),'DIRECT')+ - INDEX(TITLE(1:NC),'NOCROSS').NE.0)THEN CALL SIGADS(.FALSE.,IFAIL1) ELSE CALL SIGADS(.TRUE.,IFAIL1) ENDIF * Check return code. IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! SIGCAL WARNING : Error computing'// - ' or adding a signal; signal incomplete.' RETURN ENDIF *** 3D MC drift line calculation for electrons with avalanche. ELSEIF(IPROC.EQ.-79)THEN ** Check number of arguments. IF(NARG.LT.3.OR. - (NARG.GE.4.AND.MODARG(4).NE.1).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.NARG.NE.2*(NARG/2)).OR. - NARG.GT.6+2*MXAHIS)THEN PRINT *,' !!!!!! SIGCAL WARNING : Incorrect list of'// - ' arguments for AVALANCHE; not executed' RETURN * Make sure there are drift velocities. ELSEIF(.NOT.GASOK(1))THEN PRINT *,' !!!!!! SIGCAL WARNING : The drift velocity'// - ' for electrons is not defined ; not executed.' RETURN * Make sure there are Townsend coefficients. ELSEIF(.NOT.GASOK(4))THEN PRINT *,' !!!!!! SIGCAL WARNING : The Townsend'// - ' coefficient is not defined ; not executed.' RETURN ENDIF ** Fetch the option string. IF(NARG.GE.4)THEN CALL STRBUF('READ',NINT(ARG(4)),OPT,NCOPT,IFAIL1) CALL CLTOU(OPT(1:NCOPT)) ELSE OPT=' ' NCOPT=1 ENDIF ** Liberate storage associated with the electron and ion count. 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)) ** Create the entry point for the histogram formulae. IF(NARG.GE.7)THEN * Initialise the usage list. STAT(1)=.FALSE. STAT(2)=.FALSE. STAT(3)=.FALSE. STAT(4)=.FALSE. * Establish the variable list. IF(POLAR)THEN VARLIS(1)= 'R_CREATED' VARLIS(5)= 'R_LOST' VARLIS(9)= 'R_E' VARLIS(13)='R_ION' VARLIS(2)= 'PHI_CREATED' VARLIS(6)= 'PHI_LOST' VARLIS(10)='PHI_E' VARLIS(14)='PHI_ION' ELSE VARLIS(1)= 'X_CREATED' VARLIS(5)= 'X_LOST' VARLIS(9)= 'X_E' VARLIS(13)='X_ION' VARLIS(2)= 'Y_CREATED' VARLIS(6)= 'Y_LOST' VARLIS(10)='Y_E' VARLIS(14)='Y_ION' ENDIF VARLIS(3)= 'Z_CREATED' VARLIS(7)= 'Z_LOST' VARLIS(11)='Z_E' VARLIS(15)='Z_ION' VARLIS(4)= 'T_CREATED' VARLIS(8)= 'T_LOST' VARLIS(12)='T_E' VARLIS(16)='T_ION' * Number of histograms. NHIST=NARG/2-3 * Loop over the histograms. DO 100 I=1,NHIST * Fetch the histogram string. CALL STRBUF('READ',NINT(ARG(5+2*I)),TITLE,NC,IFAIL1) IF(IFAIL1.NE.0.OR.NC.LT.1)THEN PRINT *,' !!!!!! SIGCAL WARNING : Unable to get'// - ' an histogram formula; no avalanche.' RETURN ENDIF CALL CLTOU(TITLE(1:NC)) * Translate the formula. CALL ALGPRE(TITLE(1:NC),NC,VARLIS,16,NREXP,USE, - IENTRY(I),IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! SIGCAL WARNING : The histogram'// - ' function '//TITLE(1:NC)//' can not be'// - ' translated; no avalanche.' CALL ALGCLR(IENTRY(I)) RETURN ELSEIF(NREXP.LT.1.OR.NREXP.GT.2)THEN PRINT *,' !!!!!! SIGCAL WARNING : The histogram'// - ' function '//TITLE(1:NC)//' does not'// - ' return 1 or 2 results; no avalanche.' CALL ALGCLR(IENTRY(I)) RETURN ENDIF ITYPE(2,I)=NREXP * Work out which quantities are to be computed. ITYPE(1,I)=0 IF((USE( 1).OR.USE( 2).OR.USE( 3).OR.USE( 4)).AND. - ITYPE(1,I).NE.0)THEN PRINT *,' !!!!!! SIGCAL WARNING : Histogram'// - ' function '//TITLE(1:NC)//' uses an'// - ' invalid mix of parameters; no avalanche.' CALL ALGCLR(IENTRY(I)) RETURN ELSEIF(USE( 1).OR.USE( 2).OR.USE( 3).OR.USE( 4))THEN ITYPE(1,I)=1 ENDIF IF((USE( 5).OR.USE( 6).OR.USE( 7).OR.USE( 8)).AND. - ITYPE(1,I).NE.0)THEN PRINT *,' !!!!!! SIGCAL WARNING : Histogram'// - ' function '//TITLE(1:NC)//' uses an'// - ' invalid mix of parameters; no avalanche.' CALL ALGCLR(IENTRY(I)) RETURN ELSEIF(USE( 5).OR.USE( 6).OR.USE( 7).OR.USE( 8))THEN ITYPE(1,I)=2 ENDIF IF((USE( 9).OR.USE(10).OR.USE(11).OR.USE(12)).AND. - ITYPE(1,I).NE.0)THEN PRINT *,' !!!!!! SIGCAL WARNING : Histogram'// - ' function '//TITLE(1:NC)//' uses an'// - ' invalid mix of parameters; no avalanche.' CALL ALGCLR(IENTRY(I)) RETURN ELSEIF(USE( 9).OR.USE(10).OR.USE(11).OR.USE(12))THEN ITYPE(1,I)=3 ENDIF IF((USE(13).OR.USE(14).OR.USE(15).OR.USE(16)).AND. - ITYPE(1,I).NE.0)THEN PRINT *,' !!!!!! SIGCAL WARNING : Histogram'// - ' function '//TITLE(1:NC)//' uses an'// - ' invalid mix of parameters; no avalanche.' CALL ALGCLR(IENTRY(I)) RETURN ELSEIF(USE(13).OR.USE(14).OR.USE(15).OR.USE(16))THEN ITYPE(1,I)=4 ENDIF IF(ITYPE(1,I).EQ.0)THEN PRINT *,' !!!!!! SIGCAL WARNING : Histogram'// - ' function '//TITLE(1:NC)//' uses no'// - ' variables; no avalanche.' CALL ALGCLR(IENTRY(I)) RETURN ENDIF STAT(1)=STAT(1).OR.(ITYPE(1,I).EQ.1) STAT(2)=STAT(2).OR.(ITYPE(1,I).EQ.2) STAT(3)=STAT(3).OR.(ITYPE(1,I).EQ.3) STAT(4)=STAT(4).OR.(ITYPE(1,I).EQ.4) * Generate the histogram index list and check the number. IF(ARGREF(6+2*I,1).GE.2)THEN PRINT *,' !!!!!! SIGCAL WARNING : Histogram'// - ' argument ',I,' can not be modified;'// - ' no avalanche.' CALL ALGCLR(IENTRY(I)) RETURN ELSEIF(MODARG(6+2*I).EQ.4)THEN IHIST(I)=NINT(ARG(6+2*I)) ELSE CALL ALGREU(NINT(ARG(6+2*I)),MODARG(6+2*I), - ARGREF(6+2*I,1)) CALL HISADM('ALLOCATE',IHIST(I),100,0.0,0.0, - .TRUE.,IFAIL1) ENDIF 100 CONTINUE * No histograms to be made. ELSE STAT(1)=.FALSE. STAT(2)=.FALSE. STAT(3)=.FALSE. STAT(4)=.FALSE. NHIST=0 ENDIF ** Carry out the calculation. CALL SIGMCA(ARG(1),ARG(2),ARG(3),NETOT,NITOT, - STAT,NHIST,IHIST,ITYPE,IENTRY,OPT(1:NCOPT)) * Print algebra errors if there were any. CALL ALGERR ** Return the arguments and delete the instruction lists. IF(NARG.GE.5)THEN ARG(5)=REAL(NETOT) MODARG(5)=2 ENDIF IF(NARG.GE.6)THEN ARG(6)=REAL(NITOT) MODARG(6)=2 ENDIF DO 110 I=1,NHIST ARG(6+2*I)=REAL(IHIST(I)) MODARG(6+2*I)=4 CALL ALGCLR(IENTRY(I)) 110 CONTINUE *** Other signal calls not known. ELSE PRINT *,' !!!!!! SIGCAL WARNING : Invalid signal'// - ' procedure code received; nothing done.' RETURN ENDIF *** Seems to have worked. IFAIL=0 END +DECK,SIGWGT. SUBROUTINE SIGWGT *----------------------------------------------------------------------- * SIGWGT - Subroutine plotting the electric field, the magnetic field * and the potential in a variety of ways: histograms, contour * plots, vector plots and surface plots. * Variables : XPL,YPL : Used for plotting lines * FUNCT. : Stores the function text the plots * VAR : Array of input values for ALGEXE * GRID : Array of 'heights' for surface plots * COORD : Contains the ordinate of the graph data * VALUE : Contains the function values of the graph * HIST : Stores the histogram * CMIN,CMAX : Range of contour heights * HMIN,HMAX : Range in the histogram * NCHA : Number of bins in the histogram. * FLAG : Logicals used for parsing the command * LHIST ... : Determines whether the plot will be made * PHI,THETA : Viewing angle for 3-dimensional plots. * (Last changed on 29/ 3/01.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CONSTANTS. +SEQ,CELLDATA. +SEQ,GASDATA. +SEQ,PARAMETERS. +SEQ,GRAPHICS. +SEQ,PRINTPLOT. +SEQ,BFIELD. +SEQ,DRIFTLINE. +SEQ,SIGNALDATA. DOUBLE PRECISION QTMIN,QTMAX REAL COORD(MXLIST),VALUE(MXLIST),RES(5),VAR(MXVAR), - HMIN,HMAX,GRSMIN,GRSMAX,RT0,RT1,PT0,PT1,XPOS,YPOS,ZPOS, - FACNRM,CMIN,CMAX,QPLT,THETA,PHI,GMINR,GMAXR,QTMINR,QTMAXR, - HMINR,HMAXR,CMINR,CMAXR,XXPOS,YYPOS,VXMIN,VYMIN,VXMAX,VYMAX INTEGER NCHA,NCONT,NGRPNT,MODVAR(MXVAR),MODRES(5),NCTOT,ILOC, - ISURF,IVECT1,IVECT2,IVECT3,IHIST,IFLAT,ICHK,JCHK,IHISRF, - NREXP,I,J,ISW,ISWR,JSW, - INEXT,NWORD,IFAIL1,IFAIL2,NPNTR,NC1,NC2,NC3,NC4,NC5,II, - INPCMP,NCFTRA,ITYPE,IFAIL,IENTRA,ICOORD,NCHAR,NRES,NCAUX, - NCONTR,IENTRY,NCAUX1,NCAUX2,NCAUX3,NCAUX4,INPTYP,NDATA, - NCONTP,NCGR CHARACTER*(MXCHAR) STRING,FUNCT1,FUNCT2,FUNCT3,FUNCT4,FUNCT5, - FUNTRA CHARACTER*20 AUX1,AUX2,AUX3,AUX4,GROUP CHARACTER*10 VARLIS(MXVAR) LOGICAL USE(MXVAR),FLAG(MXWORD+5),EVALW,EVALB,EVALV,EVALE,EVALI, - EVALQ,EVALP,LHIST,LVECT,LGRAPH,LCONT,LSURF,CAUTO,HAUTO,CLAB, - LGRPRT,OK,LMCDR EXTERNAL INPCMP,INPTYP,SCONT1 COMMON /CN3DAT/ QTMIN,QTMAX,IENTRY,EVALW,EVALB,EVALV,EVALE,EVALI, - EVALQ,EVALP,QPLT,ITYPE,JSW,LMCDR +SELF,IF=NAG. DOUBLE PRECISION WS,DUM COMMON /MATRIX/ WS(MXWIRE,MXWIRE),CHTS(MXWIRE),DUM(3*MXWIRE+3) +SELF,IF=HIGZ. REAL WS(MXGRID,MXGRID),PAR(37),SMIN,SMAX +SELF,IF=SAVE. SAVE VARLIS,HMIN,HMAX,NCHA,NCONT,NGRPNT,PHI,THETA,LGRPRT +SELF. DATA (VARLIS(I),I=1,26) /'X ','Y ','EX ', - 'EY ','EZ ','E ','BX ', - 'BY ','BZ ','B ','VDX ', - 'VDY ','VDZ ','VD ','TIME_E ', - 'TIME_ION ','EWX ','EWY ','EWZ ', - 'EW ','Q_E ','Q_ION ','Z ', - 'STATUS_E ','STATUS_ION','T '/ DATA HMIN,HMAX /0.0,10000.0/ DATA NCONT/21/ DATA NGRPNT/MXLIST/,LGRPRT/.FALSE./ DATA NCHA/100/ DATA PHI,THETA/30.0,60.0/ *** Define an output format. 1010 FORMAT(26X,A10,L2,3X,A20,2X,I2,2(2X,E10.3),2(2X,I6),2(2X,E10.3)) *** Identify the routine. IF(LIDENT)PRINT *,' /// ROUTINE SIGWGT ///' *** If the first call, then we still have to prepare signal matrices. IF(.NOT.SIGSET)THEN CALL SIGINI(IFAIL1) IF(IFAIL1.NE.0)THEN PRINT *,' !!!!!! SIGWGT WARNING : Initialisation of'// - ' signal calculation failed; no signals.' RETURN ENDIF ENDIF *** Preset the options, function strings etc, FUNCT1=' ' FUNCT2=' ' FUNCT3=' ' FUNCT4=' ' FUNCT5=' ' LGRAPH=.FALSE. LSURF=.FALSE. LVECT=.FALSE. LHIST=.FALSE. LCONT=.FALSE. FUNTRA='?' NCFTRA=1 CMIN=VMIN CMAX=VMAX CAUTO=.TRUE. CLAB=.TRUE. HAUTO=.TRUE. GRSMIN=1 GRSMAX=-1 OK=.TRUE. LMCDR=.FALSE. QTMIN=-1.0D0 QTMAX=-1.0D0 *** Default sense wire number. ISW=-1 *** Make sure the variables have appropriate names IF(POLAR)THEN VARLIS(1)= 'R ' VARLIS(2)= 'PHI ' VARLIS(3)= 'ER ' VARLIS(4)= 'EPHI ' VARLIS(7)= 'BR ' VARLIS(8)= 'BPHI ' VARLIS(11)='VDR ' VARLIS(12)='VDPHI ' VARLIS(17)='EWR ' VARLIS(18)='EWPHI ' ELSE VARLIS(1)= 'X ' VARLIS(2)= 'Y ' VARLIS(3)= 'EX ' VARLIS(4)= 'EY ' VARLIS(7)= 'BX ' VARLIS(8)= 'BY ' VARLIS(11)='VDX ' VARLIS(12)='VDY ' VARLIS(17)='EWX ' VARLIS(18)='EWY ' ENDIF *** Examine the input, first step is finding out where the keywords are. CALL INPNUM(NWORD) DO 10 I=1,MXWORD+5 IF(I.EQ.1.OR.I.GT.NWORD)THEN FLAG(I)=.TRUE. ELSEIF(INPCMP(I,'A#NGLES')+INPCMP(I,'AUTO#MATIC')+ - INPCMP(I,'BI#NS')+INPCMP(I,'SC#ALE')+ - INPCMP(I,'PR#INT')+INPCMP(I,'NOPR#INT')+ - INPCMP(I,'C#ONTOUR')+INPCMP(I,'GR#APH')+ - INPCMP(I,'H#ISTOGRAM')+INPCMP(I,'N')+ - INPCMP(I,'LAB#ELS')+INPCMP(I,'NOLAB#ELS')+ - INPCMP(I,'RA#NGE')+INPCMP(I,'S#URFACE')+ - INPCMP(I,'VE#CTOR')+INPCMP(I,'ON')+ - INPCMP(I,'GROUP')+INPCMP(I,'S#ENSE-W#IRE')+ - INPCMP(I,'ELEC#TRODE')+ - INPCMP(I,'TIME-WIND#OW').NE.0)THEN FLAG(I)=.TRUE. ELSE FLAG(I)=.FALSE. ENDIF 10 CONTINUE *** Start a loop over the list, INEXT=1 DO 20 I=2,NWORD IF(I.LT.INEXT)GOTO 20 * warn if the user uses a sub-keyword out of context. IF(INPCMP(I,'RA#NGE')+INPCMP(I,'N')+INPCMP(I,'BI#NS')+ - INPCMP(I,'LAB#ELS')+INPCMP(I,'NOLAB#ELS')+ - INPCMP(I,'A#NGLES')+INPCMP(I,'AUTO#MATIC')+ - INPCMP(I,'PR#INT')+INPCMP(I,'NOPR#INT')+ - INPCMP(I,'ON')+INPCMP(I,'SC#ALE')+ - INPCMP(I,'M#ONTE-C#ARLO-#DRIFT-#LINES')+ - INPCMP(I,'MC-#DRIFT-#LINES')+ - INPCMP(I,'NOM#ONTE-C#ARLO-#DRIFT-#LINES')+ - INPCMP(I,'NOMC-#DRIFT-#LINES')+ - INPCMP(I,'RUN#GE-K#UTTA-#DRIFT-#LINES')+ - INPCMP(I,'RKF-#DRIFT-#LINES')+ - INPCMP(I,'S#ENSE-W#IRE')+INPCMP(I,'ELEC#TRODE')+ - INPCMP(I,'GROUP').NE.0)THEN CALL INPMSG(I,'Valid option out of context. ') OK=.FALSE. IF(.NOT.FLAG(I+1))THEN CALL INPMSG(I+1,'See the previous message. ') INEXT=I+2 IF(.NOT.FLAG(I+2))THEN CALL INPMSG(I+2,'See the previous messages. ') INEXT=I+3 ENDIF ENDIF * warn if an unknown keywords appear, ELSEIF(.NOT.FLAG(I))THEN CALL INPMSG(I,'Item is not a known keyword. ') OK=.FALSE. ** Find out whether a GRAPH is requested next, ELSEIF(INPCMP(I,'GR#APH').NE.0)THEN * Plot already requested ? IF(LGRAPH)PRINT *,' !!!!!! SIGWGT WARNING : Only one'// - ' graph per PLOT statement can be processed.' LGRAPH=.TRUE. * Store the function string. IF(FLAG(I+1))THEN FUNCT1(1:3)='Q_E' NC1=3 INEXT=I+1 ELSE CALL INPSTR(I+1,I+1,STRING,NC1) FUNCT1(1:NC1)=STRING(1:NC1) INEXT=I+2 ENDIF * Look for sub-keywords with GRAPH. DO 230 II=I,NWORD IF(II.LT.INEXT)GOTO 230 * Look for the subkeyword ON. IF(INPCMP(II,'ON').NE.0)THEN IF(FLAG(II+1))THEN CALL INPMSG(II,'The curve function is absent. ') OK=.FALSE. ELSE CALL INPSTR(II+1,II+1,FUNTRA,NCFTRA) INEXT=II+2 ENDIF * Look for the subkeyword N. ELSEIF(INPCMP(II,'N').NE.0)THEN IF(FLAG(II+1))THEN CALL INPMSG(II,'number of points is missing. ') OK=.FALSE. ELSE CALL INPCHK(II+1,1,IFAIL1) CALL INPRDI(II+1,NPNTR,NGRPNT) IF(NPNTR.LT.2.AND.IFAIL1.EQ.0)CALL INPMSG(II+1, - 'number of point less than 2. ') IF(NPNTR.GT.MXLIST.AND.IFAIL1.EQ.0)CALL INPMSG - (II+1,'number of points > MXLIST. ') IF(NPNTR.GE.2.AND.NPNTR.LE.MXLIST)THEN NGRPNT=NPNTR ELSE OK=.FALSE. ENDIF INEXT=II+2 ENDIF * Look for print options. ELSEIF(INPCMP(II,'PR#INT').NE.0)THEN LGRPRT=.TRUE. INEXT=II+1 ELSEIF(INPCMP(II,'NOPR#INT').NE.0)THEN LGRPRT=.FALSE. INEXT=II+1 * Scale of the graph. ELSEIF(INPCMP(II,'SC#ALE')+INPCMP(II,'RA#NGE').NE.0)THEN IF(FLAG(II+1).OR.FLAG(II+2))THEN CALL INPMSG(II,'the arguments are missing. ') OK=.FALSE. ELSE CALL INPCHK(II+1,2,IFAIL1) CALL INPRDR(II+1,GMINR,+1.0) CALL INPCHK(II+2,2,IFAIL2) CALL INPRDR(II+2,GMAXR,-1.0) IF(GMINR.EQ.GMAXR)THEN CALL INPMSG(II+1,'zero range in the') CALL INPMSG(II+2,'scale not permitted') OK=.FALSE. ELSE GRSMIN=MIN(GMINR,GMAXR) GRSMAX=MAX(GMINR,GMAXR) ENDIF INEXT=II+3 ENDIF * Otherwise skip to the next keyword. ELSE GOTO 20 ENDIF 230 CONTINUE ** Find out whether a CONTOUR plot is requested next, ELSEIF(INPCMP(I,'C#ONTOUR').NE.0)THEN IF(LCONT)PRINT *,' !!!!!! SIGWGT WARNING : Only one'// - ' contour plot per PLOT statement can be processed.' LCONT=.TRUE. * Store the function string, using the default if absent. IF(FLAG(I+1))THEN FUNCT2(1:3)='Q_E' NC2=3 INEXT=I+1 ELSE CALL INPSTR(I+1,I+1,STRING,NC2) FUNCT2(1:NC2)=STRING(1:NC2) INEXT=I+2 ENDIF * Set default values for the range, depending on the function. CMIN=0.0 CMAX=10000.0 * Look for sub-keywords with CONTOUR. DO 210 II=I+1,NWORD IF(II.LT.INEXT)GOTO 210 * LABELing of the contours. IF(INPCMP(II,'LAB#ELS').NE.0)THEN CLAB=.TRUE. INEXT=II+1 ELSEIF(INPCMP(II,'NOLAB#ELS').NE.0)THEN CLAB=.FALSE. INEXT=II+1 * The RANGE subkeyword. ELSEIF(INPCMP(II,'RA#NGE').NE.0)THEN IF(INPCMP(II+1,'AUTO#MATIC').NE.0)THEN CMIN=0.0 CMAX=0.0 CAUTO=.TRUE. INEXT=II+2 ELSEIF((.NOT.FLAG(II+1)).AND.FLAG(II+2))THEN CALL INPCHK(II+1,2,IFAIL1) CALL INPRDR(II+1,CMINR,CMIN) CMIN=CMINR CMAX=CMINR CAUTO=.FALSE. INEXT=II+2 ELSEIF((.NOT.FLAG(II+1)).AND.(.NOT.FLAG(II+2)))THEN CALL INPCHK(II+1,2,IFAIL1) CALL INPCHK(II+2,2,IFAIL2) CALL INPRDR(II+1,CMINR,CMIN) CALL INPRDR(II+2,CMAXR,CMAX) CMIN=MIN(CMINR,CMAXR) CMAX=MAX(CMINR,CMAXR) CAUTO=.FALSE. INEXT=II+3 ELSE CALL INPMSG(II,'RANGE takes two arguments. ') OK=.FALSE. IF(FLAG(II+1))THEN INEXT=II+1 ELSE CALL INPMSG(II+1, - 'Ignored, see previous message.') INEXT=II+2 ENDIF ENDIF * Sub keyword N. ELSEIF(INPCMP(II,'N').NE.0)THEN IF(FLAG(II+1))THEN CALL INPMSG(II,'N must have an argument. ') OK=.FALSE. INEXT=II+1 ELSE CALL INPCHK(II+1,1,IFAIL1) CALL INPRDI(II+1,NCONTR,NCONT) IF(NCONTR.LT.0.AND.IFAIL1.EQ.0)CALL INPMSG(II+1, - 'number of contour steps is < 0') IF(NCONTR.GT.MXWIRE.AND.IFAIL1.EQ.0)CALL INPMSG - (II+1,'may not exceed MXWIRE. ') IF(NCONTR.GE.0.AND.NCONTR.LE.MXWIRE)THEN NCONT=NCONTR ELSE OK=.FALSE. ENDIF INEXT=II+2 ENDIF * Otherwise skip to the next keyword. ELSE GOTO 20 ENDIF 210 CONTINUE ** A SURFACE (3 dimensional plot) has perhaps been requested, ELSEIF(INPCMP(I,'S#URFACE').NE.0)THEN IF(LSURF)PRINT *,' !!!!!! SIGWGT WARNING : Only one'// - ' surface per PLOT statement can be processed.' LSURF=.TRUE. IF(FLAG(I+1))THEN FUNCT3(1:3)='Q_E' NC3=3 INEXT=I+1 ELSE CALL INPSTR(I+1,I+1,STRING,NC3) FUNCT3(1:NC3)=STRING(1:NC3) INEXT=I+2 ENDIF * Look for sub-keywords with SURFACE. DO 220 II=I,NWORD IF(II.LT.INEXT)GOTO 220 * Look for the subkeyword ANGLE. IF(INPCMP(II,'A#NGLES').NE.0)THEN IF(.NOT.FLAG(II+1).AND.FLAG(II+2))THEN CALL INPMSG(II,'ANGLE has 2 args: theta, phi. ') CALL INPMSG(II+1,'See the previous message. ') INEXT=II+2 OK=.FALSE. ELSEIF(FLAG(II+1))THEN CALL INPMSG(II,'ANGLE has 2 args: theta, phi. ') INEXT=II+1 OK=.FALSE. ELSE CALL INPCHK(II+1,2,IFAIL1) CALL INPRDR(II+1,PHI,30.0) CALL INPCHK(II+2,2,IFAIL1) CALL INPRDR(II+2,THETA,60.0) INEXT=II+3 ENDIF * Otherwise skip to the next keyword. ELSE GOTO 20 ENDIF 220 CONTINUE ** A vector plot. ELSEIF(INPCMP(I,'VE#CTOR').NE.0)THEN IF(LVECT)PRINT *,' !!!!!! SIGWGT WARNING : Only one'// - ' vector plot per PLOT statement can be processed.' LVECT=.TRUE. IF(FLAG(I+1).OR.FLAG(I+2))THEN IF(.NOT.POLAR)THEN FUNCT4(1:11)='EWX,EWY,EWZ' NC4=11 ELSE FUNCT4(1:13)='EWR,EWPHI,EWZ' NC4=13 ENDIF IF(.NOT.FLAG(I+1).AND.FLAG(I+2))THEN CALL INPSTR(I+1,I+1,STRING,NCAUX) IF(INDEX(STRING(1:NCAUX),'@').NE.0)THEN FUNCT4(1:1)='@' NC4=1 ELSE CALL INPMSG(I+1, - 'Has 2 or 3 args, default used.') OK=.FALSE. ENDIF INEXT=I+2 ELSE INEXT=I+1 ENDIF ELSE CALL INPSTR(I+1,I+1,STRING,NC4) FUNCT4(1:NC4+1)=STRING(1:NC4)//',' CALL INPSTR(I+2,I+2,STRING,NCAUX) FUNCT4(NC4+2:NC4+NCAUX+2)=STRING(1:NCAUX)//',' NC4=NC4+NCAUX+2 IF(.NOT.FLAG(I+3))THEN CALL INPSTR(I+3,I+3,STRING,NCAUX) FUNCT4(NC4+1:NC4+NCAUX)=STRING(1:NCAUX) NC4=NC4+NCAUX INEXT=I+4 ELSE FUNCT4(NC4+1:NC4+1)='0' NC4=NC4+1 INEXT=I+3 ENDIF ENDIF ** Finally, find out whether the next plot is a HISTOGRAM. ELSEIF(INPCMP(I,'H#ISTOGRAM').NE.0)THEN IF(LHIST)PRINT *,' !!!!!! SIGWGT WARNING : Only one'// - ' histogram per PLOT statement can be processed.' LHIST=.TRUE. IF(FLAG(I+1))THEN FUNCT5(1:3)='Q_E' NC5=3 HMIN=0.0 HMAX=10000.0 INEXT=I+1 ELSE CALL INPSTR(I+1,I+1,STRING,NC5) FUNCT5(1:NC5)=STRING(1:NC5) INEXT=I+2 ENDIF * Look for subkeywords associated with HISTOGRAM. DO 200 II=I,NWORD IF(II.LT.INEXT)GOTO 200 * The RANGE subkeyword. IF(INPCMP(II,'RA#NGE').NE.0)THEN IF(INPCMP(II+1,'AUTO#MATIC').NE.0)THEN HMIN=0.0 HMAX=0.0 HAUTO=.TRUE. INEXT=II+2 ELSEIF(.NOT.FLAG(II+1).AND..NOT.FLAG(II+2))THEN CALL INPCHK(II+1,2,IFAIL1) CALL INPCHK(II+2,2,IFAIL2) CALL INPRDR(II+1,HMINR,HMIN) CALL INPRDR(II+2,HMAXR,HMAX) HAUTO=.FALSE. IF(HMINR.EQ.HMAXR)THEN CALL INPMSG(II+1, - 'Zero range not permitted. ') CALL INPMSG(II+2, - 'See the previous message. ') OK=.FALSE. ELSE HMIN=MIN(HMINR,HMAXR) HMAX=MAX(HMINR,HMAXR) ENDIF INEXT=II+3 ELSE CALL INPMSG(II,'RANGE takes two arguments. ') OK=.FALSE. IF(FLAG(II+1))THEN INEXT=II+1 ELSE CALL INPMSG(II+1, - 'Ignored, see previous message.') INEXT=II+2 ENDIF ENDIF * The BINS subkeyword. ELSEIF(INPCMP(II,'BI#NS').NE.0)THEN IF(FLAG(II+1))THEN CALL INPMSG(II,'This keyword has one argument.') INEXT=II+1 ELSE CALL INPCHK(II+1,1,IFAIL) CALL INPRDI(II+1,NCHAR,MXCHA) IF(NCHAR.LE.1.OR.NCHAR.GT.MXCHA)THEN CALL INPMSG(II+1, - 'Inacceptable number of bins. ') OK=.FALSE. ELSE NCHA=NCHAR ENDIF INEXT=II+2 ENDIF * Otherwise quit this loop. ELSE GOTO 20 ENDIF 200 CONTINUE * Sense wire number. ELSEIF(INPCMP(I,'S#ENSE-W#IRE')+ - INPCMP(I,'ELEC#TRODE')+ - INPCMP(I,'GROUP').NE.0)THEN IF(INPCMP(I+1,'ALL').NE.0)THEN ISW=-1 ELSEIF(INPTYP(I+1).NE.1)THEN CALL INPMSG(I,'Has an integer argument.') OK=.FALSE. ELSE CALL INPCHK(I+1,1,IFAIL1) CALL INPRDI(I+1,ISWR,1) IF(ISWR.LE.0.OR.ISWR.GT.NSW)THEN CALL INPMSG(I+1,'Not a valid sense wire') OK=.FALSE. ELSE ISW=ISWR ENDIF INEXT=I+2 ENDIF * Time window. ELSEIF(INPCMP(I,'TIME-WIND#OW').NE.0)THEN IF(FLAG(I+1).OR.FLAG(I+2))THEN CALL INPMSG(I,'the arguments are missing. ') OK=.FALSE. ELSE IF(INPCMP(I+1,'START').NE.0)THEN QTMINR=-1.0 ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPRDR(I+1,QTMINR,-1.0) IF(IFAIL1.NE.0)THEN OK=.FALSE. QTMINR=-1.0 ELSEIF(QTMINR.LT.0)THEN CALL INPMSG(I+1,'Start time is < 0.') OK=.FALSE. QTMINR=-1.0 ENDIF ENDIF IF(INPCMP(I+2,'INF#INITY')+INPCMP(I+2,'END').NE.0)THEN QTMAXR=-1.0 ELSE CALL INPCHK(I+2,2,IFAIL2) CALL INPRDR(I+2,QTMAXR,-1.0) IF(IFAIL2.NE.0)THEN OK=.FALSE. QTMAXR=-1.0 ELSEIF(QTMAXR.LT.0)THEN CALL INPMSG(I+2,'End time is < 0.') QTMAXR=-1.0 OK=.FALSE. ELSEIF(QTMINR.GE.0.AND.QTMAXR.LE.QTMINR)THEN CALL INPMSG(I+2,'Is ahead of start time.') QTMAXR=-1.0 OK=.FALSE. ENDIF ENDIF QTMIN=QTMINR QTMAX=QTMAXR INEXT=I+3 ENDIF * Drift algorithm. ELSEIF(INPCMP(I,'M#ONTE-C#ARLO-#DRIFT-#LINES')+ - INPCMP(I,'MC-#DRIFT-#LINES').NE.0)THEN LMCDR=.TRUE. ELSEIF(INPCMP(I,'NOM#ONTE-C#ARLO-#DRIFT-#LINES')+ - INPCMP(I,'NOMC-#DRIFT-#LINES')+ - INPCMP(I,'RUN#GE-K#UTTA-#DRIFT-#LINES')+ - INPCMP(I,'RKF-#DRIFT-#LINES').NE.0)THEN LMCDR=.FALSE. ** Warn if the user aks for an unknown plot type or makes an error, ELSE CALL INPMSG(I,'Should have been a plot type. ') OK=.FALSE. ENDIF 20 CONTINUE *** Print error messages. CALL INPERR * Ensure that we got some reasonable settings. IF(NSW.LE.0)THEN PRINT *,' !!!!!! SIGWGT WARNING : No sense wire has'// - ' been selected.' RETURN ENDIF * Proceed or not ? IF(JFAIL.EQ.2.AND..NOT.OK)THEN PRINT *,' !!!!!! SIGWGT WARNING : Instruction is not'// - ' carried out because of the above errors.' RETURN ELSEIF(JFAIL.EQ.3.AND..NOT.OK)THEN PRINT *,' ###### SIGWGT ERROR : Program terminated'// - ' because of the above errors.' CALL QUIT ENDIF *** Next print the list of plots if the DEBUG option is on. IF(LDEBUG)THEN WRITE(LUNOUT,'( - '' ++++++ SIGWGT DEBUG : List of requested plots:''/ - '' Type Y/N '', - ''Function (1:20) NC <--------Range-------> '', - ''# cont # bins <-------Angle-------->'')') IF(LGRAPH)THEN WRITE(LUNOUT,'(26X,A10,L2,3X,A20,1X,I3,34X,I6)') - 'Graph ',LGRAPH,FUNCT1(1:20),NC1,NGRPNT ELSE WRITE(LUNOUT,'(26X,A10,L2)') 'Graph ',LGRAPH ENDIF IF(LCONT.AND..NOT.CAUTO)THEN WRITE(LUNOUT, - '(26X,A7,3X,L2,3X,A20,1X,I3,2(2X,E10.3),2X,I6)') - 'Contour',LCONT,FUNCT2(1:20),NC2,CMIN,CMAX,NCONT ELSEIF(LCONT.AND.CAUTO)THEN WRITE(LUNOUT,'(26X,A7,3X,L2,3X,A20,1X,I3, - '' Automatic scaling'',2X,I6)') - 'Contour',LCONT,FUNCT2(1:20),NC2,NCONT ELSE WRITE(LUNOUT,'(26X,A10,L2)') 'Contour ',LCONT ENDIF IF(LSURF)THEN WRITE(LUNOUT, - '(26X,A10,L2,3X,A20,1X,I3,40X,2(2X,E10.3))') - 'Surface ',LSURF,FUNCT3(1:20),NC3,PHI,THETA ELSE WRITE(LUNOUT,'(26X,A10,L2)') 'Surface ',LSURF ENDIF IF(LVECT)THEN WRITE(LUNOUT,'(26X,A10,L2,3X,A20,1X,I3)') - 'Vector ',LVECT ,FUNCT4(1:20),NC4 ELSE PRINT '(26X,A10,L2)','Vector ',LVECT ENDIF IF(LHIST.AND..NOT.HAUTO)THEN WRITE(LUNOUT, - '(26X,A10,L2,3X,A20,1X,I3,2(2X,E10.3),10X,I6)') - 'Histogram ',LHIST ,FUNCT5(1:20),NC5, - HMIN,HMAX,NCHA ELSEIF(LHIST)THEN WRITE(LUNOUT,'(26X,A10,L2,3X,A20,1X,I3, - '' Automatic scaling'',10X,I6)') - 'Histogram ',LHIST ,FUNCT5(1:20),NC5,NCHA ELSE WRITE(LUNOUT,'(26X,A10,L2)') 'Histogram ',LHIST ENDIF WRITE(LUNOUT,'('' ++++++ SIGWGT DEBUG : Selected sense'', - '' wire: '',I4/)') ISW WRITE(LUNOUT,'('' ++++++ SIGWGT DEBUG : Time window '', - 2E15.8)') QTMIN,QTMAX ENDIF *** Loop over the sense wires. DO 40 JSW=1,NSW IF(ISW.NE.-1.AND.ISW.NE.JSW)GOTO 40 IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ SIGWGT DEBUG : Sense'', - '' wire group '',I3)') JSW * Prepare a group label. CALL OUTFMT(REAL(JSW),2,AUX1,NCAUX1,'LEFT') GROUP=' (Group '//AUX1(1:NCAUX1)//')' NCGR=9+NCAUX1 *** Take care of the 'GRAPH' type plots, translate curve function. IF(LGRAPH.AND.FUNTRA(1:NCFTRA).NE.'?')THEN CALL ALGPRE(FUNTRA,NCFTRA,VARLIS(26),1,NRES,USE(26), - IENTRA,IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! SIGWGT WARNING : Graph not made'// - ' because of an error in the track function.' CALL ALGCLR(IENTRA) GOTO 101 ELSEIF(NRES.NE.3)THEN PRINT *,' !!!!!! SIGWGT WARNING : Graph not made'// - ' because the curve does not give 3 results.' CALL ALGCLR(IENTRA) GOTO 101 ELSEIF(.NOT.USE(26))THEN PRINT *,' !!!!!! SIGWGT WARNING : Graph not made'// - ' because the track does not depend on T.' CALL ALGCLR(IENTRA) GOTO 101 ENDIF * If no curve is defined, the track must be. ELSEIF(LGRAPH.AND..NOT.TRFLAG(1))THEN PRINT *,' !!!!!! SIGWGT WARNING : Neither a track nor'// - ' a curve has been defined ; graph not made.' GOTO 101 ENDIF * Parameters look a priori acceptable. IF(LGRAPH)THEN * Transform the function into an instruction list, IF(INDEX(FUNCT1(1:NC1),'@').NE.0)THEN NRES=1 CALL ALGEDT(VARLIS,25,IENTRY,USE,NRES) FUNCT1='Edited function' NC1=15 ELSE CALL ALGPRE(FUNCT1,NC1,VARLIS,25,NRES,USE,IENTRY,IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! SIGWGT WARNING : Graph not'// - ' produced because of syntax errors.' GOTO 100 ENDIF ENDIF * Be sure only one result is returned. IF(NRES.NE.1)THEN PRINT *,' !!!!!! SIGWGT WARNING : The function'// - ' does not return precisely 1 result; no graph.' GOTO 100 ENDIF * Figure out which quatities are effectively used. EVALW=.FALSE. EVALB=.FALSE. EVALV=.FALSE. EVALE=.FALSE. EVALI=.FALSE. EVALQ=.FALSE. EVALP=.FALSE. IF(USE(17).OR.USE(18).OR.USE(19).OR.USE(20))EVALW=.TRUE. IF(USE( 7).OR.USE( 8).OR.USE( 9).OR.USE(10))EVALB=.TRUE. IF(USE(11).OR.USE(12).OR.USE(13).OR.USE(14))EVALV=.TRUE. IF(USE(15).OR.USE(21).OR.USE(24))EVALE=.TRUE. IF(USE(16).OR.USE(22).OR.USE(25))EVALI=.TRUE. IF(USE(21))EVALQ=.TRUE. IF(USE(22))EVALP=.TRUE. * check the use of magnetic field quantities, IF(EVALB.AND..NOT.MAGOK)THEN PRINT *,' !!!!!! SIGWGT WARNING : The function to be'// - ' plotted uses magnetic field quantities,' PRINT *,' no such field has'// - ' been defined however ; plot not made.' GOTO 100 ENDIF IF((USE(7).OR.USE(8)).AND.POLAR)THEN PRINT *,' !!!!!! SIGWGT WARNING : Bx and By should'// - ' not be used with polar cells ; plot not made.' GOTO 100 ENDIF * Select the axis with the largest range for ordinate. IF(FUNTRA(1:NCFTRA).NE.'?')THEN ICOORD=3 ELSEIF(POLAR)THEN CALL CFMCTP(XT0,YT0,RT0,PT0,1) CALL CFMCTP(XT1,YT1,RT1,PT1,1) IF((ZT1-ZT0)**2.GT.(XT1-XT0)**2+(YT1-YT0)**2)THEN ICOORD=11 ELSEIF(ABS(RT0-RT1).GT.ABS(PT0-PT1))THEN ICOORD=1 ELSE ICOORD=2 ENDIF ELSE IF((ZT1-ZT0)**2.GT.(XT1-XT0)**2+(YT1-YT0)**2)THEN ICOORD=11 ELSEIF(ABS(XT0-XT1).GT.ABS(YT0-YT1))THEN ICOORD=1 ELSE ICOORD=2 ENDIF ENDIF * Print a heading for the numbers. IF(FUNTRA(1:NCFTRA).EQ.'?')THEN IF(LGRPRT)WRITE(LUNOUT,'(/'' GRAPH OF '',A, - '' ON '',A//2X,''Coordinate'',48X,''Function'')') - FUNCT1(1:NC1),'THE TRACK' ELSE IF(LGRPRT)WRITE(LUNOUT,'(/'' GRAPH OF '',A, - '' ON '',A//2X,''Coordinate'',48X,''Function'')') - FUNCT1(1:NC1),FUNTRA(1:NCFTRA) ENDIF * Fill the vectors, ITYPE=1 QPLT=-1.0 DO 30 I=1,NGRPNT IF(ICOORD.NE.3)THEN XPOS=XT0+REAL(I-1)*(XT1-XT0)/REAL(NGRPNT-1) YPOS=YT0+REAL(I-1)*(YT1-YT0)/REAL(NGRPNT-1) ZPOS=ZT0+REAL(I-1)*(ZT1-ZT0)/REAL(NGRPNT-1) IF(POLAR)CALL CFMCTR(XPOS,YPOS,XPOS,YPOS,1) ELSE VAR(1)=REAL(I-1)/REAL(NGRPNT-1) MODVAR(1)=2 CALL ALGEXE(IENTRA,VAR,MODVAR,1,RES,MODRES,3,IFAIL) XPOS=RES(1) YPOS=RES(2) ZPOS=RES(3) IF(POLAR)CALL CFMPTR(XPOS,YPOS,XPOS,YPOS,1,IFAIL1) IF(IFAIL1.NE.0)THEN XPOS=1.0 YPOS=0.0 ZPOS=0.0 PRINT *,' !!!!!! SIGWGT WARNING : The curve'// - ' function returns invalid coordinates.' ENDIF ENDIF CALL SCONT2(XPOS,YPOS,ZPOS,RES,MODRES,1,ILOC) IF(ICOORD.EQ.3)THEN COORD(I)=REAL(I-1)/REAL(NGRPNT-1) ELSEIF(ICOORD.EQ.2)THEN COORD(I)=YPOS ELSEIF(ICOORD.EQ.11)THEN COORD(I)=ZPOS ELSE COORD(I)=XPOS ENDIF VALUE(I)=RES(1) * Print the point if this has been requested. IF(LGRPRT)WRITE(LUNOUT,'(4(2X,E15.8))') - XPOS,YPOS,ZPOS,VALUE(I) 30 CONTINUE * Plot the graph. IF(GRSMIN.LT.GRSMAX)CALL GRGRSC(GRSMIN,GRSMAX) IF(ICOORD.EQ.3)THEN CALL GRGRPH(COORD,VALUE,NGRPNT,'Curve parameter', - FUNCT1(1:NC1),'Graph of '//FUNCT1(1:NC1)// - GROUP(1:NCGR)) ELSEIF(POLAR.AND.ICOORD.EQ.1)THEN CALL GRGRPH(COORD,VALUE,NGRPNT,'Radius [cm]', - FUNCT1(1:NC1),'Graph of '//FUNCT1(1:NC1)// - GROUP(1:NCGR)) ELSEIF(POLAR.AND.ICOORD.EQ.2)THEN CALL GRGRPH(COORD,VALUE,NGRPNT,'Angle [degrees]', - FUNCT1(1:NC1),'Graph of '//FUNCT1(1:NC1)// - GROUP(1:NCGR)) ELSEIF((.NOT.POLAR).AND.ICOORD.EQ.1)THEN CALL GRGRPH(COORD,VALUE,NGRPNT,'x-Axis [cm]', - FUNCT1(1:NC1),'Graph of '//FUNCT1(1:NC1)// - GROUP(1:NCGR)) ELSEIF((.NOT.POLAR).AND.ICOORD.EQ.2)THEN CALL GRGRPH(COORD,VALUE,NGRPNT,'y-Axis [cm]', - FUNCT1(1:NC1),'Graph of '//FUNCT1(1:NC1)// - GROUP(1:NCGR)) ELSEIF((.NOT.POLAR).AND.ICOORD.EQ.11)THEN CALL GRGRPH(COORD,VALUE,NGRPNT,'z-Axis [cm]', - FUNCT1(1:NC1),'Graph of '//FUNCT1(1:NC1)// - GROUP(1:NCGR)) ELSE PRINT *,' ###### SIGWGT ERROR : Inconsistent axis'// - ' selection ; program bug - please report.' ENDIF IF(GASID.NE.' ')CALL GRCOMM(2,'Gas: '//GASID) * Log this frame and prepare for the next plot. CALL GRNEXT CALL GRALOG('Graph of '//FUNCT1(1:NC1)//GROUP(1:NCGR)//':') CALL TIMLOG('Plotting the graph of '//FUNCT1(1:NC1)// - GROUP(1:NCGR)//':') * print the number of arithmetic errors. CALL ALGERR 100 CONTINUE * Release the entry points. CALL ALGCLR(IENTRY) IF(FUNTRA(1:NCFTRA).NE.'?')CALL ALGCLR(IENTRA) ENDIF * Continue here if the parameters were not acceptable. 101 CONTINUE *** Take care of the contours. IF(LCONT)THEN * Convert to an instruction list, IF(INDEX(FUNCT2(1:NC2),'@').NE.0)THEN NRES=1 CALL ALGEDT(VARLIS,25,IENTRY,USE,NRES) FUNCT2='Edited function' NC2=15 ELSE CALL ALGPRE(FUNCT2,NC2,VARLIS,25,NRES,USE,IENTRY,IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! SIGWGT WARNING : No contour'// - ' plot because of function syntax errors.' GOTO 110 ENDIF ENDIF * Be sure only one result is returned. IF(NRES.NE.1)THEN PRINT *,' !!!!!! SIGWGT WARNING : The function does'// - ' not return precisely 1 result; no contour.' GOTO 110 ENDIF * Figure out which quatities are effectively used. EVALW=.FALSE. EVALB=.FALSE. EVALV=.FALSE. EVALE=.FALSE. EVALI=.FALSE. EVALQ=.FALSE. EVALP=.FALSE. IF(USE(17).OR.USE(18).OR.USE(19).OR.USE(20))EVALW=.TRUE. IF(USE( 7).OR.USE( 8).OR.USE( 9).OR.USE(10))EVALB=.TRUE. IF(USE(11).OR.USE(12).OR.USE(13).OR.USE(14))EVALV=.TRUE. IF(USE(15).OR.USE(21).OR.USE(24))EVALE=.TRUE. IF(USE(16).OR.USE(22).OR.USE(25))EVALI=.TRUE. IF(USE(21))EVALQ=.TRUE. IF(USE(22))EVALP=.TRUE. * Check the use of magnetic field quantities. IF(EVALB.AND..NOT.MAGOK)THEN PRINT *,' !!!!!! SIGWGT WARNING : The function to be'// - ' plotted uses magnetic field quantities,' PRINT *,' no such field has'// - ' been defined however ; plot not made.' GOTO 110 ENDIF IF((USE(7).OR.USE(8)).AND.POLAR)THEN PRINT *,' !!!!!! SIGWGT WARNING : Bx and By should'// - ' not be used with polar cells ; plot not made.' GOTO 110 ENDIF * Set electrons. ITYPE=1 QPLT=-1.0 * Plot the contours. CALL GRCELL(VXMIN,VYMIN,VXMAX,VYMAX, - 'Contours of '//FUNCT2(1:NC2)//GROUP(1:NCGR)) IF(GASID.NE.' ')CALL GRCOMM(2,'Gas: '//GASID) NCONTP=NCONT CALL GRCONT(SCONT1,CMIN,CMAX,VXMIN,VYMIN,VXMAX,VYMAX, - NCONTP,CAUTO,POLAR,CLAB) CALL GRNEXT * Print the table of contour heights. CALL OUTFMT(CMIN,2,AUX1,NCAUX1,'LEFT') CALL OUTFMT(CMAX,2,AUX2,NCAUX2,'LEFT') CALL OUTFMT(REAL(NCONTP),2,AUX3,NCAUX3,'LEFT') CALL OUTFMT((CMAX-CMIN)/REAL(MAX(1,NCONTP)),2, - AUX4,NCAUX4,'LEFT') IF(NCONTP.GE.1)WRITE(LUNOUT,'(/'' The contours'', - '' correspond to '',A,'' = '',A,'' to '',A, - '' in '',A,'' steps.''/'' The interval between 2'', - '' contours is '',A,''.'')') - FUNCT2(1:NC2),AUX1(1:NCAUX1),AUX2(1:NCAUX2), - AUX3(1:NCAUX3),AUX4(1:NCAUX4) IF(NCONTP.EQ.0)WRITE(LUNOUT,'(/'' The contour'', - '' corresponds to '',A,'' = '',A,''.'')') - FUNCT2(1:NC2),AUX1(1:NCAUX1) * Keep track of the plots being made. CALL GRALOG('Contours of '//FUNCT2(1:NC2)// - GROUP(1:NCGR)//':') CALL TIMLOG('Plotting contours of '//FUNCT2(1:NC2)// - GROUP(1:NCGR)//':') * Print the number of arithmetic errors. CALL ALGERR 110 CONTINUE CALL ALGCLR(IENTRY) ENDIF *** If one of the other plots is asked for, prepare the function string. IF(LHIST.OR.LSURF.OR.LVECT)THEN NCTOT=0 IF(LSURF)THEN ISURF=1 FUNCT1(1:NC3)=FUNCT3(1:NC3) NCTOT=NC3 ENDIF IF(LVECT)THEN IF(LSURF)THEN IVECT1=2 IVECT2=3 IVECT3=4 FUNCT1(NCTOT+1:NCTOT+NC4+1)=','//FUNCT4(1:NC4) NCTOT=NCTOT+NC4+1 ELSE IVECT1=1 IVECT2=2 IVECT3=3 FUNCT1(1:NC4)=FUNCT4(1:NC4) NCTOT=NC4 ENDIF ENDIF IF(LHIST)THEN IF(LSURF.OR.LVECT)THEN IF(LSURF.AND..NOT.LVECT)IHIST=2 IF(LVECT.AND..NOT.LSURF)IHIST=4 IF(LSURF.AND. LVECT)IHIST=5 FUNCT1(NCTOT+1:NCTOT+NC5+1)=','//FUNCT5(1:NC5) NCTOT=NCTOT+NC5+1 ELSE IHIST=1 FUNCT1(1:NC5)=FUNCT5(1:NC5) NCTOT=NC5 ENDIF ENDIF * Turn it into an instruction list, NREXP=0 IF(LHIST)NREXP=NREXP+1 IF(LSURF)NREXP=NREXP+1 IF(LVECT)NREXP=NREXP+3 IF(INDEX(FUNCT1(1:NCTOT),'@').NE.0)THEN NRES=NREXP CALL ALGEDT(VARLIS,25,IENTRY,USE,NRES) FUNCT1='Edited function' NCTOT=15 ELSE CALL ALGPRE(FUNCT1,NCTOT,VARLIS,25,NRES,USE,IENTRY, - IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! SIGWGT WARNING : Plots not'// - ' produced because of syntax errors.' GOTO 120 ENDIF ENDIF * Be sure the right number of result is returned. IF(NRES.NE.NREXP)THEN PRINT *,' !!!!!! SIGWGT WARNING : The function does'// - ' not return the correct number of results;'// - ' histogram, surface and vector plot skipped.' GOTO 120 ENDIF * Figure out which quatities are effectively used. EVALW=.FALSE. EVALB=.FALSE. EVALV=.FALSE. EVALE=.FALSE. EVALI=.FALSE. EVALQ=.FALSE. EVALP=.FALSE. IF(USE(17).OR.USE(18).OR.USE(19).OR.USE(20))EVALW=.TRUE. IF(USE( 7).OR.USE( 8).OR.USE( 9).OR.USE(10))EVALB=.TRUE. IF(USE(11).OR.USE(12).OR.USE(13).OR.USE(14))EVALV=.TRUE. IF(USE(15).OR.USE(21).OR.USE(24))EVALE=.TRUE. IF(USE(16).OR.USE(22).OR.USE(25))EVALI=.TRUE. IF(USE(21))EVALQ=.TRUE. IF(USE(22))EVALP=.TRUE. * check the use of magnetic field quantities, IF(EVALB.AND..NOT.MAGOK)THEN PRINT *,' !!!!!! SIGWGT WARNING : The function to be'// - ' plotted uses magnetic field quantities,' PRINT *,' no such field has'// - ' been defined however ; plot not made.' GOTO 120 ENDIF IF((USE(7).OR.USE(8)).AND.POLAR)THEN PRINT *,' !!!!!! SIGWGT WARNING : Bx and By should'// - ' not be used with polar cells ; plot not made.' GOTO 120 ENDIF +SELF,IF=NAG. * Obtain the matrix for surface plotting. IF(LSURF)THEN CALL BOOK('BOOK','MATRIX','SURFACE',IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! SIGWGT WARNING : Unable to'// - ' obtain storage for the surface plot.' PRINT *,' The plot'// - ' will not be made.' LSURF=.FALSE. ENDIF ENDIF +SELF. * Open a plotting frame for a VECTOR plot, if requested. IF(LVECT)THEN CALL GRCELL(VXMIN,VYMIN,VXMAX,VYMAX, - 'Vector plot of '//FUNCT4(1:NC4)//GROUP(1:NCGR)) CALL GRALOG('Vector plot of '//FUNCT4(1:NC4)// - GROUP(1:NCGR)//':') * Otherwise, merely request the viewing area. ELSE CALL GRVIEW(VXMIN,VYMIN,VXMAX,VYMAX) ENDIF * Add labels. IF(GASID.NE.' ')CALL GRCOMM(2,'Gas: '//GASID) * Allocate an histogram, if needed. IF(LHIST)THEN CALL HISADM('ALLOCATE',IHISRF,NCHA,HMIN,HMAX, - HAUTO,IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! SIGWGT WARNING : Unable to'// - ' allocate histogram storage; histogram'// - ' cancelled.' LHIST=.FALSE. ENDIF ENDIF * Set representation for the vector plot. IF(LVECT)CALL GRATTS('FUNCTION-1','POLYLINE') * Set electrons. ITYPE=1 QPLT=-1.0 * Fill all the arrays and matrices required for these plots. NDATA=0 DO 50 I=1,NGRIDX IF(.NOT.POLAR)THEN XXPOS=VXMIN+REAL(I-1)*(VXMAX-VXMIN)/REAL(NGRIDX-1) ELSE XXPOS=LOG(EXP(VXMIN)+REAL(I-1)*(EXP(VXMAX)-EXP(VXMIN))/ - REAL(NGRIDX-1)) ENDIF * set a normalisation factor, to get the arrows more or less right IF(.NOT.POLAR)THEN FACNRM=MIN(VYMAX-VYMIN,VXMAX-VXMIN)/REAL(NGRIDX) ELSE FACNRM=LOG((EXP(VXMIN)+REAL(I-1)*(EXP(VXMAX)- - EXP(VXMIN))/REAL(NGRIDX))/(EXP(VXMIN)+REAL(I)* - (EXP(VXMAX)-EXP(VXMIN))/REAL(NGRIDX))) ENDIF DO 60 J=1,NGRIDY YYPOS=VYMIN+REAL(J-1)*(VYMAX-VYMIN)/REAL(NGRIDY-1) * Coordinate transformation to the viewing plane. XPOS=FPROJ(1,1)*XXPOS+FPROJ(2,1)*YYPOS+FPROJ(3,1) YPOS=FPROJ(1,2)*XXPOS+FPROJ(2,2)*YYPOS+FPROJ(3,2) ZPOS=FPROJ(1,3)*XXPOS+FPROJ(2,3)*YYPOS+FPROJ(3,3) * Compute the formulae. CALL SCONT2(XPOS,YPOS,ZPOS,RES,MODRES,5,ILOC) +SELF,IF=NAG,HIGZ. * Preset the surface to 0. IF(LSURF)WS(I,J)=0.0 +SELF. * Check location code. IF(ILOC.NE.0)GOTO 60 NDATA=NDATA+1 * Vector plot plotting. IF(LVECT)THEN IF(RES(IVECT1)**2+RES(IVECT2)**2+RES(IVECT3)**2.GT.0) - CALL PLAARR(XPOS,YPOS,ZPOS, - 0.5*FACNRM*RES(IVECT1)/SQRT(RES(IVECT1)**2+ - RES(IVECT2)**2+RES(IVECT3)**2), - 0.5*FACNRM*RES(IVECT2)/SQRT(RES(IVECT1)**2+ - RES(IVECT2)**2+RES(IVECT3)**2), - 0.5*FACNRM*RES(IVECT3)/SQRT(RES(IVECT1)**2+ - RES(IVECT2)**2+RES(IVECT3)**2)) ENDIF * Fill the histogram, if requested, IF(LHIST)CALL HISENT(IHISRF,RES(IHIST),1.0) +SELF,IF=NAG,HIGZ. * Fill the surface plot, if requested. IF(LSURF)WS(I,J)=RES(ISURF) +SELF. 60 CONTINUE 50 CONTINUE * Close the vector plot. CALL TIMLOG('Accumulating plot data on the grid: ') IF(LVECT)CALL GRNEXT * Verify data count. IF(NDATA.EQ.0)THEN CALL ALGERR PRINT *,' !!!!!! SIGWGT WARNING : Viewing plane grid'// - ' has no points in the drift medium; no surface'// - ' or histogram.' GOTO 120 ENDIF * Plot the 3-dimensional picture if requested IF(LSURF)THEN +SELF,IF=NAG. * Check that the surface is not flat. IFLAT=1 DO 80 ICHK=1,NGRIDX DO 70 JCHK=1,NGRIDY IF(ABS(WS(ICHK,JCHK)-WS(1,1)).GT.1.0E-5* - (1.0+ABS(WS(ICHK,JCHK))+ABS(WS(1,1))))IFLAT=0 70 CONTINUE 80 CONTINUE IF(IFLAT.NE.0)THEN PRINT *,' !!!!!! SIGWGT WARNING : The surface is', - ' not plotted because it is entirely flat.' CALL BOOK('RELEASE','MATRIX','SURFACE',IFAIL) GOTO 90 ENDIF * Switch the screen to graphics mode. CALL GRGRAF(.TRUE.) * Store the CH eXPansion, NAG has the nasty habit of changing it. CALL GQCHXP(IERR,CHEXP) IF(IERR.NE.0)CHEXP=1.0 * Initialize NAG. CALL X04AAF(1,10) CALL J06WAF CALL J06WCF(0.1D0,0.9D0,0.1D0,0.9D0) CALL J06WBF(0.0D0,1.0D0,0.0D0,1.0D0,1) IFAIL=0 IF(POLAR)THEN CALL J06HCF(WS,MXWIRE,NGRIDX,NGRIDY,DBLE(THETA), - DBLE(PHI),'Along a radius', - 'Increasing angle',IFAIL) ELSE CALL J06HCF(WS,MXWIRE,NGRIDX,NGRIDY,DBLE(THETA), - DBLE(PHI),'u-axis','v-axis',IFAIL) ENDIF CALL GRNEXT * Reset the CH eXPension factor to the original value, CALL GSCHXP(CHEXP) CALL TIMLOG('Making a 3D plot of '//FUNCT3(1:NC3)// - GROUP(1:NCGR)//':') CALL GRALOG('3-D plot of '//FUNCT3(1:NC3)// - GROUP(1:NCGR)//':') +SELF,IF=HIGZ. * Check that the surface is not flat. IFLAT=1 SMIN=WS(1,1) SMAX=WS(1,1) DO 80 ICHK=1,NGRIDX DO 70 JCHK=1,NGRIDY IF(ABS(WS(ICHK,JCHK)-WS(1,1)).GT.1.0E-5* - (1.0+ABS(WS(ICHK,JCHK))+ABS(WS(1,1))))IFLAT=0 SMIN=MIN(SMIN,WS(1,1)) SMAX=MAX(SMAX,WS(1,1)) 70 CONTINUE 80 CONTINUE IF(IFLAT.NE.0)THEN PRINT *,' !!!!!! SIGWGT WARNING : The surface is', - ' not plotted because it is entirely flat.' GOTO 90 ENDIF * Switch the screen to graphics mode. CALL GRGRAF(.TRUE.) * Fill the PAR vector. PAR(1)=THETA PAR(2)=PHI PAR(3)=VXMIN PAR(4)=VXMAX PAR(5)=VYMIN PAR(6)=VYMAX PAR(7)=SMIN PAR(8)=SMAX PAR(9)=1000+NGRIDX PAR(10)=1000+NGRIDY PAR(11)=510 PAR(12)=510 PAR(13)=510 PAR(14)=1 PAR(15)=1 PAR(16)=1 PAR(17)=0.02 PAR(18)=0.02 PAR(19)=0.02 PAR(20)=0.03 PAR(21)=2 PAR(22)=0.03 PAR(23)=0.03 PAR(24)=0.03 PAR(25)=7 PAR(26)=8 PAR(27)=9 PAR(28)=10 PAR(29)=11 PAR(30)=12 PAR(31)=13 PAR(32)=14 PAR(33)=15 PAR(34)=16 PAR(35)=17 PAR(36)=18 PAR(37)=19 * Plot the surface. CALL ISVP(1,0.1,0.9,0.1,0.9) CALL ISWN(1,0.0,1.0,0.0,1.0) CALL ISELNT(1) CALL IGTABL(MXGRID,MXGRID,WS,37,PAR,'S1') * Add labels. IF(GASID.NE.' ')CALL GRCOMM(2,'Gas: '//GASID) * Plot the title. CALL GSELNT(0) CALL GSTXAL(0,0) CALL GSCHUP(0.0,1.0) CALL GRATTS('TITLE','TEXT') CALL GRTX(0.1,0.95,'Surface of '//FUNCT3(1:NC3)// - GROUP(1:NCGR)) * Close the plot. CALL GRNEXT * Record what happened. CALL TIMLOG('Making a 3D plot of '//FUNCT3(1:NC3)// - GROUP(1:NCGR)//':') CALL GRALOG('3-D plot of '//FUNCT3(1:NC3)// - GROUP(1:NCGR)//':') +SELF,IF=-NAG,IF=-HIGZ. * No graphics system present to plot the surface. PRINT *,' !!!!!! SIGWGT WARNING : The plotting system', - ' used for this module has no SURFACE facilities.' +SELF. 90 CONTINUE ENDIF * plot the histogram if requested, delete after use. IF(LHIST)THEN CALL HISPLT(IHISRF,FUNCT5(1:NC5), - 'Histogram of '//FUNCT5(1:NC5)// - GROUP(1:NCGR),.TRUE.) IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) IF(GASID.NE.' ')CALL GRCOMM(2,'Gas: '//GASID) CALL GRNEXT CALL GRALOG('Histogram of '//FUNCT5(1:NC5)// - GROUP(1:NCGR)//':') CALL TIMLOG('Plotting an histogram of '// - FUNCT5(1:NC5)//GROUP(1:NCGR)//':') CALL HISADM('DELETE',IHISRF,0,0.0,0.0,.FALSE.,IFAIL) ENDIF * print the number of arithmetic errors. CALL ALGERR 120 CONTINUE * release the algebra storage. CALL ALGCLR(IENTRY) ENDIF *** Next sense wire. 40 CONTINUE END +DECK,SCONT1. SUBROUTINE SCONT1(X0,Y0,FVAL,ILOC) *----------------------------------------------------------------------- * SCONT1 - Returns the function value to the contour routine * (Last changed on 4/11/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,PARAMETERS. REAL RES(1),X0,Y0,FVAL,XPOS,YPOS,ZPOS INTEGER MODRES(1),ILOC,NRES *** Compute the true space coordinates. XPOS=FPROJ(1,1)*X0+FPROJ(2,1)*Y0+FPROJ(3,1) YPOS=FPROJ(1,2)*X0+FPROJ(2,2)*Y0+FPROJ(3,2) ZPOS=FPROJ(1,3)*X0+FPROJ(2,3)*Y0+FPROJ(3,3) *** Set expected number of results. NRES=1 *** Evaluate the function. CALL SCONT2(XPOS,YPOS,ZPOS,RES,MODRES,NRES,ILOC) *** Return the result. FVAL=RES(1) END +DECK,SCONT2. SUBROUTINE SCONT2(X0,Y0,Z0,RES,MODRES,NRES,ILOC) *----------------------------------------------------------------------- * SCONT2 - Performs formula evaluations for the signal field plots. * (Last changed on 14/ 6/99.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,DRIFTLINE. +SEQ,PRINTPLOT. INTEGER NRES,MODRES(NRES),MODVAR(MXVAR),ILOC,ILOC1, - IENTRY,ITYPE,I,IFAIL,JSW REAL RES(NRES),VAR(MXVAR),QPLT,X0,Y0,Z0,VOLT,EX,EY,EZ DOUBLE PRECISION F0(3),QTMIN,QTMAX,QQTMIN,QQTMAX LOGICAL EVALW,EVALB,EVALV,EVALE,EVALI,EVALQ,EVALP,LMCDR COMMON /CN3DAT/ QTMIN,QTMAX,IENTRY,EVALW,EVALB,EVALV,EVALE,EVALI, - EVALQ,EVALP,QPLT,ITYPE,JSW,LMCDR *** Verify that we are in the drift area. IF(X0.LT.DXMIN.OR.X0.GT.DXMAX.OR. - Y0.LT.DYMIN.OR.Y0.GT.DYMAX.OR. - Z0.LT.DZMIN.OR.Z0.GT.DZMAX)THEN ILOC=-1 RETURN ENDIF *** Store the coordinates. VAR(1)= X0 VAR(2)= Y0 VAR(23)=Z0 *** Always calculate the E field for verification purposes. CALL EFIELD(VAR(1),VAR(2),VAR(23),VAR(3),VAR(4),VAR(5),VAR(6), - VOLT,0,ILOC) * Location code -5 (in a material) can be acceptable. IF(ILOC.EQ.-5.AND.LCNTAM)ILOC=0 * For other non-zero locations return. IF(ILOC.NE.0)THEN DO 10 I=1,NRES RES(I)=0 MODRES(I)=0 10 CONTINUE RETURN ENDIF *** Calculate the B field. IF(EVALB)CALL BFIELD(VAR(1),VAR(2),VAR(23), - VAR(7),VAR(8),VAR(9),VAR(10)) *** Compute the local drift velocity. IF(EVALV)THEN CALL DLCVEL(DBLE(VAR(1)),DBLE(VAR(2)),DBLE(VAR(23)), - F0,QPLT,ITYPE,ILOC1) VAR(11)=REAL(F0(1)) VAR(12)=REAL(F0(2)) VAR(13)=REAL(F0(3)) VAR(14)=REAL(SQRT(F0(1)**2+F0(2)**2+F0(3)**2)) ENDIF *** Calculate the Ew field. IF(EVALW)THEN CALL SIGFLS(VAR(1),VAR(2),VAR(23),EX,EY,EZ,JSW) * Assign the results. VAR(17)=EX VAR(18)=EY VAR(19)=EZ VAR(20)=SQRT(EX**2+EY**2+EZ**2) ENDIF *** Electron drift line related quantities. IF(EVALE)THEN * Set electron parameters. QPLT=-1.0 ITYPE=1 * Compute the drift line. IF(LMCDR)THEN CALL DLCMC(VAR(1),VAR(2),VAR(23),QPLT,ITYPE) ELSE CALL DLCALC(VAR(1),VAR(2),VAR(23),QPLT,ITYPE) ENDIF * Time and status. VAR(15)=TU(NU) VAR(24)=ISTAT * Induced charge. IF(EVALQ)THEN IF(QTMIN.LT.0)THEN QQTMIN=TU(1) ELSE QQTMIN=QTMIN ENDIF IF(QTMAX.LT.0)THEN QQTMAX=TU(NU) ELSE QQTMAX=QTMAX ENDIF CALL SIGQIN(VAR(21),JSW,QQTMIN,QQTMAX) ENDIF ENDIF *** Ion drift line related quantities. IF(EVALI)THEN * Set ion parameters. QPLT=+1.0 ITYPE=2 * Compute the drift line. CALL DLCALC(VAR(1),VAR(2),VAR(23),QPLT,ITYPE) * Time and status. VAR(16)=TU(NU) VAR(25)=ISTAT * Induced charge. IF(EVALP)CALL SIGQIN(VAR(22),JSW,TU(1),TU(NU)) ENDIF *** Transform vectors and covectors to polar coordinates if needed. IF(POLAR)THEN CALL CFMRTP(VAR(1),VAR(2),VAR(1),VAR(2),1) VAR(3)=VAR(3)/VAR(1) VAR(4)=VAR(4)/VAR(1) VAR(6)=SQRT(VAR(3)**2+VAR(4)**2+VAR(5)**2) VAR(17)=VAR(17)/VAR(1) VAR(18)=VAR(18)/VAR(1) VAR(20)=SQRT(VAR(17)**2+VAR(18)**2+VAR(19)**2) VAR(11)=VAR(11)*VAR(1) VAR(12)=VAR(12)*VAR(1) VAR(14)=SQRT(VAR(11)**2+VAR(12)**2+VAR(13)**2) ENDIF *** Assign modes. DO 100 I=1,25 MODVAR(I)=2 100 CONTINUE *** Evaluate the function CALL ALGEXE(IENTRY,VAR,MODVAR,25,RES,MODRES,NRES,IFAIL) END +DECK,SIGQIN. SUBROUTINE SIGQIN(QTOT,ISW,TMIN,TMAX) *----------------------------------------------------------------------- * SIGQIN - Integrates the induced charge over a drift line. * (Last changed on 18/11/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,DRIFTLINE. +SEQ,CELLDATA. DOUBLE PRECISION F1(3),F2(3),F3(3),AUX(1),DGMLT1, - DMEAN,XMID,YMID,ZMID,TABTIM,TABLAM,TMIN,TMAX,TIMIN,TIMAX REAL QTOT,DRES,EX1,EY1,EZ1,EX2,EY2,EZ2,EX3,EY3,EZ3 INTEGER ILOC1,ILOC2,ILOC3,IU,IWIRE,NTAB,ISW,JSW,I PARAMETER(NTAB=10) EXTERNAL DGMLT1,FSCONT COMMON /SQIDAT/ TABTIM(NTAB),TABLAM(NTAB),IU,JSW *** Copy the sense wire number to the common. JSW=ISW *** Set the wire diameter to 0, if a wire was hit. IF(ISTAT.GE.1.AND.ISTAT.LE.NWIRE)THEN IWIRE=ISTAT ELSEIF(ISTAT.GT.MXWIRE.AND.ISTAT.LE.2*MXWIRE)THEN IWIRE=ISTAT-MXWIRE ELSE IWIRE=0 ENDIF IF(IWIRE.GT.0)THEN DRES=D(IWIRE) D(IWIRE)=0 ENDIF *** Initial value for the induced charge. QTOT=0 CALL DLCVEL(XU(1),YU(1),ZU(1),F1,QPCHAR,IPTYPE,ILOC1) CALL SIGFLS(REAL(XU(1)),REAL(YU(1)),REAL(ZU(1)),EX1,EY1,EZ1,JSW) IF(ILOC1.NE.0)THEN PRINT *,' !!!!!! SIGQIN WARNING : Ran into non-free'// - ' zone at first step ; Q=0.' QTOT=0 IF(IWIRE.GT.0)D(IWIRE)=DRES RETURN ENDIF *** Loop over the drift line. DO 10 IU=2,NU * Evaluate end-point. CALL DLCVEL(XU(IU),YU(IU),ZU(IU),F3,QPCHAR,IPTYPE,ILOC3) * Abandon if this fails. IF(ILOC3.NE.0)THEN PRINT *,' !!!!!! SIGQIN WARNING : Ran into non-free'// - ' zone at end of regular step ; Q=0.' QTOT=0 IF(IWIRE.GT.0)D(IWIRE)=DRES RETURN ENDIF CALL SIGFLS(REAL(XU(IU)),REAL(YU(IU)),REAL(ZU(IU)), - EX3,EY3,EZ3,JSW) * Avoid integration outside the time limits. IF(TMIN.GT.TU(IU).OR.TMAX.LT.TU(IU-1))GOTO 30 * Try a parabolic weighted mean of the average position. XMID=XU(IU-1)+(TU(IU)-TU(IU-1))*(3*F1(1)+F3(1))/8 YMID=YU(IU-1)+(TU(IU)-TU(IU-1))*(3*F1(2)+F3(2))/8 ZMID=ZU(IU-1)+(TU(IU)-TU(IU-1))*(3*F1(3)+F3(3))/8 CALL DLCVEL(XMID,YMID,ZMID,F2,QPCHAR,IPTYPE,ILOC2) * If this fails, try a straight mean. IF(ILOC2.NE.0)THEN XMID=(XU(IU)+XU(IU-1))/2 YMID=(YU(IU)+YU(IU-1))/2 ZMID=(ZU(IU)+ZU(IU-1))/2 CALL DLCVEL(XMID,YMID,ZMID,F2,QPCHAR,IPTYPE,ILOC2) * If this too fails, abandon. IF(ILOC2.NE.0)THEN PRINT *,' !!!!!! SIGQIN WARNING : Ran into non-free'// - ' zone in middle of regular step ; Q=0.' QTOT=0 IF(IWIRE.GT.0)D(IWIRE)=DRES RETURN ENDIF ENDIF CALL SIGFLS(REAL(XMID),REAL(YMID),REAL(ZMID),EX2,EY2,EZ2,JSW) * Compare 1st and 2nd order. IF((TU(IU)-TMIN)*(TMIN-TU(IU-1)).LE.0.AND. - (TU(IU)-TMAX)*(TMAX-TU(IU-1)).LE.0.AND. - ABS((TU(IU)-TU(IU-1))*( - (EX1*F1(1)+EY1*F1(2)+EZ1*F1(3))- - 2*(EX2*F2(1)+EY2*F2(2)+EZ2*F2(3))+ - (EX3*F3(1)+EY3*F3(2)+EZ3*F3(3))))/3.LT.1D-6)THEN * If they agree, use Simpsons formula. QTOT=QTOT+QPCHAR*(TU(IU)-TU(IU-1))*( - (EX1*F1(1)+EY1*F1(2)+EZ1*F1(3))+ - 4*(EX2*F2(1)+EY2*F2(2)+EZ2*F2(3))+ - (EX3*F3(1)+EY3*F3(2)+EZ3*F3(3)))/6 * Otherwise use 6-point Gaussian integration. ELSE * Prepare an interpolation table for the time-lambda relation. TABTIM(1)=0 TABLAM(1)=0 DMEAN=SQRT((XU(IU)-XU(IU-1))**2+(YU(IU)-YU(IU-1))**2+ - (ZU(IU)-ZU(IU-1))**2)/DBLE(NTAB-1) DO 20 I=2,NTAB CALL DLCVEL( - XU(IU-1)+(I-2.0D0)*(XU(IU)-XU(IU-1))/DBLE(NTAB-1), - YU(IU-1)+(I-2.0D0)*(YU(IU)-YU(IU-1))/DBLE(NTAB-1), - ZU(IU-1)+(I-2.0D0)*(ZU(IU)-ZU(IU-1))/DBLE(NTAB-1), - F1,QPCHAR,IPTYPE,ILOC1) CALL DLCVEL( - XU(IU-1)+(I-1.5D0)*(XU(IU)-XU(IU-1))/DBLE(NTAB-1), - YU(IU-1)+(I-1.5D0)*(YU(IU)-YU(IU-1))/DBLE(NTAB-1), - ZU(IU-1)+(I-1.5D0)*(ZU(IU)-ZU(IU-1))/DBLE(NTAB-1), - F2,QPCHAR,IPTYPE,ILOC2) CALL DLCVEL( - XU(IU-1)+(I-1.0D0)*(XU(IU)-XU(IU-1))/DBLE(NTAB-1), - YU(IU-1)+(I-1.0D0)*(YU(IU)-YU(IU-1))/DBLE(NTAB-1), - ZU(IU-1)+(I-1.0D0)*(ZU(IU)-ZU(IU-1))/DBLE(NTAB-1), - F3,QPCHAR,IPTYPE,ILOC3) IF(SQRT(F1(1)**2+F1(2)**2+F1(3)**2).LE.0.OR. - SQRT(F2(1)**2+F2(2)**2+F2(3)**2).LE.0.OR. - SQRT(F3(1)**2+F3(2)**2+F3(3)**2).LE.0.OR. - ILOC1.NE.0.OR.ILOC2.NE.0.OR.ILOC3.NE.0)THEN PRINT *,' !!!!!! SIGQIN WARNING : Ran into non'// - ' free area in a Gauss step ; Qe set to 0.' QTOT=0 IF(IWIRE.GT.0)D(IWIRE)=DRES RETURN ENDIF TABTIM(I)=TABTIM(I-1)+DMEAN*( - 1/SQRT(F1(1)**2+F1(2)**2+F1(3)**2)+ - 4/SQRT(F2(1)**2+F2(2)**2+F2(3)**2)+ - 1/SQRT(F3(1)**2+F3(2)**2+F3(3)**2))/6 TABLAM(I)=DBLE(I-1)/DBLE(NTAB-1) 20 CONTINUE * Set integration limits. TIMIN=MAX(TMIN-TU(IU-1),TABTIM(1)) TIMAX=MIN(TMAX-TU(IU-1),TABTIM(NTAB)) * Add the contribution. QTOT=QTOT+QPCHAR*DGMLT1(FSCONT,TIMIN,TIMAX,1,8,AUX) ENDIF * Shift the field for the end-point to the starting point. 30 CONTINUE EX1=EX3 EY1=EY3 EZ1=EZ3 F1(1)=F3(1) F1(2)=F3(2) F1(3)=F3(3) 10 CONTINUE *** Restore the wire diameter. IF(IWIRE.GT.0)D(IWIRE)=DRES *** Invert sign of the induced charge. QTOT=-QTOT END +DECK,FSCONT. SUBROUTINE FSCONT(M,U1,F1,XTIM) *----------------------------------------------------------------------- * FSCONT - Integrates the induced charge over a drift line segment. * (Last changed on 4/11/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,DRIFTLINE. +SEQ,CELLDATA. REAL EX,EY,EZ INTEGER L,M,JSW,ILOC,IU,NTAB PARAMETER(NTAB=10) DOUBLE PRECISION U1(*),F1(*),XTIM(1),F0(3),DIVDF2,XPOS,YPOS,ZPOS, - TABTIM,TABLAM,XLAM COMMON /SQIDAT/ TABTIM(NTAB),TABLAM(NTAB),IU,JSW EXTERNAL DIVDF2 *** Loop over the positions. DO 10 L=1,M * Copy the time coordinate. XTIM(1)=U1(L) * Compute space coordinate. XLAM=DIVDF2(TABLAM,TABTIM,NTAB,XTIM(1),2) * Position. XPOS=XU(IU-1)+XLAM*(XU(IU)-XU(IU-1)) YPOS=YU(IU-1)+XLAM*(YU(IU)-YU(IU-1)) ZPOS=ZU(IU-1)+XLAM*(ZU(IU)-ZU(IU-1)) ** Compute Ew. CALL SIGFLS(REAL(XPOS),REAL(YPOS),REAL(ZPOS),EX,EY,EZ,JSW) ** Compute drift velocity. CALL DLCVEL(XPOS,YPOS,ZPOS,F0,QPCHAR,IPTYPE,ILOC) ** Set the return value. F1(L)=F0(1)*EX+F0(2)*EY+F0(3)*EZ 10 CONTINUE END +DECK,SIGWRT. SUBROUTINE SIGWRT *----------------------------------------------------------------------- * SIGWRT - A routine that writes the signals to a file * VARIABLES : VALID : Valid dataset available, if set to .TRUE. * FILE etc : Data on the file to be written. * (Last changed on 1/12/98.) *----------------------------------------------------------------------- implicit none +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,SIGNALDATA. +SEQ,PRINTPLOT. CHARACTER*(MXCHAR) STRING CHARACTER*(MXNAME) FILE CHARACTER*80 FCNWRC,UNIT CHARACTER*29 REMARK CHARACTER*10 VARLIS(MXVAR) CHARACTER*8 TIME,DATE,MEMBER,FORMAT LOGICAL FLAG(MXWORD+3),VALID,IFWRT(MXLIST),USE(MXVAR) C LOGICAL EXMEMB INTEGER INPCMP,IENTRY,NCWRC,I,NWORD,INEXT,NCFILE,NCMEMB,NCREM, - ISW,IOS,NWRITE,J,MODVAR(MXVAR),IFAIL,MODRES(1),NRES,NOUT, - NCUNIT REAL RES(1),VAR(MXVAR),SCALET,SCALEI EXTERNAL INPCMP +SELF,IF=SAVE. SAVE VALID,FILE,NCFILE,MEMBER,NCMEMB,REMARK,NCREM,FORMAT, - IENTRY,NCWRC,SCALET,SCALEI +SELF. *** Initialise the various parameters. DATA VALID /.FALSE./ DATA FILE /' '/ DATA MEMBER /'< none >'/ DATA REMARK /'none'/ DATA FORMAT /'SPICE '/ DATA NCFILE,NCMEMB,NCREM /1,8,4/ DATA IENTRY /0/ DATA SCALET /1.0/, SCALEI /1.0/ FCNWRC=' ' NCWRC=0 *** Identify the routine. IF(LIDENT)PRINT *,' /// ROUTINE SIGWRT ///' *** Get the number of words, return if there is only one. CALL INPNUM(NWORD) IF(NWORD.LE.1)THEN PRINT *,' !!!!!! SIGWRT WARNING : WRITE takes at least 1'// - ' argument (a dataset name); data will not be written.' RETURN ENDIF ** Mark keywords. DO 10 I=1,NWORD+3 FLAG(I)=.TRUE. IF(I.GT.NWORD)GOTO 10 IF(INPCMP(I,'D#ATASET')+INPCMP(I,'R#EMARK')+ - INPCMP(I,'WR#ITE-IF')+INPCMP(I,'F#ORMAT')+ - INPCMP(I,'U#NITS').EQ.0)FLAG(I)=.FALSE. 10 CONTINUE ** Loop over the words. INEXT=2 DO 20 I=2,NWORD IF(I.LT.INEXT)GOTO 20 * Look for a DATASET. IF(INPCMP(I,'D#ATASET').NE.0)THEN IF(FLAG(I+1))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(.NOT.FLAG(I+2))THEN CALL INPSTR(I+2,I+2,STRING,NCMEMB) MEMBER=STRING INEXT=I+3 ENDIF VALID=.TRUE. ENDIF * FORMAT specification, either SPICE or SCEPTRE. ELSEIF(INPCMP(I,'F#ORMAT').NE.0)THEN IF(FLAG(I+1))THEN CALL INPMSG(I,'No format specification found.') INEXT=I+1 ELSE IF(INPCMP(I+1,'SC#EPTRE').NE.0)THEN FORMAT='SCEPTRE ' ELSEIF(INPCMP(I+1,'SP#ICE').NE.0)THEN FORMAT='SPICE ' ELSE CALL INPMSG(I+1,'Not a known dataset format. ') ENDIF INEXT=I+2 ENDIF * Remark. ELSEIF(INPCMP(I,'REM#ARK').NE.0)THEN IF(FLAG(I+1))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 * Look for a write condition. ELSEIF(INPCMP(I,'WR#ITE-IF').NE.0)THEN IF(I+1.GT.NWORD)THEN CALL INPMSG(I,'The function is not specified.') ELSE CALL INPSTR(I+1,I+1,FCNWRC,NCWRC) IF(NCWRC.GT.0.AND.IENTRY.GT.0)THEN CALL ALGCLR(IENTRY) IENTRY=0 ENDIF ENDIF INEXT=I+2 * Units. ELSEIF(INPCMP(I,'U#NITS').NE.0)THEN DO 30 J=I+1,NWORD IF(FLAG(J))THEN INEXT=J GOTO 20 ELSEIF(INPCMP(J,'SEC#ONDS').NE.0)THEN SCALET=1E-6 ELSEIF(INPCMP(J,'MIL#LI-SEC#ONDS')+ - INPCMP(J,'MILLISEC#ONDS')+ - INPCMP(J,'MSEC#ONDS').NE.0)THEN SCALET=1E-3 ELSEIF(INPCMP(J,'MIC#RO-SEC#ONDS')+ - INPCMP(J,'MICROSEC#ONDS')+ - INPCMP(J,'MUSEC#ONDS').NE.0)THEN SCALET=1 ELSEIF(INPCMP(J,'N#ANO-SEC#ONDS')+ - INPCMP(J,'NANOSEC#ONDS')+ - INPCMP(J,'NSEC#ONDS').NE.0)THEN SCALET=1E+3 ELSEIF(INPCMP(J,'P#ICO-SEC#ONDS')+ - INPCMP(J,'PICOSEC#ONDS')+ - INPCMP(J,'PSEC#ONDS').NE.0)THEN SCALET=1E+6 ELSEIF(INPCMP(J,'F#EMTO-SEC#ONDS')+ - INPCMP(J,'F#EMTOSEC#ONDS')+ - INPCMP(J,'FSEC#ONDS').NE.0)THEN SCALET=1E+9 ELSEIF(INPCMP(J,'A#TTO-SEC#ONDS')+ - INPCMP(J,'ATTOSEC#ONDS')+ - INPCMP(J,'ASEC#ONDS').NE.0)THEN SCALET=1E+12 ELSEIF(INPCMP(J,'KI#LO-A#MPERES')+ - INPCMP(J,'KILOA#MPERES')+ - INPCMP(J,'KA#MPERES').NE.0)THEN SCALEI=1E-9 ELSEIF(INPCMP(J,'A#MPERES').NE.0)THEN SCALEI=1E-6 ELSEIF(INPCMP(J,'MIL#LI-A#MPERES')+ - INPCMP(J,'MILLIA#MPERES')+ - INPCMP(J,'MA#MPERES').NE.0)THEN SCALEI=1E-3 ELSEIF(INPCMP(J,'MIC#RO-A#MPERES')+ - INPCMP(J,'MICROA#MPERES')+ - INPCMP(J,'MUA#MPERES').NE.0)THEN SCALEI=1 ELSEIF(INPCMP(J,'N#ANO-A#MPERES')+ - INPCMP(J,'NANOA#MPERES')+ - INPCMP(J,'NA#MPERES').NE.0)THEN SCALEI=1E+3 ELSEIF(INPCMP(J,'P#ICO-A#MPERES')+ - INPCMP(J,'PICOA#MPERES')+ - INPCMP(J,'PA#MPERES').NE.0)THEN SCALEI=1E+6 ELSEIF(INPCMP(J,'F#EMTO-A#MPERES')+ - INPCMP(J,'F#EMTOA#MPERES')+ - INPCMP(J,'FA#MPERES').NE.0)THEN SCALEI=1E+9 ELSEIF(INPCMP(J,'A#TTO-A#MPERES')+ - INPCMP(J,'ATTOA#MPERES')+ - INPCMP(J,'AA#MPERES').NE.0)THEN SCALEI=1E+12 ELSE CALL INPMSG(J,'Not a known unit.') ENDIF 30 CONTINUE INEXT=NWORD+1 * Invalid keyword. ELSE CALL INPMSG(I,'Invalid as a keyword. ') ENDIF 20 CONTINUE ** Print error messages. CALL INPERR ** Check the dataset name length, if such a name will be needed. IF(VALID)THEN IF(NCFILE.GT.MXNAME)PRINT *,' !!!!!! SIGWRT WARNING : File', - ' name truncated to MXNAME (=',MXNAME,') characters.' IF(NCMEMB.GT.8)PRINT *,' !!!!!! SIGWRT WARNING : Member', - ' name shortened to ',MEMBER,', first 8 characters.' IF(NCREM.GT.29)PRINT *,' !!!!!! SIGWRT WARNING : Remark', - ' shortened to ',REMARK,', first 29 characters.' NCFILE=MIN(NCFILE,MXNAME) NCMEMB=MIN(NCMEMB,8) NCREM=MIN(NCREM,29) ELSE PRINT *,' !!!!!! SIGWRT WARNING : No dataset name found;'// - ' signals not written.' RETURN ENDIF * Check whether the member already exists. C CALL DSNREM(FILE(1:NCFILE),MEMBER(1:NCMEMB),'SIGNAL',EXMEMB) C IF(JEXMEM.EQ.2.AND.EXMEMB)THEN C PRINT *,' ------ SIGWRT MESSAGE : A copy of the member'// C - ' exists; new member will be appended.' C ELSEIF(JEXMEM.EQ.3.AND.EXMEMB)THEN C PRINT *,' !!!!!! SIGWRT WARNING : A copy of the member'// C - ' exists already; member will not be written.' C RETURN C ENDIF * Print some debugging output if requested. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ SIGWRT DEBUG : File= '',A, - '', member='',A/26X,''remark='',A,'', format='',A)') - FILE(1:NCFILE),MEMBER(1:NCMEMB),REMARK(1:NCREM),FORMAT IF(LDEBUG)WRITE(LUNOUT,'(26X,''Write condition: '',A)') - FCNWRC(1:MAX(1,NCWRC)) *** Translate the write condition, if there is no entry point yet. IF(IENTRY.LE.0.AND.NCWRC.GT.0)THEN VARLIS(1)='TIME ' VARLIS(2)='SIGNAL ' VARLIS(3)='SAMPLE ' CALL ALGPRE(FCNWRC(1:NCWRC),NCWRC,VARLIS,3, - NRES,USE,IENTRY,IFAIL) * Verify that the translation worked correctly. IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! SIGWRT WARNING : Write condition'// - ' could not be translated ; set to True.' CALL ALGCLR(IENTRY) IENTRY=0 NCWRC=0 RETURN * Make sure that there is only one result coming back. ELSEIF(NRES.NE.1)THEN PRINT *,' !!!!!! SIGWRT WARNING : The write'// - ' condition does not return 1 result ;'// - ' set to True.' CALL ALGCLR(IENTRY) IENTRY=0 NCWRC=0 RETURN ENDIF ENDIF *** Format the description of the units. UNIT='time in ' NCUNIT=8 IF(NINT(LOG10(SCALET)).EQ.12)THEN UNIT(NCUNIT+1:NCUNIT+11)='atto second' NCUNIT=NCUNIT+11 ELSEIF(NINT(LOG10(SCALET)).EQ.9)THEN UNIT(NCUNIT+1:NCUNIT+12)='femto second' NCUNIT=NCUNIT+12 ELSEIF(NINT(LOG10(SCALET)).EQ.6)THEN UNIT(NCUNIT+1:NCUNIT+11)='pico second' NCUNIT=NCUNIT+11 ELSEIF(NINT(LOG10(SCALET)).EQ.3)THEN UNIT(NCUNIT+1:NCUNIT+11)='nano second' NCUNIT=NCUNIT+11 ELSEIF(NINT(LOG10(SCALET)).EQ.0)THEN UNIT(NCUNIT+1:NCUNIT+12)='micro second' NCUNIT=NCUNIT+12 ELSEIF(NINT(LOG10(SCALET)).EQ.-3)THEN UNIT(NCUNIT+1:NCUNIT+12)='milli second' NCUNIT=NCUNIT+12 ELSEIF(NINT(LOG10(SCALET)).EQ.-6)THEN UNIT(NCUNIT+1:NCUNIT+6)='second' NCUNIT=NCUNIT+6 ELSE UNIT(NCUNIT+1:NCUNIT+16)=' second' NCUNIT=NCUNIT+16 ENDIF UNIT(NCUNIT+1:NCUNIT+13)=', current in ' NCUNIT=NCUNIT+13 IF(NINT(LOG10(SCALEI)).EQ.12)THEN UNIT(NCUNIT+1:NCUNIT+11)='atto Ampere' NCUNIT=NCUNIT+11 ELSEIF(NINT(LOG10(SCALEI)).EQ.9)THEN UNIT(NCUNIT+1:NCUNIT+12)='femto Ampere' NCUNIT=NCUNIT+12 ELSEIF(NINT(LOG10(SCALEI)).EQ.6)THEN UNIT(NCUNIT+1:NCUNIT+11)='pico Ampere' NCUNIT=NCUNIT+11 ELSEIF(NINT(LOG10(SCALEI)).EQ.3)THEN UNIT(NCUNIT+1:NCUNIT+11)='nano Ampere' NCUNIT=NCUNIT+11 ELSEIF(NINT(LOG10(SCALEI)).EQ.0)THEN UNIT(NCUNIT+1:NCUNIT+12)='micro Ampere' NCUNIT=NCUNIT+12 ELSEIF(NINT(LOG10(SCALEI)).EQ.-3)THEN UNIT(NCUNIT+1:NCUNIT+12)='milli Ampere' NCUNIT=NCUNIT+12 ELSEIF(NINT(LOG10(SCALEI)).EQ.-6)THEN UNIT(NCUNIT+1:NCUNIT+6)='Ampere' NCUNIT=NCUNIT+6 ELSEIF(NINT(LOG10(SCALEI)).EQ.-9)THEN UNIT(NCUNIT+1:NCUNIT+11)='kilo Ampere' NCUNIT=NCUNIT+11 ELSE UNIT(NCUNIT+1:NCUNIT+16)=' Ampere' NCUNIT=NCUNIT+16 ENDIF *** Write the information to the dataset, start opening it. CALL DSNOPN(FILE,NCFILE,12,'WRITE-LIBRARY',IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! SIGWRT WARNING : Opening ',FILE(1:NCFILE), - ' failed ; no signal data written.' RETURN ENDIF CALL DSNLOG(FILE,'Signals ','Sequential','Write ') *** Loop over all sense wires. DO 240 ISW=1,NSW * Now write a heading record to the file, CALL DATTIM(DATE,TIME) WRITE(STRING,'(''% Created '',A8,'' At '',A8, - '' < none > SIGNAL "Direct signal, group '',I3, - '' "'')') DATE,TIME,ISW IF(REMARK.NE.'none')STRING(51:79)=REMARK IF(MEMBER.NE.'< none >')STRING(32:39)=MEMBER WRITE(12,'(A80)',IOSTAT=IOS,ERR=2010) STRING * Inform the user about the conductors in this group. CALL CELPRC(12,ISW) * Evaluate the function. NWRITE=0 IF(IENTRY.NE.0)THEN DO 205 J=1,NTIME VAR(1)=TIMSIG(J) MODVAR(1)=2 VAR(2)=SIGNAL(J,ISW,1) MODVAR(2)=2 VAR(3)=REAL(J) MODVAR(3)=2 CALL ALGEXE(IENTRY,VAR,MODVAR,3,RES,MODRES,1,IFAIL) IF(IFAIL.EQ.0.AND.MODRES(1).EQ.3)THEN IF(ABS(RES(1)).LT.1E-3)THEN IFWRT(J)=.FALSE. ELSE IFWRT(J)=.TRUE. NWRITE=NWRITE+1 ENDIF ELSE PRINT *,' !!!!!! SIGWRT WARNING : WRITE-IF does not'// - ' evaluate to a valid logical; set to True.' IFWRT(J)=.TRUE. NWRITE=NWRITE+1 ENDIF 205 CONTINUE ELSE DO 206 J=1,NTIME IFWRT(J)=.TRUE. NWRITE=NWRITE+1 206 CONTINUE ENDIF * Check there is something to be written. IF(NWRITE.LE.0)THEN WRITE(12,'('' No signal data selected by WRITE-IF'')') ELSE WRITE(12,'('' Number of signal records: '',I5)') NWRITE ENDIF * Write the name of the units. WRITE(12,'('' Units used: '',A,''.'')') UNIT(1:NCUNIT) * Write the data at the end of the file. NOUT=0 DO 210 J=1,NTIME IF(.NOT.IFWRT(J))GOTO 210 NOUT=NOUT+1 IF(FORMAT.EQ.'SPICE ')THEN IF(NOUT.EQ.NWRITE.AND.NOUT.EQ.1)THEN WRITE(12,'('' .STIMULUS signal PWL''/ - '' + TIME_SCALE_FACTOR = '',E10.3/ - '' + VALUE_SCALE_FACTOR = '',E10.3/ - '' + ( '',E15.8,2X,E15.8,'' )'')', - IOSTAT=IOS,ERR=2010) 1.0E-6*SCALET,1.0E-6*SCALEI, - TIMSIG(J)*SCALET,SIGNAL(J,ISW,1)*SCALEI ELSEIF(NOUT.EQ.1)THEN WRITE(12,'('' .STIMULUS signal PWL''/ - '' + TIME_SCALE_FACTOR = '',E10.3/ - '' + VALUE_SCALE_FACTOR = '',E10.3/ - '' + ( '',E15.8,2X,E15.8)',IOSTAT=IOS, - ERR=2010) 1.0E-6*SCALET,1.0E-6*SCALEI, - TIMSIG(J)*SCALET,SIGNAL(J,ISW,1)*SCALEI ELSEIF(NOUT.GT.1.AND.NOUT.LT.NWRITE)THEN WRITE(12,'('' +'',4X,E15.8,2X,E15.8)',IOSTAT=IOS, - ERR=2010) - TIMSIG(J)*SCALET,SIGNAL(J,ISW,1)*SCALEI ELSEIF(NOUT.EQ.NWRITE)THEN WRITE(12,'('' +'',4X,E15.8,2X,E15.8,'' )'')', - IOSTAT=IOS,ERR=2010) - TIMSIG(J)*SCALET,SIGNAL(J,ISW,1)*SCALEI ENDIF ELSEIF(FORMAT.EQ.'SCEPTRE ')THEN WRITE(12,'(2X,E15.8,'' , '',E15.8)',IOSTAT=IOS,ERR=2010) - TIMSIG(J)*SCALET,SIGNAL(J,ISW,1)*SCALEI ELSE PRINT *,' ###### SIGWRT ERROR : Signal dataset'// - ' format not known ('//FORMAT//'); respecify.' RETURN ENDIF 210 CONTINUE ** Same procedure for the cross induced signals. IF(LCROSS)THEN WRITE(STRING,'(''% Created '',A8,'' At '',A8, - '' < none > SIGNAL "Cross-talk, group '',I3, - '' "'')') DATE,TIME,ISW IF(REMARK.NE.'none')STRING(51:79)=REMARK IF(MEMBER.NE.'< none >')STRING(32:39)=MEMBER WRITE(12,'(A80)',IOSTAT=IOS,ERR=2010) STRING * Inform the user about the wires in this group. CALL CELPRC(12,ISW) * Evaluate the function. NWRITE=0 IF(IENTRY.NE.0)THEN DO 270 J=1,NTIME VAR(1)=TIMSIG(J) MODVAR(1)=2 VAR(2)=SIGNAL(J,ISW,2) MODVAR(2)=2 VAR(3)=REAL(J) MODVAR(3)=2 CALL ALGEXE(IENTRY,VAR,MODVAR,3,RES,MODRES,1,IFAIL) IF(IFAIL.EQ.0.AND.MODRES(1).EQ.3)THEN IF(ABS(RES(1)).LT.1E-3)THEN IFWRT(J)=.FALSE. ELSE IFWRT(J)=.TRUE. NWRITE=NWRITE+1 ENDIF ELSE PRINT *,' !!!!!! SIGWRT WARNING : WRITE-IF does'// - ' not evaluate to a valid logical;'// - ' set to True.' IFWRT(J)=.TRUE. NWRITE=NWRITE+1 ENDIF 270 CONTINUE ELSE DO 280 J=1,NTIME IFWRT(J)=.TRUE. NWRITE=NWRITE+1 280 CONTINUE ENDIF * Check there is something to be written. IF(NWRITE.LE.0)THEN WRITE(12,'('' No signal data selected by WRITE-IF'')') ELSE WRITE(12,'('' Number of signal records: '',I5)') NWRITE ENDIF * Write the name of the units. WRITE(12,'('' Units used: '',A,''.'')') UNIT(1:NCUNIT) * Write the data at the end of the file. NOUT=0 DO 220 J=1,NTIME IF(.NOT.IFWRT(J))GOTO 220 NOUT=NOUT+1 IF(FORMAT.EQ.'SPICE ')THEN IF(NOUT.EQ.NWRITE.AND.NOUT.EQ.1)THEN WRITE(12,'('' .STIMULUS signal PWL''/ - '' + TIME_SCALE_FACTOR = '',E10.3/ - '' + VALUE_SCALE_FACTOR = '',E10.3/ - '' + ( '',E15.8,2X,E15.8,'' )'')', - IOSTAT=IOS,ERR=2010) - 1.0E-6*SCALET,1.0E-6*SCALEI, - TIMSIG(J)*SCALET,SIGNAL(J,ISW,2)*SCALEI ELSEIF(NOUT.EQ.1)THEN WRITE(12,'('' .STIMULUS signal PWL''/ - '' + TIME_SCALE_FACTOR = '',E10.3/ - '' + VALUE_SCALE_FACTOR = '',E10.3/ - '' + ( '',E15.8,2X,E15.8)',IOSTAT=IOS, - ERR=2010) 1.0E-6*SCALET,1.0E-6*SCALEI, - TIMSIG(J)*SCALET,SIGNAL(J,ISW,2)*SCALEI ELSEIF(NOUT.GT.1.AND.NOUT.LT.NWRITE)THEN WRITE(12,'('' +'',4X,E15.8,2X,E15.8)',IOSTAT=IOS, - ERR=2010) - TIMSIG(J)*SCALET,SIGNAL(J,ISW,2)*SCALEI ELSEIF(NOUT.EQ.NWRITE)THEN WRITE(12,'('' +'',4X,E15.8,2X,E15.8,'' )'')', - IOSTAT=IOS,ERR=2010) - TIMSIG(J)*SCALET,SIGNAL(J,ISW,2)*SCALEI ENDIF ELSEIF(FORMAT.EQ.'SCEPTRE ')THEN WRITE(12,'(2X,E15.8,'' , '',E15.8)', - IOSTAT=IOS,ERR=2010) - TIMSIG(J)*SCALET,SIGNAL(J,ISW,2)*SCALEI ELSE PRINT *,' ###### SIGWRT ERROR : Signal dataset'// - ' format not known ('//FORMAT//'); respecify.' RETURN ENDIF 220 CONTINUE ENDIF 240 CONTINUE *** Normal end of the routine, return after closing the file. CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) RETURN *** Handle error conditions. 2010 CONTINUE PRINT *,' ###### SIGWRT ERROR : Error while writing'// - ' to the file ',FILE(1:NCFILE),' on unit 12.' CALL INPIOS(IOS) CLOSE(UNIT=12,STATUS='KEEP',IOSTAT=IOS,ERR=2030) RETURN 2030 CONTINUE PRINT *,' ###### SIGWRT ERROR : '//FILE(1:NCFILE)// - ' could not be closed properly ; results not predictable.' CALL INPIOS(IOS) END +DECK,SIGCHK. SUBROUTINE SIGCHK *----------------------------------------------------------------------- * SIGCHK - Performs some simple checks on the performance of the * signal routines. * VARIABLES : LAVACH : if .TRUE.: check avalanche calculation. * (Last changed on 21/ 5/96.) *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,SIGNALDATA. +SEQ,CELLDATA. +SEQ,GASDATA. +SEQ,DRIFTLINE. +SEQ,PRINTPLOT. +SEQ,PARAMETERS. LOGICAL LAVACH,LDIFCH,LCLSCH,LKEEP,USE(MXVAR),EXIST,RSET INTEGER NRNDM,NCHA,MODVAR(MXVAR),MODRES(1) REAL XPL(MXLIST),YPL(MXLIST),AVER,SIGMA,SDIFF,XSTART,YSTART DOUBLE PRECISION XRAN CHARACTER*20 AUX,AUX2 CHARACTER*10 VARCLS(MXVAR) +SELF,IF=SAVE. SAVE LAVACH,LDIFCH,LCLSCH,NRNDM,XSTART,YSTART,FMIN,FMAX,NCHA, - LKEEP +SELF. DATA VARCLS(1)/'N '/ DATA LAVACH,LDIFCH,LCLSCH,LKEEP /.FALSE.,.FALSE.,.FALSE.,.FALSE./ DATA NRNDM /100000/ DATA XSTART,YSTART /0.0,0.0/ DATA FMIN,FMAX /1.0,1.0E10/ DATA NCHA /100/ *** Identify the routine if requested. IF(LIDENT)PRINT *,' /// ROUTINE SIGCHK ///' *** Decode the argument string. CALL INPNUM(NWORD) INEXT=2 DO 10 I=2,NWORD IF(I.LT.INEXT)GOTO 10 * The AVALANCHE options. IF(INPCMP(I,'AVA#LANCHE').NE.0)THEN IF(AVATYP.EQ.'NOT SET')THEN CALL INPMSG(I,'No avalanche type has been set') ELSE LAVACH=.TRUE. ENDIF ELSEIF(INPCMP(I,'NOAVA#LANCHE').NE.0)THEN LAVACH=.FALSE. * The BINS keyword. ELSEIF(INPCMP(I,'BIN#S').NE.0)THEN IF(I+1.GT.NWORD)THEN CALL INPMSG(I,'This keyword has one argument.') ELSE CALL INPCHK(I+1,1,IFAIL) CALL INPRDI(I+1,NCHAR,MXCHA) IF(NCHAR.LE.1.OR.NCHAR.GT.MXCHA)THEN CALL INPMSG(I+1,'Inacceptable number of bins. ') ELSE NCHA=NCHAR ENDIF ENDIF INEXT=I+2 * The CLUSTER options. ELSEIF(INPCMP(I,'CL#USTER').NE.0)THEN TRKLEN=SQRT((XT0-XT1)**2+(YT0-YT1)**2) IF(.NOT.GASOK(5))THEN CALL INPMSG(I,'No cluster data available. ') ELSEIF(TRKLEN*CMEAN.LT.0.1)THEN CALL INPMSG(I,'The track is too short. ') ELSE LCLSCH=.TRUE. ENDIF ELSEIF(INPCMP(I,'NOCL#USTER').NE.0)THEN LCLSCH=.FALSE. * The diffusion options. ELSEIF(INPCMP(I,'DIFF#USION').NE.0)THEN IF(.NOT.GASOK(3))THEN CALL INPMSG(I,'No diffusion data available. ') ELSE LDIFCH=.TRUE. ENDIF ELSEIF(INPCMP(I,'NODIFF#USION').NE.0)THEN LDIFCH=.FALSE. * Starting point of the drift line (if needed). ELSEIF(INPCMP(I,'FR#OM').NE.0)THEN IF(I+2.GT.NWORD)THEN CALL INPMSG(I,'This keyword has 2 arguments. ') ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPCHK(I+2,2,IFAIL2) IF(POLAR)CALL CFMRTP(XSTART,YSTART,XSTART,YSTART,1) CALL INPRDR(I+1,XSTART,XSTART) CALL INPRDR(I+2,YSTART,XSTART) IF(POLAR)THEN CALL CFMPTR(XSTART,YSTART,XSTART,YSTART,1,IFAIL) IF(IFAIL.NE.0)THEN CALL INPMSG(I+1, - 'Illegal polar coordinate. ') XSTART=0.0 YSTART=0.0 ENDIF ENDIF ENDIF INEXT=I+3 * Histogram keeping option. ELSEIF(INPCMP(I,'KEEP-#HISTOGRAMS').NE.0)THEN LKEEP=.TRUE. ELSEIF(INPCMP(I,'NOKEEP-#HISTOGRAMS').NE.0)THEN LKEEP=.FALSE. * The RANGE for the avalanche multiplication histogram. ELSEIF(INPCMP(I,'R#ANGE').NE.0)THEN IF(I+2.GT.NWORD)THEN CALL INPMSG(I,'This keyword has 2 arguments. ') ELSE CALL INPCHK(I+1,2,IFAIL1) CALL INPCHK(I+2,2,IFAIL2) CALL INPRDR(I+1,FMINR,FMIN) CALL INPRDR(I+2,FMAXR,FMAX) IF(FMINR.LE.0.OR.FMAXR.LE.0)THEN CALL INPMSG(I,'Both arguments must be > 0. ') ELSEIF(FMINR.EQ.FMAXR)THEN CALL INPMSG(I,'A zero range is not permitted.') ELSE FMIN=MIN(FMINR,FMAXR) FMAX=MAX(FMINR,FMAXR) ENDIF ENDIF INEXT=I+3 * The repeat counter. ELSEIF(INPCMP(I,'REP#EAT')+INPCMP(I,'N').NE.0)THEN IF(I+1.GT.NWORD)THEN CALL INPMSG(I,'this keyword has one argument.') ELSE CALL INPCHK(I+1,1,IFAIL) CALL INPRDI(I+1,NRNDMR,100000) IF(NRNDMR.LE.0)THEN CALL INPMSG(I+1,'The repeat counter is not > 0.') ELSE NRNDM=NRNDMR ENDIF ENDIF INEXT=I+2 * Unknown option. ELSE CALL INPMSG(I,'The option is not known. ') ENDIF 10 CONTINUE CALL INPERR *** Carry out the AVALANCHE test, if requested. IF(LAVACH.AND.AVATYP.NE.'NOT SET')THEN CALL PROINT('Avalanche check',1,6) * Print some general information. WRITE(LUNOUT,'(''1 CHECK OF THE AVALANCHE CALCULATION''// - '' The avalanche type has been set to '',A)') AVATYP WRITE(LUNOUT,'('' The avalanche will be simulated '',I7, - '' times in this test.'')') NRNDM * For Townsend, print extra information and calculate a drift line. IF(AVATYP.EQ.'TOWNSEND'.OR.AVATYP.EQ.'POLYA-TOWN'.OR. - AVATYP.EQ.'TOWN-FIXED')THEN CALL PROFLD(1,'Computing drift line',-1.0) CALL PROSTA(1,0.0) CALL DLCALC(XSTART,YSTART,0.0,-1.0,1) CALL DLCTWN(ACLUST) XPRT=XSTART YPRT=YSTART IF(POLAR)CALL CFMRTP(XSTART,YSTART,XPRT,YPRT,1) WRITE(LUNOUT,'(/'' The drift-line over which the'', - '' Townsend coefficient is integrated'')') WRITE(LUNOUT,'('' starts at ('',E15.8,'','',E15.8, - ''). Its ISTAT code is '',I3,''.'')') - XPRT,YPRT,ISTAT WRITE(LUNOUT,'('' The drift-time is expected to be '', - E15.8,'' microsec. The calculation'')') TU(NU) WRITE(LUNOUT,'('' needed '',I3,'' steps. An average'', - '' avalanche should create '',E15.8,'' pairs.'')') - NU,ACLUST IF(NU.LE.2.OR.ISTAT.EQ.-2.OR.ISTAT.EQ.-3)THEN WRITE(LUNOUT,'(/'' There is no point in perfor'', - ''ming the test under these conditions.'')') RETURN ENDIF ELSE ACLUST=1.0 ENDIF * Initialize the histogram. CALL PROFLD(1,'Histogram allocation',-1.0) CALL PROSTA(1,0.0) CALL HISADM('ALLOCATE',IHIST,NCHA,FMIN,FMAX,.FALSE.,IFAIL1) * Generate entries. CALL PROFLD(1,'MC cycles',REAL(NRNDM)) DO 30 I=1,NRNDM IF(I.EQ.(NRNDM/20)*(I/(NRNDM/20)))CALL PROSTA(1,REAL(I)) CALL SIGAVA(FACTOR,ACLUST) CALL HISENT(IHIST,FACTOR,1.0) 30 CONTINUE * Plot the histogram. CALL PROFLD(1,'Histogram plotting',-1.0) CALL PROSTA(1,0.0) CALL HISPLT(IHIST,'Multiplication factor', - 'CHECK ON THE GENERATION OF AVALANCHES',.TRUE.) IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) IF(GASID.NE.' ')CALL GRCOMM(2,'Gas: '//GASID) * Get information about the histogram. CALL HISINQ(IHIST,EXIST,RSET, - NNCHA,XXMIN,XXMAX,NNENT,AVER,SIGMA) CALL OUTFMT(AVER,2,AUX,NC,'LEFT') CALL OUTFMT(SIGMA,2,AUX2,NC2,'LEFT') CALL GRCOMM(4,'Mean: '//AUX(1:NC)//', width: '//AUX2(1:NC2)) * Close the plot. CALL GRNEXT CALL GRALOG('Check: Avalanche multiplication.') * Keep the histogram if requested. IF(LKEEP)THEN CALL PROFLD(1,'Histogram saving',-1.0) CALL PROSTA(1,0.0) CALL HISSAV(IHIST,'AVALANCHE',IFAIL1) IF(IFAIL1.EQ.0)THEN PRINT *,' ------ SIGCHK MESSAGE : Avalanche'// - ' histogram kept as AVALANCHE.' ELSE PRINT *,' !!!!!! SIGCHK WARNING : Avalanche'// - ' histogram not saved.' CALL HISADM('DELETE',IHIST,0,0.0,0.0,.TRUE., - IFAIL2) ENDIF * Otherwise delete it. ELSE CALL PROFLD(1,'Histogram deletion',-1.0) CALL PROSTA(1,0.0) CALL HISADM('DELETE',IHIST,0,0.0,0.0,.TRUE.,IFAIL2) ENDIF * End of progress printing. CALL PROEND ENDIF *** Carry out the DIFFUSION test, if requested. IF(LDIFCH.AND.GASOK(3))THEN * Print some general information. WRITE(LUNOUT,'(''1 CHECK OF THE DIFFUSION CALCULATION''// - '' The longitudinal diffusion process will be'', - '' simulated '',I7/'' times in this test, by'', - '' repeatedly drawing an arrival time. '')') NRNDM CALL PROINT('Diffusion check',1,6) CALL PROFLD(1,'Computing drift line',-1.0) CALL PROSTA(1,0.0) XPRT=XSTART YPRT=YSTART IF(POLAR)CALL CFMRTP(XSTART,YSTART,XPRT,YPRT,1) CALL DLCALC(XSTART,YSTART,0.0,-1.0,1) CALL DLCDIF(SDIFF) WRITE(LUNOUT,'(/'' The drift-line over which the'', - '' diffusion coefficient is to be integrated'')') WRITE(LUNOUT,'('' starts at ('',E15.8,'','',E15.8, - ''). Its ISTAT code is '',I3,''.'')') XPRT,YPRT,ISTAT WRITE(LUNOUT,'('' The drift-time and the estimate'', - '' for the average diffusion are '',E15.8)') TU(NU) WRITE(LUNOUT,'('' and '',E15.5,''. The drift line was'', - '' calculated in '',I3,'' steps.'')') SDIFF,NU IF(NU.LE.2.OR.ISTAT.EQ.-2.OR.ISTAT.EQ.-3)THEN WRITE(LUNOUT,'(/'' There is no point in performing'', - '' the test under these conditions.'')') RETURN ENDIF * Initialize the histogram. CALL PROFLD(1,'Histogram allocation',-1.0) CALL PROSTA(1,0.0) CALL HISADM('ALLOCATE',IHIST,NCHA,0.0,0.0,.TRUE.,IFAIL1) * Generate entries. CALL PROFLD(1,'MC cycles',REAL(NRNDM)) DO 50 I=1,NRNDM IF(I.EQ.(NRNDM/20)*(I/(NRNDM/20)))CALL PROSTA(1,REAL(I)) DIFF=RNDNOR(REAL(TU(NU)),SDIFF) CALL HISENT(IHIST,DIFF,1.0) 50 CONTINUE * Plot the histogram. CALL HISPLT(IHIST,'Arrival time [microsec]', - 'CHECK ON THE DIFFUSION',.TRUE.) IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) IF(GASID.NE.' ')CALL GRCOMM(2,'Gas: '//GASID) * Get information about the histogram. CALL HISINQ(IHIST,EXIST,RSET, - NNCHA,XXMIN,XXMAX,NNENT,AVER,SIGMA) CALL OUTFMT(AVER,2,AUX,NC,'LEFT') CALL OUTFMT(SIGMA,2,AUX2,NC2,'LEFT') CALL GRCOMM(4,'Mean: '//AUX(1:NC)//', width: '//AUX2(1:NC2)) * Close the plot. CALL GRNEXT CALL GRALOG('Check: spread due to diffusion. ') * Keep the histogram if requested. IF(LKEEP)THEN CALL PROFLD(1,'Histogram saving',-1.0) CALL PROSTA(1,0.0) CALL HISSAV(IHIST,'DIFFUSION',IFAIL1) IF(IFAIL1.EQ.0)THEN PRINT *,' ------ SIGCHK MESSAGE : Diffusion'// - ' histogram kept as DIFFUSION.' ELSE PRINT *,' !!!!!! SIGCHK WARNING : Diffusion'// - ' histogram not saved.' CALL HISADM('DELETE',IHIST,0,0.0,0.0,.TRUE., - IFAIL2) ENDIF * Otherwise delete it. ELSE CALL PROFLD(1,'Histogram deletion',-1.0) CALL PROSTA(1,0.0) CALL HISADM('DELETE',IHIST,0,0.0,0.0,.TRUE.,IFAIL2) ENDIF * End of progress printing. CALL PROEND ENDIF *** Carry out the CLUSTER test, if requested. IF(LCLSCH.AND.GASOK(5))THEN * Prepare for progress printing. CALL PROINT('Clustering check',1,6) * Obtain track length and set range. TRKLEN=SQRT((XT0-XT1)**2+(YT0-YT1)**2) * Print some general information. WRITE(LUNOUT,'(''1 CHECK OF THE CLUSTER FORMATION''// - '' Clusters will be generated '',I7,'' times on the'', - '' current track, their number''/'' is counted each'', - '' time and the distribution is plotted.'')') NRNDM WRITE(LUNOUT,'('' The track has a length of '',E12.4, - '' cm; the average number of clusters per''/ - '' cm for this gas is '',E12.4,''.'')') TRKLEN,CMEAN * Initialize the histogram. CALL PROFLD(1,'Histogram allocation',-1.0) CALL PROSTA(1,0.0) NAUX=NINT(2*TRKLEN*CMEAN)+1 IF(NAUX.GT.MXCHA)THEN CALL HISADM('ALLOCATE',ICLUS,MXCHA, - -0.5,-0.5+MXCHA*(((NAUX-1)/MXCHA)+1), - .FALSE.,IFAIL1) ELSE CALL HISADM('ALLOCATE',ICLUS,NAUX,-0.5,NAUX-0.5, - .FALSE.,IFAIL1) ENDIF NAUX=NINT(2*TRKLEN*CMEAN*CLSAVE)+1 IF(NAUX.GT.MXCHA)THEN CALL HISADM('ALLOCATE',IELEC,MXCHA, - -0.5,-0.5+MXCHA*(((NAUX-1)/MXCHA)+1), - .FALSE.,IFAIL1) ELSE CALL HISADM('ALLOCATE',IELEC,NAUX,-0.5,NAUX-0.5, - .FALSE.,IFAIL1) ENDIF * Generate entries. CALL PROFLD(1,'Tracks',REAL(NRNDM)) DO 90 I=1,NRNDM IF(I.EQ.(NRNDM/20)*(I/(NRNDM/20)))CALL PROSTA(1,REAL(I)) NCLSCH=0 NELECH=0 DIST=0 70 CONTINUE DIST=DIST+RNDEXP(REAL(1)/CMEAN) IF(DIST.GT.TRKLEN)GOTO 80 NCLSCH=NCLSCH+1 CALL HISRAD(CLSDIS,NCLS,0.0D0,1.0D0,XRAN) NELECH=NELECH+INT(XRAN) GOTO 70 80 CONTINUE CALL HISENT(ICLUS,REAL(NCLSCH),1.0) CALL HISENT(IELEC,REAL(NELECH),1.0) 90 CONTINUE * Plot the histograms. CALL PROFLD(1,'Histogram plotting',-1.0) CALL PROSTA(1,0.0) CALL HISPLT(ICLUS,'Number of clusters on the track', - 'CHECK ON THE CLUSTER GENERATION',.TRUE.) IF(GASID.NE.' ')CALL GRCOMM(1,'Gas: '//GASID) CALL HISINQ(ICLUS,EXIST,RSET, - NNCHA,XXMIN,XXMAX,NNENT,AVER,SIGMA) CALL OUTFMT(AVER,2,AUX,NC,'LEFT') CALL OUTFMT(SIGMA,2,AUX2,NC2,'LEFT') CALL GRCOMM(4,'Mean: '//AUX(1:NC)//', width: '//AUX2(1:NC2)) CALL GRNEXT CALL GRALOG('Check: cluster generation, cluster count') CALL HISPLT(IELEC,'Number of electrons on the track', - 'CHECK ON THE CLUSTER GENERATION',.TRUE.) IF(GASID.NE.' ')CALL GRCOMM(1,'Gas: '//GASID) CALL HISINQ(IELEC,EXIST,RSET, - NNCHA,XXMIN,XXMAX,NNENT,AVER,SIGMA) IF(AVER.GT.0)THEN CALL OUTFMT(SIGMA**2/AVER,2,AUX,NC,'LEFT') CALL GRCOMM(2,'Sigma**2/Mean: '//AUX(1:NC)) ELSE CALL GRCOMM(2,'Sigma**2/Mean: < mean zero>') ENDIF CALL OUTFMT(AVER,2,AUX,NC,'LEFT') CALL OUTFMT(SIGMA,2,AUX2,NC2,'LEFT') CALL GRCOMM(4,'Mean: '//AUX(1:NC)//', width: '//AUX2(1:NC2)) CALL GRNEXT CALL GRALOG('Check: cluster generation, e- count ') * Keep the histograms if requested. IF(LKEEP)THEN CALL PROFLD(1,'Histogram saving',-1.0) CALL PROSTA(1,0.0) CALL HISSAV(ICLUS,'CLUSTERS',IFAIL1) IF(IFAIL1.EQ.0)THEN PRINT *,' ------ SIGCHK MESSAGE : Cluster'// - ' count histogram kept as CLUSTERS.' ELSE PRINT *,' !!!!!! SIGCHK WARNING : Cluster'// - ' count histogram not saved.' CALL HISADM('DELETE',ICLUS,0,0.0,0.0,.TRUE., - IFAIL2) ENDIF CALL HISSAV(IELEC,'ELECTRONS',IFAIL1) IF(IFAIL1.EQ.0)THEN PRINT *,' ------ SIGCHK MESSAGE : Electron'// - ' count histogram kept as ELECTRONS.' ELSE PRINT *,' !!!!!! SIGCHK WARNING : Electron'// - ' count histogram not saved.' CALL HISADM('DELETE',IELEC,0,0.0,0.0,.TRUE., - IFAIL2) ENDIF * Otherwise delete it. ELSE CALL PROFLD(1,'Histogram deletion',-1.0) CALL PROSTA(1,0.0) CALL HISADM('DELETE',ICLUS,0,0.0,0.0,.TRUE.,IFAIL2) CALL HISADM('DELETE',IELEC,0,0.0,0.0,.TRUE.,IFAIL2) ENDIF ** Sample the cluster size distribution and plot a histogram. WRITE(LUNOUT,'(/'' In the next test, a cluster size will'', - '' be drawn '',I7,'' times.'')') NRNDM IF(CLSTYP.EQ.'FUNCTION'.OR.CLSTYP.EQ.'LANDAU')WRITE(LUNOUT, - '('' The dotted curve represents the function'', - '' the histogram is expected to follow.'')') * Initialise the histogram. CALL PROFLD(1,'Histogram allocation',-1.0) CALL PROSTA(1,0.0) CALL HISADM('ALLOCATE',IHIST,MIN(MXCHA,MXPAIR,NCLS), - -0.5,-0.5+MIN(MXCHA,MXPAIR,NCLS),.FALSE.,IFAIL1) * Generate pairs. CALL PROFLD(1,'Clusters',REAL(NRNDM)) DO 110 I=1,NRNDM IF(I.EQ.(NRNDM/20)*(I/(NRNDM/20)))CALL PROSTA(1,REAL(I)) CALL HISRAD(CLSDIS,NCLS,0.0D0,1.0D0,XRAN) CALL HISENT(IHIST,REAL(XRAN),1.0) 110 CONTINUE * Plot the histogram with GRHIST, CALL PROFLD(1,'Histogram plotting',-1.0) CALL PROSTA(1,0.0) CALL GRAOPT('LIN-X, LOG-Y') CALL HISPLT(IHIST,'Cluster Size', - 'CHECK ON THE CLUSTER SIZE DISTRIBUTION',.TRUE.) IF(GASID.NE.' ')CALL GRCOMM(1,'Gas: '//GASID) CALL HISINQ(IHIST,EXIST,RSET, - NNCHA,XXMIN,XXMAX,NNENT,AVER,SIGMA) CALL OUTFMT(AVER,2,AUX,NC,'LEFT') CALL OUTFMT(SIGMA,2,AUX2,NC2,'LEFT') CALL GRCOMM(4,'Mean: '//AUX(1:NC)//', width: '//AUX2(1:NC2)) * Get rid of the histogram. IF(LKEEP)THEN CALL PROFLD(1,'Histogram saving',-1.0) CALL PROSTA(1,0.0) CALL HISSAV(IHIST,'PAIRS',IFAIL1) IF(IFAIL1.EQ.0)THEN PRINT *,' ------ SIGCHK MESSAGE : Pair'// - ' count histogram kept as PAIRS.' ELSE PRINT *,' !!!!!! SIGCHK WARNING : Pair'// - ' count histogram not saved.' CALL HISADM('DELETE',IHIST,0,0.0,0.0,.TRUE., - IFAIL1) ENDIF ELSE CALL PROFLD(1,'Histogram deletion',-1.0) CALL PROSTA(1,0.0) CALL HISADM('DELETE',IHIST,0,0.0,0.0,.TRUE.,IFAIL2) ENDIF ** Skip plotting the function if of inappropriate type. IENTRY=0 IF(CLSTYP.NE.'FUNCTION'.AND.CLSTYP.NE.'LANDAU')GOTO 150 * Pass the cluster function through ALGPRE. IF(CLSTYP.EQ.'FUNCTION')THEN CALL PROFLD(1,'Function plotting',-1.0) CALL PROSTA(1,0.0) IF(INDEX(FCNCLS(1:NFCLS),'@').NE.0)THEN GOTO 150 ELSE CALL ALGPRE(FCNCLS,NFCLS,VARCLS,1,NRES,USE, - IENTRY,IFAIL1) IF(IFAIL1.NE.0.OR.NRES.NE.1)THEN CALL ALGCLR(IENTRY) GOTO 150 ENDIF ENDIF ENDIF * And calculate it. SUM=0.0 NTERM=MAX(3,2*INT(MXLIST/2)-1) DO 130 I=1,NTERM XPL(I)=(I-1)*REAL(NCLS)/REAL(NTERM-1) XVAL=(I-0.5)*REAL(NCLS)/REAL(NTERM-1) IF(CLSTYP.EQ.'FUNCTION')THEN MODVAR(1)=2 CALL ALGEXE(IENTRY,XVAL,MODVAR,1, - YPL(I),MODRES,1,IFAIL1) ELSEIF(CLSTYP.EQ.'LANDAU')THEN IF((CMEAN*XVAL*EPAIR-EMPROB)/(1.54E5*(Z/A)*RHO)- - LOG(CMEAN).LT.-5.0)THEN YPL(I)=0.0 ELSE YPL(I)=DENLAN((CMEAN*XVAL*EPAIR-EMPROB)/ - (1.54E5*(Z/A)*RHO)-LOG(CMEAN)) ENDIF ENDIF * integrate the cluster function to be able to plot it to scale, IF(I.EQ.2*INT(I/2))SUM=SUM+4.0*YPL(I) IF(I.NE.2*INT(I/2))SUM=SUM+2.0*YPL(I) 130 CONTINUE SUM=NCLS*(SUM-YPL(1)-YPL(NTERM))/(3.0*(NTERM-1)) * normalise the calculated distribution and clip above MAXHST, DO 140 I=1,NTERM YPL(I)=YPL(I)*REAL(NRNDM)/SUM 140 CONTINUE * and finally plot the cluster function on top of the histogram. CALL GRATTS('FUNCTION-2','POLYLINE') CALL GRLINE(NTERM,XPL,YPL) * Jump to this lable if no function is to be plotted. 150 CONTINUE * Print number of algebra error messages. CALL ALGERR * Clear the function used for plotting the cluster distribution. IF(CLSTYP.EQ.'FUNCTION'.AND.IENTRY.NE.0)CALL ALGCLR(IENTRY) * Close the graphics output. CALL GRNEXT CALL GRALOG('Check: cluster size distribution. ') CALL GRAOPT('LIN-X, LIN-Y') * End of progress printing. CALL PROEND ENDIF *** Logging of CPU time used for these checks. CALL TIMLOG('Various signal related checks: ') END +DECK,SIGTHR,IF=NEVER. SUBROUTINE SIGTHR *----------------------------------------------------------------------- * SIGTHR - Computes the arrival time distribution of the M'th electron * from a given track. It has a set of auxilliray routines * SIGTH1, SIGTH2 etc * VARIABLES : AUXSPL : Auxilliary array for interpolations. * LTHWRT : Write the data to a dataset, if .TRUE. * LMCCHK : Perform an additional MC check. * TIMSCL : Vector storing the time scale. * FGLOB : Time distribution for all electrons. * STACK : Stack used for integrating. * MFIRST,MLAST: First and last electron to be handled. *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,GASDATA. +SEQ,THRESHDATA. +SEQ,DRIFTLINE. +SEQ,PARAMETERS. +SEQ,PRINTPLOT. +SEQ,CONSTANTS. *** Declarations, start setting the max number of histogram channels. CHARACTER*(MXCHAR) STRING CHARACTER*(MXNAME) FILE CHARACTER*40 TITLE CHARACTER*29 REMARK CHARACTER*8 MEMBER REAL TIMDIF(MXLIST,3),TIMSCL(MXLIST),FGLOB(MXLIST),FK(MXLIST), - FAUX(MXLIST),FM(MXLIST),ARRTIM(MXCLUS*MXPAIR), - XPL(MXLIST),YPL(MXLIST),STACK(MXSTCK,3), - CONT1(0:MXCHA+1),CONT2(0:MXCHA+1),XTHR,YSTART DOUBLE PRECISION CLSRND LOGICAL FLAG(MXWORD+3),LTHWRT,LMCCHK,LANTHR EXTERNAL RNDNOR,DIVDIF +SELF,IF=SAVE. SAVE MAXOPT,MFIRST,MLAST,NRNDM,NCHA,LMCCHK,LANTHR +SELF. *** Initialise those variables that are kept across calls. DATA MAXOPT/10/ DATA MFIRST,MLAST/1,10/ DATA LMCCHK,LANTHR/.FALSE.,.TRUE./ DATA NRNDM/10000/ DATA NCHA/MXCHA/ *** Check the presence of sufficient gas data. IF(.NOT.(GASOK(1).AND.GASOK(3).AND.GASOK(5)))THEN PRINT *,' ###### SIGTHR ERROR : Insufficient gas data to', - ' perform the calculations.' PRINT *,' Required are velocity,', - ' diffusion and cluster data.' RETURN ENDIF *** Make sure the cell is not in polar coordinates. IF(POLAR)THEN PRINT *,' ###### SIGTHR ERROR : The THRESHOLD function', - ' can not be applied to polar geometries.' RETURN ENDIF ** Set NLINTH to the next higher multiple of 8. NLINTH=8*INT(1+NLINED/8.0) *** Initialise various other variables being reset at each call. FILE=' ' MEMBER='< none >' REMARK='none' NCFILE=1 NCMEMB=8 NCREM=4 LTHWRT=.FALSE. IYSET=0 XTHR=DXMAX-(DXMAX-DXMIN)/100.0 *** Examine the input line, flag the known words. CALL INPNUM(NWORD) DO 10 I=2,NWORD IF(INPCMP(I,'X-#START')+INPCMP(I,'OPT#IMISE')+ - INPCMP(I,'D#ATASET')+INPCMP(I,'R#EMARK')+ - INPCMP(I,'ARR#IVALS')+INPCMP(I,'BIN#S')+ - INPCMP(I,'ANA#LYTIC')+INPCMP(I,'NOANA#LYTIC')+ - INPCMP(I,'Y-#SEGMENT')+INPCMP(I,'M#ONTE-C#ARLO').NE.0)THEN FLAG(I)=.TRUE. ELSE FLAG(I)=.FALSE. ENDIF 10 CONTINUE FLAG(NWORD+1)=.TRUE. FLAG(NWORD+2)=.TRUE. FLAG(NWORD+3)=.TRUE. INEXT=2 ** Read in detail. DO 20 I=2,NWORD IF(I.LT.INEXT)GOTO 20 * The ANALYTIC/NOANALYTIC options. IF(INPCMP(I,'ANA#LYTIC').NE.0)THEN LANTHR=.TRUE. ELSEIF(INPCMP(I,'NOANA#LYTIC').NE.0)THEN LANTHR=.FALSE. * Read the first and last particle to be considered. ELSEIF(INPCMP(I,'ARR#IVALS').NE.0)THEN IF(FLAG(I+1))THEN CALL INPMSG(I,'Should have 1 or 2 arguments. ') ELSE CALL INPCHK(I+1,1,IFAIL) CALL INPRDI(I+1,MFR,MFIRST) IF(MFR.LE.0.AND.IFAIL.EQ.0)THEN CALL INPMSG(I+1,'The serial numbers start at 1.') ELSEIF(MFR.GT.MXLIST.AND.IFAIL.EQ.0)THEN CALL INPMSG(I+1,'This parameter exceeds MXLIST.') ELSEIF(IFAIL.EQ.0)THEN MFIRST=MFR ENDIF INEXT=I+2 IF(.NOT.FLAG(I+2))THEN CALL INPCHK(I+2,1,IFAIL) CALL INPRDI(I+2,MLR,MLAST) IF(MLR.LE.0.AND.IFAIL.EQ.0)THEN CALL INPMSG(I+1, - 'The serial numbers start at 1.') ELSEIF(MLR.GT.MXLIST.AND.IFAIL.EQ.0)THEN CALL INPMSG(I+1, - 'This parameter exceeds MXLIST.') ELSEIF(MLR.LT.MFIRST.AND.IFAIL.EQ.0)THEN CALL INPMSG(I+1, - 'Has been set to the minimum. ') MLAST=MFIRST ELSEIF(IFAIL.EQ.0)THEN MLAST=MLR ENDIF INEXT=I+3 ELSE MLAST=MFIRST ENDIF ENDIF * The BINS keyword. ELSEIF(INPCMP(I,'BIN#S').NE.0)THEN IF(I+1.GT.NWORD)THEN CALL INPMSG(I,'This keyword has one argument.') ELSE CALL INPCHK(I+1,1,IFAIL) CALL INPRDI(I+1,NCHAR,MXCHA) IF(NCHAR.LE.1.OR.NCHAR.GT.MXCHA)THEN CALL INPMSG(I+1,'Inacceptable number of bins. ') ELSE NCHA=NCHAR ENDIF ENDIF INEXT=I+2 * Read the output data set name. ELSEIF(INPCMP(I,'D#ATASET').NE.0)THEN IF(FLAG(I+1))THEN CALL INPMSG(I,'Should have an argument. ') ELSE CALL INPSTR(I+1,I+1,STRING,NCFILE) FILE=STRING INEXT=I+2 IF(.NOT.FLAG(I+2))THEN CALL INPSTR(I+2,I+2,STRING,NCMEMB) MEMBER=STRING INEXT=I+3 ENDIF LTHWRT=.TRUE. ENDIF * Check for the Monte-Carlo option ELSEIF(INPCMP(I,'M#ONTE-C#ARLO').NE.0)THEN IF(FLAG(I+1))THEN LMCCHK=.TRUE. ELSEIF(INPCMP(I+1,'OFF')+INPCMP(I+1,'NO#NE').NE.0)THEN LMCCHK=.FALSE. ELSE CALL INPCHK(I+1,1,IFAIL) CALL INPRDI(I+1,NRNDMR,NRNDM) IF(NRNDMR.LT.0)THEN CALL INPMSG(I+1,'The number of cycles is < 0. ') ELSE NRNDM=NRNDMR IF(NRNDM.GT.0)THEN LMCCHK=.TRUE. ELSE LMCCHK=.FALSE. ENDIF ENDIF INEXT=I+2 ENDIF ELSEIF(INPCMP(I,'NOM#ONTE-C#ARLO').NE.0)THEN LMCCHK=.FALSE. * Read the maximum number of optimising cycles. ELSEIF(INPCMP(I,'OPT#IMISE').NE.0)THEN IF(FLAG(I+1))THEN CALL INPMSG(I,'Should have an argument. ') ELSEIF(INPCMP(I+1,'OFF')+INPCMP(I+1,'NO#NE').NE.0)THEN MAXOPT=0 ELSE CALL INPCHK(I+1,1,IFAIL) CALL INPRDI(I+1,MAXOPR,MAXOPT) IF(MAXOPR.LT.0)THEN CALL INPMSG(I+1,'The number of cycles is < 0. ') ELSE MAXOPT=MAXOPR ENDIF INEXT=I+2 ENDIF * Read the remark to be added to the dataset. ELSEIF(INPCMP(I,'R#EMARK').NE.0)THEN IF(FLAG(I+1))THEN CALL INPMSG(I,'Should have an argument. ') ELSE CALL INPSTR(I+1,I+1,STRING,NCREM) REMARK=STRING INEXT=I+2 ENDIF * Find the x-coordinate on which this routine will work. ELSEIF(INPCMP(I,'X-#START').NE.0)THEN IF(FLAG(I+1))THEN CALL INPMSG(I,'Should have an argument. ') ELSE CALL INPCHK(I+1,2,IFAIL) CALL INPRDR(I+1,XTHRR,XTHR) IF(XTHRR.LE.DXMIN.OR.XTHRR.GE.DXMAX)THEN CALL INPMSG(I+1,'This x lies outside the AREA. ') ELSE XTHR=XTHRR ENDIF INEXT=I+2 ENDIF * Find the y-segment to be used. ELSEIF(INPCMP(I,'Y-#SEGMENT').NE.0)THEN IF(FLAG(I+1).OR.FLAG(I+2))THEN CALL INPMSG(I,'Should have two arguments. ') IF(.NOT.FLAG(I+1))THEN INEXT=I+2 CALL INPMSG(I+1,'See the preceding message. ') ENDIF ELSE CALL INPCHK(I+1,2,IFAIL) CALL INPRDR(I+1,YTHMIR,DYMIN) CALL INPCHK(I+2,2,IFAIL) CALL INPRDR(I+2,YTHMAR,DYMAX) YTHMIN=MIN(YTHMIR,YTHMAR) YTHMAX=MAX(YTHMIR,YTHMAR) IYSET=1 INEXT=I+3 ENDIF * The option is not known to the program. ELSE CALL INPMSG(I,'The option is not known. ') ENDIF 20 CONTINUE CALL INPERR ** Check the length of the various strings. IF(NCFILE.GT.MXNAME)THEN PRINT *,' !!!!!! SIGTHR WARNING : The dataset name is too', - ' long and is truncated to ',FILE,'.' NCFILE=MXNAME ENDIF IF(NCMEMB.GT.8)THEN PRINT *,' !!!!!! SIGTHR WARNING : The member name is too', - ' long and is truncated to ',MEMBER,'.' NCMEMB=8 ENDIF IF(NCREM.GT.29)THEN PRINT *,' !!!!!! SIGTHR WARNING : The remark is too', - ' long and is truncated to ',REMARK,'.' NCREM=29 ENDIF ** Print some debugging output, to check correct input handling. IF(LDEBUG)THEN PRINT *,' ++++++ SIGTHR DEBUG : Requested action: MC: ', - LMCCHK,', analytic: ',LANTHR,', dataset: ',LTHWRT IF(LTHWRT)WRITE(*,'(26X,''Dataset: '',A,'' member: '',A/ - 26X,''Remark: '',A29)') - FILE(1:NCFILE),MEMBER(1:NCMEMB),REMARK WRITE(*,'(26X,''First electron to be handled: '',I3, - '', last electron: '',I3)') MFIRST,MLAST WRITE(*,'(26X,''Calculations apply to x='',E15.8)') XTHR WRITE(*,'(26X,''Maximum number of iterations: '',I3/ - 26X,''Random cycles: '',I6,'', bins: '',I3)') - MAXOPT,NRNDM,NCHA ENDIF ** Check that at least some output has been requested. IF(.NOT.(LANTHR.OR.LMCCHK.OR.LTHWRT))THEN PRINT *,' !!!!!! SIGTHR WARNING : All output of has been', - ' suppressed; routine not executed.' RETURN ENDIF *** Loop over the selected, attracting wires inside the AREA. DO 1000 IW=1,NWIRE IF(INDSW(IW).EQ.0.OR.X(IW).LT.DXMIN.OR.X(IW).GT.DXMAX.OR. - Y(IW).LT.DYMIN.OR.Y(IW).GT.DYMAX.OR.E(IW).LT.0.0)GOTO 1000 IF(LDEBUG)PRINT *,' ++++++ SIGTHR DEBUG : Wire ',IW,' selected' ** Find the y-segment from where the particles reach the wire. IF(IYSET.NE.1)THEN CALL SIGTH3(IW,MAXOPT,IFAIL) IF(IFAIL.NE.0)GOTO 1000 ENDIF ** Store distribution of number of clusters and of cluster sizes. IF(LANTHR)THEN CALL SIGTH4(IFAIL) IF(IFAIL.NE.0)GOTO 1000 ENDIF *** Calculate drift lines from the given x coordinate in the y range. IF(LDEBUG)WRITE(LUNOUT,'('' ++++++ SIGTHR DEBUG : List of'', - '' drift-lines from the accepting segments.'')') ** Open a plot frame if the DRIFTPLOT option is on. IF(LDRPLT)THEN CALL GRAXIS(DXMIN,DYMIN,DXMAX,DYMAX, - 'DRIFT LINES USED FOR THE INTERPOLATION ') CALL CELLAY(DXMIN,DYMIN,DXMAX,DYMAX) IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) IF(GASID.NE.' ')CALL GRCOMM(2,'Gas: '//GASID) * Plot the accepting segment as a dashed line. XPL(1)=XTHR YPL(1)=YTHMIN XPL(2)=XTHR YPL(2)=YTHMAX CALL GRATTS('TRACK','POLYLINE') CALL GPL(2,XPL,YPL) ENDIF ** Loop along the segment, produce 3*NLINTH/4 drift-lines. NLINE=0 IF(LDRPLT)CALL GRATTS('E-DRIFT-LINE','POLYLINE') DO 300 IL=1,3*NLINTH/4 * Check number of drift-lines. IF(NLINE+1.GT.MXLIST)THEN IF(LDEBUG)PRINT *,' ++++++ SIGTHR DEBUG : NLINE = MXLIST.' GOTO 390 ENDIF * Calculate a drift-line. YSTART=YTHMIN+REAL(IL-1)*(YTHMAX-YTHMIN)/REAL(3*NLINTH/4-1) CALL DLCALC(XTHR,YSTART,0.0,-1.0,1) * Plot and print the data if requested. IF(NU.GT.2.AND.LDRPLT)CALL GPL2(NU,XU,YU) * Add the new drift-line to the table if it leads to the wire. IF(ISTAT.EQ.IW)THEN NLINE=NLINE+1 TIMDIF(NLINE,1)=YSTART TIMDIF(NLINE,2)=TU(NU) CALL DLCDIF(TIMDIF(NLINE,3)) IF(LDEBUG)WRITE(LUNOUT,'(2X,''y='',E15.8,'', t='', - E15.8,'', s='',E10.3,'', ISTAT='',I4,'',NU='', - I3)') YSTART,TU(NU),TIMDIF(NLINE,3),ISTAT,NU ELSE PRINT *,' !!!!!! SIGTHR WARNING : Wire ',IW,' lost; fix', - ' via interpolation attempted, this may result in a', - ' degraded accuracy.' ENDIF * Proceed with the next drift-line. 300 CONTINUE *** Skip this wire if less than 4 drift-lines have been found. IF(NLINE.LT.4)THEN PRINT *,' !!!!!! SIGTHR WARNING : Insufficient data for', - ' wire ',IW,', 4 points are needed ; wire skipped.' IF(LDRPLT)THEN CALL GRNEXT CALL GRALOG('Drift-lines from the acceptance segment.') ENDIF GOTO 1000 ENDIF ** Next add the other NLINTH/4 drift-lines where delta t is largest. IF(LDEBUG)PRINT *,' ++++++ SIGTHR DEBUG : Adding intermediate', - ' drift-lines at largest t jumps.' DO 360 IL=1,NLINTH/4 * Check number of drift-lines. IF(NLINE+1.GT.MXLIST)THEN IF(LDEBUG)PRINT *,' ++++++ SIGTHR DEBUG : NLINE = MXLIST.' GOTO 390 ENDIF * Locate the largest t jump. DELTAT=ABS(TIMDIF(2,2)-TIMDIF(1,2)) IDMAX=1 DO 370 JL=2,NLINE-1 IF(ABS(TIMDIF(JL+1,2)-TIMDIF(JL,2)).GT.DELTAT)THEN DELTAT=ABS(TIMDIF(JL+1,2)-TIMDIF(JL,2)) IDMAX=JL ENDIF 370 CONTINUE * Shift everything above by one place. DO 380 JL=NLINE,IDMAX+1,-1 DO 385 KL=1,3 TIMDIF(JL+1,KL)=TIMDIF(JL,KL) 385 CONTINUE 380 CONTINUE * Halve the y-step. TIMDIF(IDMAX+1,1)=(TIMDIF(IDMAX,1)+TIMDIF(IDMAX+2,1))/2.0 * Calculate a drift-line from the half-way point. YSTART=TIMDIF(IDMAX+1,1) CALL DLCALC(XTHR,YSTART,0.0,-1.0,1) * Plot and print the data if requested. IF(NU.GT.2.AND.LDRPLT)CALL GPL2(NU,XU,YU) * Add the new drift-line to the table if it leads to the wire. IF(ISTAT.EQ.IW)THEN NLINE=NLINE+1 TIMDIF(IDMAX+1,2)=TU(NU) CALL DLCDIF(TIMDIF(IDMAX+1,3)) IF(LDEBUG)WRITE(LUNOUT,'(2X,''y='',E15.8,'', t='', - E15.8,'', s='',E10.3,'', ISTAT='',I4,'',NU='', - I3)') YSTART,TU(NU),TIMDIF(IDMAX+1,3),ISTAT,NU ELSE PRINT *,' !!!!!! SIGTHR WARNING : Wire ',IW,' lost; fix', - ' via interpolation attempted, this may result in a', - ' degraded accuracy.' ENDIF * Add another line. 360 CONTINUE ** Jump to this point if the maximum number of drift-lines is reached. 390 CONTINUE ** Finish this plot, if plotting has been requested. IF(LDRPLT)THEN CALL GRNEXT CALL GRALOG('Drift-lines from the acceptance segment.') ENDIF * Plot the arrival time distribution. IF(LDEBUG.AND..FALSE.)THEN DO 301 IPL=1,MXLIST XPL(IPL)=TIMDIF(1,1)+REAL(IPL-1)* - (TIMDIF(NLINE,1)-TIMDIF(1,1))/REAL(MXLIST-1) YPL(IPL)=DIVDIF(TIMDIF(1,2),TIMDIF(1,1),NLINE,XPL(IPL),2) 301 CONTINUE CALL GRGRPH(XPL,YPL,MXLIST, - ' y-Axis [cm]', - ' Drift time [microsec]', - 'DRIFT TIME AS A FUNCTION OF Y ') CALL GRATTS('FUNCTION-1','POLYMARKER') CALL GPM(NLINE,TIMDIF(1,1),TIMDIF(1,2)) CALL GRALOG('Drift-time as a function of y. ') CALL GRNEXT DO 302 IPL=1,MXLIST XPL(IPL)=TIMDIF(1,1)+REAL(IPL-1)* - (TIMDIF(NLINE,1)-TIMDIF(1,1))/REAL(MXLIST-1) YPL(IPL)=DIVDIF(TIMDIF(1,3),TIMDIF(1,1),NLINE,XPL(IPL),2) 302 CONTINUE CALL GRGRPH(XPL,YPL,MXLIST, - ' y-Axis [cm]', - ' Integrated Diffusion [microsec]', - 'DIFFUSION AS A FUNCTION OF Y ') CALL GRATTS('FUNCTION-1','POLYMARKER') CALL GPM(NLINE,TIMDIF(1,1),TIMDIF(1,3)) CALL GRALOG('Diffusion as a function of y. ') CALL GRNEXT ENDIF ** Find maximum and minimum arrival time. TMIN=TIMDIF(1,2) TMAX=TIMDIF(1,2) DO 310 I=1,NLINE TMIN=MIN(TMIN,TIMDIF(I,2)-5.0*TIMDIF(I,3)) TMAX=MAX(TMAX,TIMDIF(I,2)+5.0*TIMDIF(I,3)) 310 CONTINUE * Round these values to obtain a sensible time scale. CALL ROUND(TMIN,TMAX,MXLIST,'LARGER',THRSTP) IF(LDEBUG)PRINT *,' ++++++ SIGTHR DEBUG : TMIN=',TMIN, - ', TMAX=',TMAX *** Prepare the analytic calc, integrate the Gaussian diffusion spread. IF(LANTHR)THEN * Initialise the output array and the time scale vectors. DO 320 IT=1,MXLIST FGLOB(IT)=0.0 TIMSCL(IT)=TMIN+REAL(IT-1)*(TMAX-TMIN)/REAL(MXLIST-1) 320 CONTINUE * Interpolate for the first y point. YPOS1=TIMDIF(1,1) TIM1=DIVDIF(TIMDIF(1,2),TIMDIF(1,1),NLINE,YPOS1,2) SIG1=DIVDIF(TIMDIF(1,3),TIMDIF(1,1),NLINE,YPOS1,2) * Loop over the remaining points, set the initial stacksize to 0. NSTACK=0 DO 350 IY=1,MXLIST-1 YPOS2=TIMDIF(1,1)+REAL(IY)*(TIMDIF(NLINE,1)-TIMDIF(1,1))/ - REAL(MXLIST-1) TIM2=DIVDIF(TIMDIF(1,2),TIMDIF(1,1),NLINE,YPOS2,2) SIG2=DIVDIF(TIMDIF(1,3),TIMDIF(1,1),NLINE,YPOS2,2) * Establish the middle point. 330 CONTINUE YPOSM=0.5*(YPOS1+YPOS2) TIMM=DIVDIF(TIMDIF(1,2),TIMDIF(1,1),NLINE,YPOSM,2) SIGM=DIVDIF(TIMDIF(1,3),TIMDIF(1,1),NLINE,YPOSM,2) * Subdivide if needed, provided storage is available. IF((SIG1**2+4*SIGM**2+SIGM**2)/6.0.LT.10*(TIM1-TIM2)**2.AND. - NSTACK.LT.MXSTCK)THEN NSTACK=NSTACK+1 STACK(NSTACK,1)=YPOS2 STACK(NSTACK,2)=TIM2 STACK(NSTACK,3)=SIG2 YPOS2=YPOSM TIM2=TIMM SIG2=SIGM GOTO 330 * Add the new segment, without further subdivision. ELSE DO 340 IT=1,MXLIST IF((TIMSCL(IT)-(TIM1-5.0*SIG1))* - (TIMSCL(IT)-(TIM2+5.0*SIG2)).GT.0)GOTO 340 FGLOB(IT)=FGLOB(IT)+(YPOS2-YPOS1)* - (EXP(-0.5*((TIM1-TIMSCL(IT))/SIG1)**2)/SIG1+ - 4.0*EXP(-0.5*((TIMM-TIMSCL(IT))/SIGM)**2)/SIGM+ - EXP(-0.5*((TIM2-TIMSCL(IT))/SIG2)**2)/SIG2)/ - (6*SQRT(2*PI)*(YTHMAX-YTHMIN)) 340 CONTINUE * Move on to the next subsegment. YPOS1=YPOS2 TIM1=TIM2 SIG1=SIG2 * Return one level in the stack, provided it is not empty. IF(NSTACK.GT.0)THEN YPOS2=STACK(NSTACK,1) TIM2=STACK(NSTACK,2) SIG2=STACK(NSTACK,3) NSTACK=NSTACK-1 GOTO 330 ENDIF ENDIF * Proceed with the next couple of points. 350 CONTINUE ** Open the dataset for storing the FK distributions. CALL SIGTH6('OPEN',FK,0,IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! SIGTHR WARNING : The ANALYTIC flag', - ' is cancelled as a result of the OPEN failure.' LANTHR=.FALSE. GOTO 490 ENDIF * Loop over the clusters. DO 440 K=1,NCMAX * Initialise the distribution for cluster K. DO 410 IFK=1,MXLIST FK(IFK)=0 410 CONTINUE * Loop over the numbers of clusters. DO 450 N=MAX(K,NCMIN),NCMAX IF(PRCLUS(N).LT.1.0E-10)GOTO 450 * Obtain the K'th cluster out of N clusters in all. CALL SIGTH5(FGLOB,N,K,FAUX) * Add this distribution to the sum. DO 420 IFK=1,MXLIST FK(IFK)=FK(IFK)+PRCLUS(N)*FAUX(IFK) 420 CONTINUE * Next number of clusters. 450 CONTINUE * Dump the distribution in external storage. CALL SIGTH6('WRITE',FK,K,IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! SIGTHR WARNING : The ANALYTIC flag', - ' is cancelled as a result of the WRITE failure.' LANTHR=.FALSE. GOTO 490 ENDIF * Next cluster. 440 CONTINUE * Error exit. 490 CONTINUE ENDIF *** Preset the over-all arrival time histogram. DO 730 ICONT=0,MXCHA+1 CONT2(ICONT)=0 730 CONTINUE NENTR2=0 *** Calculate the arrival time distribution of the M'th electron. DO 700 M=MFIRST,MLAST * Prepare a title for the plots. WRITE(TITLE,'(''ARRIVAL TIME DISTRIBUTION (ELECTRON '',I3, - '')'')') M ** Perform the calculation in Monte-Carlo style. IF(LMCCHK)THEN * Reset the histogram to zero. DO 650 I=0,MXCHA+1 CONT1(I)=0 650 CONTINUE NENTR1=0 * Carry out NRNDM global random cycles, resetting the counters. IF(LDEBUG)WRITE(*,'('' '')') DO 640 IRNDM=1,NRNDM IF(LDEBUG.AND.IRNDM.EQ.1000*INT(REAL(IRNDM)/1000.0)) - WRITE(*,'(''+ At random cycle '',I5)') IRNDM YPOS=YTHMIN NPART=0 * Return to this point to process the y=YPOS point. 610 CONTINUE * Generate a new point on the track. YPOS=YPOS+RNDEXP(1.0/CMEAN) IF(YPOS.GT.YTHMAX)GOTO 630 * Find the drift time and the diffusion coefficient for this point. TIMRND=DIVDIF(TIMDIF(1,2),TIMDIF(1,1),NLINE,YPOS,2) SIGRND=DIVDIF(TIMDIF(1,3),TIMDIF(1,1),NLINE,YPOS,2) * Generate a cluster size. CALL HISRAD(CLSDIS,NCLS,0.0D0,1.0D0,CLSRND) * And generate the correponding number of arrival times. DO 620 ICLS=1,INT(CLSRND) IF(NPART.GE.MXCLUS*MXPAIR)THEN PRINT *,' !!!!!! SIGTHR WARNING : Too many particles', - ' have been generated on a track in' PRINT *,' the MC check,', - ' the track is left out of the histograms.' GOTO 640 ENDIF NPART=NPART+1 ARRTIM(NPART)=RNDNOR(TIMRND,SIGRND) * Enter this arrival time in the global histogram. IND=1+INT(REAL(NCHA)*(ARRTIM(NPART)-TMIN)/(TMAX-TMIN)) IF(IND.LT.1)THEN CONT2(0)=CONT2(0)+1 ELSEIF(IND.GT.NCHA)THEN CONT2(NCHA+1)=CONT2(NCHA+1)+1 ELSE CONT2(IND)=CONT2(IND)+1 NENTR2=NENTR2+1 ENDIF 620 CONTINUE ** Perform a new distance cycle. GOTO 610 ** End of the track generating loops, now sort the arrival times. 630 CONTINUE ** Find the M'th particle to arrive and enter in a histogram. IF(M.GT.NPART.OR.NPART.EQ.0)THEN IND=0 NENTR1=NENTR1+1 ELSE CALL FLPSOR(ARRTIM,NPART) IND=1+INT(REAL(NCHA)*(ARRTIM(M)-TMIN)/(TMAX-TMIN)) ENDIF IF(IND.LE.0)THEN CONT1(0)=CONT1(0)+1 ELSEIF(IND.GT.NCHA)THEN CONT1(NCHA+1)=CONT1(NCHA+1) ELSE CONT1(IND)=CONT1(IND)+1 NENTR1=NENTR1+1 ENDIF * Proceed with the next random cycle. 640 CONTINUE * Scale the curve to a unity surface. DO 660 ISCL=1,NCHA CONT1(ISCL)=CONT1(ISCL)*REAL(NCHA)/(NENTR1*(TMAX-TMIN)) 660 CONTINUE * Plot the curve. CALL GRHIST(CONT1,NCHA,TMIN,TMAX, - 'Arrival time [microsec]',TITLE,.TRUE.) CALL GRALOG('Cluster size distribution (Monte-Carlo).') IF(.NOT.LANTHR)CALL GRNEXT ENDIF ** Perform the calculation analytically, if requested. IF(LANTHR)THEN * Preset the electron origin probabilities CMIK. CALL SIGTH1(M,IFAIL) IF(IFAIL.NE.0)GOTO 890 * Preset the output distribution to 0. DO 800 IFM=1,MXLIST FM(IFM)=0 800 CONTINUE * Loop over the clusters. DO 810 K=1,NCMAX * Set the fetch flag to 0, i.e. not yet fetched. IFETCH=0 * Loop over the total number of electrons in the cluster. DO 820 NELEC=1,NCSMAX IF(PRSIZE(NELEC).LT.1.0E-10)GOTO 820 * Loop over the electrons inside the cluster. DO 830 IELEC=1,NELEC * See whether this combination of K and IELEC contributes. IF(CMIK(IELEC,K).LT.1.0E-10)GOTO 830 WRITE(*,'('' contribution from I='',I3,'', N='',I3, - '', M='',I3,'', K='',I3)') IELEC,NELEC,M,K * Fetch the arrival time distribution of the K'th cluster. IF(IFETCH.EQ.0)THEN CALL SIGTH6('READ',FK,K,IFAIL) IF(IFAIL.NE.0)THEN PRINT *,' !!!!!! SIGTHR WARNING : This wire', - ' is skipped for the analytic part.' GOTO 890 ENDIF IFETCH=1 ENDIF * Extract the IELEC'th electron out of NELEC from FK. CALL SIGTH5(FK,NELEC,IELEC,FAUX) * Add this contribution to FM with the relevant factors. DO 840 IFM=1,MXLIST FM(IFM)=FM(IFM)+PRSIZE(NELEC)*CMIK(IELEC,K)*FAUX(IFM) 840 CONTINUE * Next electron from this cluster. 830 CONTINUE * Next number of electrons in the cluster. 820 CONTINUE * Next cluster to arrive. 810 CONTINUE * Plot the curve. IF(.NOT.LMCCHK)THEN CALL GRGRPH(TIMSCL,FM,MXLIST, - ' Arrival time [microsec]', - ' Probability', - TITLE) CALL GRALOG('Arrival time distribution (analytic). ') CALL GRNEXT ENDIF * Overlayed plots (also error exit). 890 CONTINUE IF(LMCCHK)THEN CALL GRATTS('FUNCTION-2','POLYLINE') CALL GPL(MXLIST,TIMSCL,FM) CALL GRALOG('Arrival time distribution (MC + anal). ') CALL GRNEXT ENDIF ENDIF ** Proceed with the electron arriving next globally (M). 700 CONTINUE ** Output the over-all arrival time histogram. IF(LDEBUG.AND.LMCCHK)THEN DO 710 ISCL=1,NCHA CONT2(ISCL)=CONT2(ISCL)*REAL(NCHA)/(NENTR2*(TMAX-TMIN)) 710 CONTINUE CALL GRHIST(CONT2,NCHA,TMIN,TMAX, - 'Arrival time [microsec]', - 'OVER-ALL ARRIVAL TIME DISTRIBUTION',.TRUE.) ENDIF * Perhaps overlay this histogram with the calculated distribution. IF(LDEBUG.AND.LANTHR)THEN IF(LMCCHK)THEN CALL GRATTS('FUNCTION-1','POLYLINE') CALL GPL(MXLIST,TIMSCL,FGLOB) ELSE CALL GRGRPH(TIMSCL,FGLOB,MXLIST, - ' Arrival time [microsec]', - ' Probability', - 'OVER-ALL ARRIVAL TIME DISTRIBUTION ') ENDIF ENDIF * Log the plot and move to the next frame, if it has been made. IF(LDEBUG.AND.(LMCCHK.OR.LANTHR))THEN CALL GRALOG('Over-all arrival time distribution. ') CALL GRNEXT ENDIF *** Close the dataset for FK. IF(LANTHR)CALL SIGTH6('CLOSE',FK,0,IFAIL) *** Proceed with the next wire. 1000 CONTINUE *** Register the amount of CPU time used by this routine. CALL TIMLOG('Calculating thresholds: ') END +DECK,SIGTH1,IF=NEVER. SUBROUTINE SIGTH1(M,IFAIL) *----------------------------------------------------------------------- * SIGTH1 - Auxilliary routine to SIGTHR storing the matrix CMK and * various other variables in /THRDAT/. *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,GASDATA. +SEQ,THRESHDATA. +SEQ,PRINTPLOT. REAL PROB(2,0:MXCLUS*MXPAIR) *** Identify the routine, if requested. IF(LIDENT)PRINT *,' /// ROUTINE SIGTH1 ///' *** Preset IFAIL to 1, i.e. failure. IFAIL=1 *** Preset the convoluted distribution. DO 10 I=0,MXPAIR*MXCLUS IF(I.EQ.0)THEN PROB(1,I)=1 ELSE PROB(1,I)=0 ENDIF PROB(2,I)=0 10 CONTINUE *** Preset the output array to zero. DO 30 I=1,MXPAIR DO 20 K=1,MXCLUS CMIK(I,K)=0 20 CONTINUE 30 CONTINUE *** And preset the largest and smallest non-zero value in PROB. NPRMIN=0 NPRMAX=0 *** Loop over the cluster sizes. DO 170 K=1,NCMAX * Loop over the electrons. DO 120 I=1,NCSMAX * Simple case that I > M, probability is 0. IF(I.GT.M)GOTO 120 * Figure out what C(M,I,K) looks like in the other case. PSUM=0 DO 100 J=I,NCSMAX PSUM=PSUM+PRSIZE(J) 100 CONTINUE CMIK(I,K)=PSUM*PROB(1,M-I) * Next electron. 120 CONTINUE * Skip convoluting in the last loop. IF(K.EQ.NCMAX)GOTO 170 * Convolute once more. DO 140 I=0,MIN(NPRMAX+NCSMAX,MXCLUS*MXPAIR) PROB(2,I)=0 DO 130 J=MAX(0,I-NPRMAX),MIN(I,NCSMAX,I-NPRMIN) PROB(2,I)=PROB(2,I)+PRSIZE(J)*PROB(1,I-J) 130 CONTINUE 140 CONTINUE * Move the convoluted distribution to PROB(1, ... ). NPRMIN=-1 NPRMAX=-1 PSUM=0 DO 150 I=0,MXCLUS*MXPAIR PROB(1,I)=PROB(2,I) IF(PROB(1,I).GT.1.0E-10)THEN IF(NPRMIN.EQ.-1)NPRMIN=I NPRMAX=I ELSE PROB(1,I)=0.0 ENDIF PSUM=PSUM+PROB(1,I) 150 CONTINUE * Check that some probability is left. IF(NPRMIN.EQ.-1.OR.NPRMAX.EQ.-1)THEN PRINT *,' !!!!!! SIGTH1 WARNING : Distribution vanished', - ' at convolution loop ',K,'.' RETURN ENDIF * And normalise the distribution again. IF(ABS(PSUM-1.0).GT.1.0E-5.AND.LDEBUG)PRINT *,' ++++++ SIGTH1', - ' DEBUG : Normalisation deviation, PSUM=',PSUM,'.' DO 160 INORM=0,MXPAIR*MXCLUS PROB(1,INORM)=PROB(1,INORM)/PSUM 160 CONTINUE * Next cluster size. 170 CONTINUE *** Convolution completed, set IFAIL to 0 and return. IFAIL=0 END +DECK,SIGTH3,IF=NEVER. SUBROUTINE SIGTH3(IW,MAXOPT,IFAIL) *----------------------------------------------------------------------- * SIGTH3 - Searches for the y segment at x=XTHR from where particles * reach the wire IW. *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,CELLDATA. +SEQ,GASDATA. +SEQ,DRIFTLINE. +SEQ,THRESHDATA. +SEQ,PRINTPLOT. +SEQ,CONSTANTS. +SEQ,PARAMETERS. LOGICAL CROSS EXTERNAL CROSS REAL XTHR,YTHR,QTHR *** Identify the routine if requested. IF(LIDENT)PRINT *,' /// ROUTINE SIGTH3 ///' *** Initialise the IFAIL flag to 1, i.e. failure. IFAIL=1 *** Open a plot frame if the DRIFT-PLOT option is on. IF(LDRPLT)THEN CALL GRAXIS(DXMIN,DYMIN,DXMAX,DYMAX, - 'SEARCH FOR THE ACCEPTANCE SEGMENT ') CALL CELLAY(DXMIN,DYMIN,DXMAX,DYMAX) IF(CELLID.NE.' ')CALL GRCOMM(1,'Cell: '//CELLID) IF(GASID.NE.' ')CALL GRCOMM(2,'Gas: '//GASID) ENDIF *** Start with a rather pessimistic guess of the y range. YTHMAX=Y(IW) YTHMIN=Y(IW) ICROSS=0 QTHR=+1.0 DO 20 IL=1,NLINED CALL DLCALC(X(IW)+0.51*D(IW)*COS(REAL(IL)*2.0*PI/REAL(NLINED)), - Y(IW)+0.51*D(IW)*SIN(REAL(IL)*2.0*PI/REAL(NLINED)),0.0, - QTHR,1) IF(NU.GT.2.AND.LDRPLT)CALL GPL2(NU,XU,YU) DO 10 IU=1,NU-1 IF(CROSS(REAL(XU(IU)),REAL(YU(IU)),REAL(XU(IU+1)),REAL(YU(IU+1)), - XTHR,DYMIN,XTHR,DYMAX))THEN YTHMIN=MIN(REAL(MAX(YU(IU),YU(IU+1))),YTHMIN) YTHMAX=MAX(REAL(MIN(YU(IU),YU(IU+1))),YTHMAX) ICROSS=1 ENDIF 10 CONTINUE 20 CONTINUE * Check the y-range is non-zero. IF(YTHMIN.GE.YTHMAX.OR.ICROSS.EQ.0)THEN IF(LDRPLT)THEN CALL GRNEXT CALL GRALOG('Failed search for the acceptance region.') ENDIF PRINT *,' !!!!!! SIGTH3 WARNING : x=',XTHR,' seems to be', - ' unreachable from wire ',IW,' ; the wire is skipped.' RETURN ENDIF * Debug output. IF(LDEBUG)PRINT *,' ++++++ SIGTH3 DEBUG : Raw y-range : ', - YTHMIN,YTHMAX *** Refine this estimate, first for the upper boundary. IF(LDEBUG)PRINT *,' ++++++ SIGTH3 DEBUG : Refinement of the', - ' upper bound of the y-range.' * Set the initial step size for the success-failure algorithm. STEP=MIN((YTHMAX-YTHMIN)/2.0,1.1*(DYMAX-YTHMAX)) * Set the charge for the normal drift-lines. QTHR=-1.0 * Carry out at most MAXOPT refinement loops. ICONV=0 DO 30 IOPT=1,MAXOPT YTHR=YTHMAX+STEP * Set a flag in case the point to be sampled lies outside the area. IF(YTHR.GT.DYMAX)THEN YTHR=DYMAX-(DYMAX-DYMIN)/1000.0 IBOUND=1 ELSE IBOUND=0 ENDIF * Calculate a drift-line from the sample point. CALL DLCALC(XTHR,YTHR,0.0,QTHR,1) IF(NU.GT.2.AND.LDRPLT)CALL GPL2(NU,XU,YU) IF(LDEBUG)PRINT '('' ++++++ SIGTH3 DEBUG : IOPT='',I2, - '' y='',E12.5,'', ISTAT='',I4,'', NU='',I3,'', IBOUND='', - I1)',IOPT,YTHR,ISTAT,NU,IBOUND * Extra check of ISTAT if the boundary flag has been set. IF(IBOUND.EQ.1.AND.ISTAT.EQ.IW)THEN IF(LDEBUG)PRINT *,' ++++++ SIGTH3 DEBUG : The upper', - ' AREA boundary is satisfactory.' ICONV=1 YTHMAX=YTHR GOTO 40 ENDIF * Otherwise modify YTHMAX or STEP, depending on the status. IF(ISTAT.EQ.IW)THEN YTHMAX=YTHR ELSE ICONV=1 ENDIF STEP=STEP/2.0 30 CONTINUE * Check the process has converged to some extent. 40 CONTINUE IF(ICONV.EQ.0.AND.MAXOPT.GT.0)THEN PRINT *,' !!!!!! SIGTH3 WARNING : The refinement process', - ' for the upper y bound failed; wire ',IW,' skipped.' IF(LDRPLT)THEN CALL GRNEXT CALL GRALOG('Failed search for the acceptance region.') ENDIF RETURN ENDIF *** Refine the estimate for the lower y boundary. IF(LDEBUG)PRINT *,' ++++++ SIGTH3 DEBUG : Refinement of the', - ' lower bound of the y-range.' * Set the initial step size for the success-failure algorithm. STEP=MIN((YTHMAX-YTHMIN)/2.0,1.1*(YTHMIN-DYMIN)) * Carry out at most MAXOPT refinement loops. ICONV=0 DO 50 IOPT=1,MAXOPT YTHR=YTHMIN-STEP * Set a flag in case the point to be sampled lies outside the area. IF(YTHR.LT.DYMIN)THEN YTHR=DYMIN+(DYMAX-DYMIN)/1000.0 IBOUND=1 ELSE IBOUND=0 ENDIF * Calculate a drift-line from the sample point. CALL DLCALC(XTHR,YTHR,0.0,QTHR,1) IF(NU.GT.2.AND.LDRPLT)CALL GPL2(NU,XU,YU) IF(LDEBUG)PRINT '('' ++++++ SIGTH3 DEBUG : IOPT='',I2, - '' y='',E12.5,'', ISTAT='',I4,'', NU='',I3,'', IBOUND='', - I1)',IOPT,YTHR,ISTAT,NU,IBOUND * Extra check of ISTAT if the boundary flag has been set. IF(IBOUND.EQ.1.AND.ISTAT.EQ.IW)THEN IF(LDEBUG)PRINT *,' ++++++ SIGTH3 DEBUG : The lower', - ' AREA boundary is satisfactory.' ICONV=1 YTHMIN=YTHR GOTO 60 ENDIF * Otherwise modify YTHMIN or STEP, depending on the status. IF(ISTAT.EQ.IW)THEN YTHMIN=YTHR ELSE ICONV=1 ENDIF STEP=STEP/2.0 50 CONTINUE * Check the process has converged to some extent. 60 CONTINUE IF(ICONV.EQ.0.AND.MAXOPT.GT.0)THEN PRINT *,' !!!!!! SIGTH3 WARNING : The refinement process', - ' for the lower y bound failed; wire ',IW,' skipped.' IF(LDRPLT)THEN CALL GRNEXT CALL GRALOG('Failed search for the acceptance region.') ENDIF RETURN ENDIF *** Make the y-range a fraction smaller to avoid boundary problems. DY=YTHMAX-YTHMIN YTHMIN=YTHMIN+0.001*DY YTHMAX=YTHMAX-0.001*DY *** Debug output. IF(LDEBUG)PRINT *,' ++++++ SIGTH3 DEBUG : Refined y-range : ', - YTHMIN,YTHMAX *** Finish this plot, if plotting has been requested. IF(LDRPLT)THEN CALL GRNEXT CALL GRALOG('Searching the acceptance region. ') ENDIF *** Things apparently worked well. IFAIL=0 END +DECK,SIGTH4,IF=NEVER. SUBROUTINE SIGTH4(IFAIL) *----------------------------------------------------------------------- * SIGTH4 - Auxilliary routine to SIGTHR calculating the probability * that a given total number of clusters is formed and to * compute the cluster-size distribution. *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,THRESHDATA. +SEQ,GASDATA. +SEQ,CONSTANTS. +SEQ,PRINTPLOT. REAL XPL(MXLIST),YPL(MXLIST) *** Identify the routine if requested. IF(LIDENT)PRINT *,' /// ROUTINE SIGTH4 ///' *** Preset IFAIL to 1, i.e. fail. IFAIL=1 *** Calculate the distribution of the number of clusters, debug output. IF(LDEBUG)PRINT *,' ++++++ SIGTH4 DEBUG : Mean number', - ' of clusters on the segment: ',CMEAN*(YTHMAX-YTHMIN) IF(CMEAN*(YTHMAX-YTHMIN).LT.50.0)THEN ** Use the Poisson distribution, if the number of particles is small. IF(LDEBUG)PRINT *,' ++++++ SIGTH4 DEBUG : The', - ' Poisson distribution is applied directly.' DO 20 N=0,MXCLUS PRCLUS(N)=EXP(-CMEAN*(YTHMAX-YTHMIN)) DO 10 M=1,N IF(REAL(M).GT.CMEAN*(YTHMAX-YTHMIN).AND. - PRCLUS(N).LT.1.0E-10)THEN PRCLUS(N)=0.0 GOTO 20 ENDIF PRCLUS(N)=PRCLUS(N)*CMEAN*(YTHMAX-YTHMIN)/FLOAT(M) 10 CONTINUE 20 CONTINUE ELSE ** Use the Gaussian approximation instead if there are many particles. IF(LDEBUG)PRINT *,' ++++++ SIGTH4 DEBUG : The', - ' Gaussian approximation is used.' DO 30 N=0,MXCLUS ARG=0.5*(REAL(N)-CMEAN*(YTHMAX-YTHMIN))**2/ - (CMEAN*(YTHMAX-YTHMIN)) IF(ARG.LT.50.0)THEN PRCLUS(N)=EXP(-ARG)/SQRT(2*PI*CMEAN*(YTHMAX-YTHMIN)) ELSE PRCLUS(N)=0.0 ENDIF 30 CONTINUE ENDIF ** Find out in which range this distribution is effectively non-zero. NCMIN=-1 NCMAX=-1 PSUM=0.0 DO 40 I=0,MXCLUS IF(PRCLUS(I).GT.1.0E-10)THEN IF(NCMIN.EQ.-1)NCMIN=I NCMAX=I ENDIF PSUM=PSUM+PRCLUS(I) 40 CONTINUE * Check whether there are non-zero values. IF(NCMIN.EQ.-1.OR.NCMAX.EQ.-1)THEN PRINT *,' !!!!!! SIGTH4 WARNING : The particle number', - ' distribution is flat; the wire is skipped.' IFAIL=1 RETURN ENDIF * Warn if the integral differs significantly from 1. IF(ABS(PSUM-1.0).GT.1.0E-4)THEN PRINT *,' !!!!!! SIGTH4 WARNING : The distribution of the', - ' number of clusters doesn''t integrate to 1.' PRINT *,' (Integral=',PSUM,')', - ' increasing MXCLUS might help.' ENDIF ** Debugging output. IF(.FALSE..AND.LDEBUG)THEN * Print the range of the distribution. WRITE(*,'('' ++++++ SIGTH4 DEBUG : Effective range'', - '' particle number distr: '',I3,'' to '',I3)') - NCMIN,NCMAX * And plot the distribution. NPL=0 DO 50 I=NCMIN,NCMAX IF(NPL.LT.MXLIST)THEN NPL=NPL+1 XPL(NPL)=I YPL(NPL)=PRCLUS(I) ENDIF 50 CONTINUE CALL GRGRPH(XPL,YPL,NPL, - ' Number of clusters', - ' Probability', - 'DISTRIBUTION OF THE NUMBER OF CLUSTERS ') CALL GRALOG('Plot of the cluster number probabilities') CALL GRNEXT ENDIF *** Set the cluster-size probabilities. NCSMAX=-1 PSUM=0 DO 60 I=0,MXPAIR IF(I.EQ.0)THEN PRSIZE(0)=CLSDIS(1) ELSEIF(I.LT.NCLS)THEN PRSIZE(I)=CLSDIS(I+1)-CLSDIS(I) ELSE PRSIZE(I)=0.0 ENDIF PSUM=PSUM+PRSIZE(I) IF(PRSIZE(I).GT.1.0E-10)NCSMAX=I 60 CONTINUE * Check that non-zero probabilities are present. IF(NCSMAX.EQ.-1)THEN PRINT *,' !!!!!! SIGTH4 WARNING : No non-zero cluster-size', - ' probabilities found.' RETURN ENDIF * Check that probabilities add up to 1. IF(ABS(PSUM-1.0).GT.1.0E-5)THEN PRINT *,' !!!!!! SIGTH4 WARNING : Total cluster-size', - ' probability ',PSUM RETURN ENDIF * Generate some debugging output. IF(LDEBUG)PRINT *,' ++++++ SIGTH4 DEBUG : Maximum', - ' cluster-size contributing: ',NCSMAX *** Apparently things worked well. IFAIL=0 END +DECK,SIGTH5,IF=NEVER. SUBROUTINE SIGTH5(FALL,N,K,FNK) *----------------------------------------------------------------------- * SIGTH5 - Auxiliary routine tyo SIGTHR extracting the K'th electron * from a distribution of N electrons. The relevant formulae * are explained in the writeup. * VARIABLES : FALL : The over-all distribution * FNK : The distribution of electron K out of N. * SUMLOW : Integral over FALL from -inf to t. * SUMUP : Integral over FALL from t to +inf. *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,THRESHDATA. EXTERNAL KBINOM REAL FALL(MXLIST),FNK(MXLIST) *** Loop over all points in the distribution. DO 30 I=1,MXLIST * Initialise with the K * (N over K) * F overall part. FNK(I)=FALL(I)*REAL(K)*KBINOM(N,K) * Approximate the F- integral. IF(K.GT.1)THEN SUMLOW=FALL(I)/2.0 DO 10 J=1,I-1 SUMLOW=SUMLOW+FALL(J) 10 CONTINUE SUMLOW=SUMLOW*(TMAX-TMIN)/REAL(MXLIST-1) IF(SUMLOW.LE.0.0)THEN FNK(I)=0.0 ELSEIF(LOG10(SUMLOW)*REAL(K-1).LT.-25.0)THEN FNK(I)=0.0 ELSE FNK(I)=FNK(I)*SUMLOW**(K-1) ENDIF ENDIF * Approximate the F+ integral. IF(N.GT.K)THEN SUMUP=FALL(I)/2.0 DO 20 J=I+1,MXLIST SUMUP=SUMUP+FALL(J) 20 CONTINUE SUMUP=SUMUP*(TMAX-TMIN)/REAL(MXLIST-1) IF(SUMUP.LE.0.0)THEN FNK(I)=0.0 ELSEIF(LOG10(SUMUP)*REAL(N-K).LT.-25.0)THEN FNK(I)=0.0 ELSE FNK(I)=FNK(I)*SUMUP**(N-K) ENDIF ENDIF * Next data-point. 30 CONTINUE END +DECK,SIGTH6,IF=NEVER. SUBROUTINE SIGTH6(ACTION,DIST,NUMBER,IFAIL) *----------------------------------------------------------------------- * SIGTH5 - Auxilliary routine to SIGTHR handling an auxiliary file on * unit 15 storing probability distributions. * compute the cluster-size distribution. * VARIABLES : ACTION : Dataset operation to be performed. * DIST : The distribution to be written/read. * NUMBER : Reference number for the distribution. * OPEN : Keeps track of the unit status. * OPENED : Used with INQUIRE to find the unit status. *----------------------------------------------------------------------- +SEQ,DIMENSIONS. +SEQ,PRINTPLOT. REAL DIST(MXLIST) CHARACTER*(*) ACTION LOGICAL OPEN,OPENED +SELF,IF=CMS. CHARACTER*80 FILDEF +SELF,IF=SAVE. SAVE OPEN +SELF. DATA OPEN /.FALSE./ *** Identify the routine if requested. IF(LIDENT)PRINT *,' /// ROUTINE SIGTH6 ///' *** Initialise IFAIL to 1, i.e. fail. IFAIL=1 *** Open the dataset if ACTION='OPEN'. IF(ACTION.EQ.'OPEN')THEN * Check that the maximum record-length will not be exceeded. IF(4+MXLIST*4.GT.MXRECL)THEN PRINT *,' ###### SIGTH6 ERROR : Unable to allocate', - ' storage space ; increase MXRECL' PRINT *,' or decrease MXLIST', - ' such that MXRECL > 4 + 4*MXLIST.' RETURN ENDIF * Check that the dataset is not already opened. INQUIRE(UNIT=15,OPENED=OPENED) IF(OPENED)THEN PRINT *,' !!!!!! SIGTH6 WARNING : Unit 15 is open', - ' while it should be closed ; attempt to close.' CLOSE(UNIT=15,IOSTAT=IOS,ERR=2030) ENDIF * Open the dataset. +SELF,IF=CMS. WRITE(FILDEF,'(''FILEDEF 15 DISK GARFTEMP THRESH A6'', - '' (CHANGE XTENT '',I4)') MXLIST CALL VMCMS(FILDEF,IRC) IF(IRC.NE.0)THEN PRINT *,' !!!!!! SIGTH6 WARNING : Error issuing a', - ' FILEDEF for the threshold dataset.' GOTO 2020 ENDIF +SELF. OPEN(UNIT=15,STATUS='SCRATCH',ACCESS='DIRECT', - RECL=4+MXLIST*4,FORM='UNFORMATTED',IOSTAT=IOS,ERR=2020) IF(LDEBUG)PRINT *,' ++++++ SIGTH6 DEBUG : Dataset opened', - ' on unit 15 with RECL=',4+MXLIST*4 * Keep track of opening. OPEN=.TRUE. *** Close the dataset if ACTION='CLOSE'. ELSEIF(ACTION.EQ.'CLOSE')THEN * Check that the dataset is really opened. INQUIRE(UNIT=15,OPENED=OPENED) * And close if it is, otherwise print an error message. IF(OPENED)THEN CLOSE(UNIT=15,IOSTAT=IOS,ERR=2030) IF(LDEBUG)PRINT *,' ++++++ SIGTH6 DEBUG : Dataset', - ' on unit 15 has been closed.' ELSE PRINT *,' !!!!!! SIGTH6 WARNING : Unit 15 is already', - ' closed ; program bug - please report.' ENDIF OPEN=.FALSE. *** Write the record if ACTION='WRITE'. ELSEIF(ACTION.EQ.'WRITE')THEN * Check the reference number. IF(NUMBER.LT.1.OR.NUMBER.GT.1000)THEN PRINT *,' ###### SIGTH6 ERROR : Record reference', - ' number (',NUMBER,') out of range ; program bug.' RETURN * Check the dataset status. ELSEIF(.NOT.OPEN)THEN PRINT *,' ###### SIGTH6 ERROR : No dataset has been', - ' opened ; program bug - please report.' RETURN ENDIF * Perform the write operation. WRITE(UNIT=15,REC=NUMBER,IOSTAT=IOS,ERR=2010) DIST *** Retrieve the record if ACTION='READ'. ELSEIF(ACTION.EQ.'READ')THEN * Check the reference number. IF(NUMBER.LT.1.OR.NUMBER.GT.1000)THEN PRINT *,' ###### SIGTH6 ERROR : Record reference', - ' number (',NUMBER,') out of range ; program bug.' RETURN * Check the dataset status. ELSEIF(.NOT.OPEN)THEN PRINT *,' ###### SIGTH6 ERROR : No dataset has been', - ' opened ; program bug - please report.' RETURN ENDIF * Preset the record to 0, in case of errors. DO 10 I=1,MXLIST DIST(I)=0 10 CONTINUE * Perform the read operation. READ(UNIT=15,REC=NUMBER,IOSTAT=IOS,ERR=2010) DIST *** Unknown instruction. ELSE PRINT *,' ###### SIGTH6 ERROR : Invalid instruction ', - ACTION,' received; program bug - please report.' RETURN ENDIF *** Apparently things worked. IFAIL=0 RETURN *** Handle I/O problems. 2010 CONTINUE PRINT *,' !!!!!! SIGTH6 ERROR : I/O error on the dataset for'// - ' storing THRESHOLD probability distributions.' PRINT *,' Probably attempt to retrieve'// - ' a non-existing record.' CALL INPIOS(IOS) RETURN 2020 CONTINUE PRINT *,' !!!!!! SIGTH6 ERROR : Unable to open a dataset for'// - ' storing THRESHOLD probability distributions on unit 15.' CALL INPIOS(IOS) RETURN 2030 CONTINUE PRINT *,' !!!!!! SIGTH6 ERROR : Unable to close a dataset for', - ' storing THRESHOLD probability distributions on unit 15.' CALL INPIOS(IOS) RETURN END +PATCH,AUXILIARY,T=DATA. +DECK,CLD,IF=VAX. +SELF,IF=FRONTEND. DECK ID>, GARFRUNCLD.CLD +SELF,IF=-FRONTEND. DECK ID>, GARFIELDCLD.CLD +SELF. !==============================================================================! ! Garfield command language definition file for Vax computers. ! ! Valid for versions 5.12 and higher, can be used with version 4. ! ! Since version 5.12, there is one common CLD file for all graphics systems. ! ! ! ! This file is to be compiled with the command: ! ! ! ! SET COMMAND GARFIELDCLD.CLD /OBJECT=GARFIELDCLD.OBJ ! ! ! ! and should then be linked with the main program and with the front-end ! ! program. ! ! ! ! The advice from Bert Driehuis /VNG and C.W. Hobbs /DEC is gratefully ! ! acknowledged. ! ! ! ! Gopyright: Rob Veenhof, 2000. ! !==============================================================================! module GARFCLD define type TERMINAL_GTS keyword TYPE ! Terminal type chosen from list label=TERM_TYPE ! value(type=TERM_TYPE_GTS,required) ! keyword GKS_IDENTIFIER ! Terminal specified by identifier label=TERM_GKSID ! value(type=$number,required) ! keyword CONNECTION_IDENTIFIER ! Connection identifier label=TERM_CONID ! value(type=$number,required) ! define type TERM_TYPE_GTS ! Digital GTS-GRAL workstation keyword VT100_RETROGRAPHICS ! 1001 keyword VT100_SELENAR ! 1002 keyword VT125_REGIS ! 1010 keyword VT240_REGIS ! 1020 keyword VT241_REGIS ! 1021 keyword VT340 ! 1030 keyword VAXSTATION ! 8601 ! Pericom keyword PG7800, default ! 7878 keyword MG600 ! 7800 keyword MX2000 ! 221 keyword MX7000 ! 221 keyword MX8000 ! 227 ! Tektronix keyword 4010 ! 101 keyword 4012 ! 102 keyword 4014 ! 101 keyword 4015 ! 103 keyword 4105 ! 110 keyword 4107 ! 121 keyword 4207 ! 121 keyword 4109 ! 122 keyword 4209 ! 122 keyword 4111 ! 123 keyword 4113 ! 125 keyword 4114 ! 127 keyword 4115 ! 127 ! Falco keyword Falco ! 114 ! X-windows keyword X_windows ! 32120 keyword X_windows_0 ! 32120 keyword X_windows_1 ! 32121 keyword X_windows_2 ! 32122 keyword X_windows_3 ! 32123 keyword X_windows_4 ! 32124 keyword X_windows_5 ! 32125 keyword X_windows_6 ! 32126 keyword X_windows_7 ! 32127 keyword X_windows_8 ! 32128 keyword X_windows_9 ! 32129 define type TERMINAL_DEC keyword TYPE ! Terminal type chosen from list label=TERM_TYPE ! value(type=TERM_TYPE_DEC,required) ! keyword GKS_IDENTIFIER ! Terminal specified by identifier label=TERM_GKSID ! value(type=$number,required) ! keyword CONNECTION_IDENTIFIER ! Connection identifier label=TERM_CONID ! value(type=$number,required) ! define type TERM_TYPE_DEC ! Logical DEC GKS workstation type keyword Logical ! 0 ! Digital keyword VT125_COLOUR ! 11 keyword VT125_BW ! 12 keyword VT240_COLOUR ! 13 keyword VT240_BW ! 14 keyword VT330 ! 16 keyword VT340 ! 17 keyword VAXSTATION_1 ! 42 keyword VAXSTATION_2 ! 41 keyword VS_1 ! 42 keyword VS_2 ! 41 keyword VS_2000 ! 41 keyword DECWINDOWS ! 211 ! Tektronix keyword 4014 ! 72 keyword 4017 ! 82 define type TERMINAL_ATC keyword TYPE ! Terminal type chosen from list label=TERM_TYPE ! value(type=TERM_TYPE_ATC,required) ! keyword GKS_IDENTIFIER ! Terminal specified by identifier label=TERM_GKSID ! value(type=$number,required) ! keyword CONNECTION_IDENTIFIER ! Connection identifier label=TERM_CONID ! value(type=$number,required) ! define type TERM_TYPE_ATC ! Digital ATC_GKS workstation type keyword VT125_REGIS ! 2600 keyword VT240_REGIS ! 2601 keyword VT241_REGIS ! 2602 keyword VT330 ! 2603 keyword VT340 ! 2604 keyword VT340_COLOUR ! 2605 ! Tektronix keyword 4010 ! 2500 keyword COMP_4010 ! 2501 keyword 4014 ! 2400 keyword 4105 ! 2300 keyword PIX_4105 ! 2301 keyword COMP_4105 ! 2302 keyword 4107 ! 3100 keyword 12B_4107 ! 3101 keyword 4205 ! 3102 keyword 12B_4205 ! 3103 keyword 4208 ! 3104 keyword 12B_4208 ! 3105 keyword 4111 ! 3200 keyword 32B_4111 ! 3201 keyword 4115 ! 3202 keyword 32B_4115 ! 3203 keyword 4125 ! 3204 keyword 32B_4125 ! 3205 ! C-ITOH 414A keyword CIT_414A ! 2502 ! Graphon 140, 230 keyword GRAPHON ! 2506 ! Imagen keyword LAND_IMG ! 6300 keyword PORT_IMG ! 6301 ! Retrographics VT640 keyword RETRO ! 3203 ! X11 keyword X11 ! 5300 ! X11 (back and store) keyword BS_X11 ! 5350 define type TERMINAL_HIGZ keyword TYPE ! Terminal type chosen from list label=TERM_TYPE ! value(type=TERM_TYPE_HIGZ,required) ! keyword GKS_IDENTIFIER ! Terminal specified by identifier label=TERM_GKSID ! value(type=$number,required) ! keyword CONNECTION_IDENTIFIER ! Connection identifier label=TERM_CONID ! value(type=$number,required) ! define type TERM_TYPE_HIGZ keyword 0 ! No terminal graphics output keyword inquire, default ! Request terminal inquiry keyword 1 ! From HIGZ_WINDOWS.DAT keyword 2 ! From HIGZ_WINDOWS.DAT keyword 3 ! From HIGZ_WINDOWS.DAT keyword 4 ! From HIGZ_WINDOWS.DAT keyword 5 ! From HIGZ_WINDOWS.DAT keyword 6 ! From HIGZ_WINDOWS.DAT keyword 7 ! From HIGZ_WINDOWS.DAT keyword 8 ! From HIGZ_WINDOWS.DAT keyword 9 ! From HIGZ_WINDOWS.DAT keyword FALCO ! Falco terminal keyword XTERM ! X-terminal define type METAFILE_GTS keyword TYPE ! Metafile type chosen from list label=META_TYPE ! value(type=META_TYPE_GTS,required) ! keyword GKS_IDENTIFIER ! Metafile type via GKS identifier label=META_GKSID ! value(type=$number,required) ! keyword NAME ! File name of the metafile label=META_NAME ! value(type=$outfile,required) ! keyword OFFSET ! Logical unit offset label=META_OFFSET ! value(type=$number,required) ! define type META_TYPE_GTS keyword APPENDIX_E ! 4 keyword POSTSCRIPT, default ! 12203 keyword PS_PORTRAIT_COLOUR ! 12201 keyword PS_LANDSCAPE_COLOUR ! 12202 keyword PS_PORTRAIT_BW ! 12203 keyword PS_LANDSCAPE_BW ! 12204 keyword ENCAPSULATED_PS ! 12203 keyword EPS_PORTRAIT_COLOUR ! 12201 keyword EPS_LANDSCAPE_COLOUR ! 12202 keyword EPS_PORTRAIT_BW ! 12203 keyword EPS_LANDSCAPE_BW ! 12204 define type METAFILE_DEC keyword TYPE ! Metafile type chosen from list label=META_TYPE ! value(type=META_TYPE_DEC,required) ! keyword GKS_IDENTIFIER ! Metafile type via GKS identifier label=META_GKSID ! value(type=$number,required) ! keyword NAME ! File name of the metafile label=META_NAME ! value(type=$outfile,required) ! keyword OFFSET ! Logical unit offset label=META_OFFSET ! value(type=$number,required) ! define type META_TYPE_DEC keyword POSTSCRIPT, default ! 61 keyword PS ! 61 keyword METAFILE ! 2 keyword DECGKS_MO ! 2 keyword CGM ! 7 keyword LCP01 ! 15 keyword LCG01 ! 15 keyword LN03 ! 38 ! Hewlett-Packard keyword HP7475 ! 51 keyword HP7550 ! 53 keyword HP7580 ! 54 keyword HP7585 ! 56 ! Canon keyword LBP8A2 ! 531 ! Kyocera keyword L880 ! 532 define type METAFILE_ATC keyword TYPE ! Metafile type chosen from list label=META_TYPE ! value(type=META_TYPE_ATC,required) ! keyword GKS_IDENTIFIER ! Metafile type via GKS identifier label=META_GKSID ! value(type=$number,required) ! keyword NAME ! File name of the metafile label=META_NAME ! value(type=$outfile,required) ! keyword OFFSET ! Logical unit offset label=META_OFFSET ! value(type=$number,required) ! define type META_TYPE_ATC keyword CGM_BIN ! 10100 keyword CGM_MBIN ! 10101 keyword CGM_CHAR ! 10110 keyword CGM_TEXT ! 10120 keyword CGM_LBIN ! 10150 keyword CGM_LCHAR ! 10160 keyword CGM_LTEXT ! 10170 ! ATC Postscript keyword POSTSCRIPT, default ! 1900 keyword PS_PORTRAIT_COLOUR ! 1900 keyword PS_LANDSCAPE_COLOUR ! 1901 keyword PS_PORTRAIT_BW ! 1900 keyword PS_LANDSCAPE_BW ! 1901 keyword ENCAPSULATED_PS ! 1900 keyword EPS_PORTRAIT_COLOUR ! 1900 keyword EPS_LANDSCAPE_COLOUR ! 1901 keyword EPS_PORTRAIT_BW ! 1900 keyword EPS_LANDSCAPE_BW ! 1901 define type METAFILE_HIGZ keyword TYPE ! Metafile type chosen from list label=META_TYPE ! value(type=META_TYPE_HIGZ,required) ! keyword GKS_IDENTIFIER ! Metafile type via GKS identifier label=META_GKSID ! value(type=$number,required) ! keyword NAME ! File name of the metafile label=META_NAME ! value(type=$outfile,required) ! keyword OFFSET ! Logical unit offset label=META_OFFSET ! value(type=$number,required) ! define type META_TYPE_HIGZ keyword POSTSCRIPT, default ! PostScript keyword PS_LANDSCAPE ! keyword PS_PORTRAIT ! keyword EPS ! Encapsulated PS keyword ENCAPSULATED_PS ! keyword ENCAPSULATED_POSTSCRIPT ! keyword LATEX ! LaTeX define verb GARFIELD qualifier OLD placement=global nonnegatable qualifier PRO placement=global nonnegatable qualifier NEW placement=global nonnegatable qualifier EXP placement=global nonnegatable qualifier DEBUG placement=global negatable qualifier IDENTIFICATION placement=global negatable qualifier INPUT_LISTING placement=global negatable qualifier RNDM_INITIALISATION placement=global negatable default qualifier RECORDING placement=global negatable default qualifier PROGRESS_PRINT placement=global negatable default qualifier PROFILE placement=global negatable default qualifier SYNCHRONISE placement=global negatable disallow any2(GKS, GTS_GRAL, DEC_GKS, ATC_GKS, HIGZ) qualifier HIGZ placement=global syntax=GARFIELD_HIGZ default qualifier GKS placement=global syntax=GARFIELD_GTS qualifier GTS_GRAL placement=global syntax=GARFIELD_GTS qualifier DEC_GKS placement=global syntax=GARFIELD_DEC qualifier ATC_GKS placement=global syntax=GARFIELD_ATC define syntax GARFIELD_GTS qualifier OLD placement=global nonnegatable qualifier PRO placement=global nonnegatable qualifier NEW placement=global nonnegatable qualifier EXP placement=global nonnegatable qualifier DEBUG placement=global negatable qualifier IDENTIFICATION placement=global negatable qualifier INPUT_LISTING placement=global negatable qualifier RNDM_INITIALISATION placement=global negatable default qualifier RECORDING placement=global negatable default qualifier PROGRESS_PRINT placement=global negatable default qualifier PROFILE placement=global negatable default qualifier SYNCHRONISE placement=global negatable qualifier TERMINAL placement=global value(list,type=TERMINAL_GTS) negatable default qualifier METAFILE placement=global value(list,type=METAFILE_GTS) negatable default qualifier HIGZ qualifier GKS qualifier GTS_GRAL, default qualifier DEC_GKS qualifier ATC_GKS disallow(TERM_TYPE and (TERM_GKSID or TERM_CONID)) disallow(META_TYPE and (META_GKSID or META_OFFSET)) define syntax GARFIELD_DEC qualifier OLD placement=global nonnegatable qualifier PRO placement=global nonnegatable qualifier NEW placement=global nonnegatable qualifier EXP placement=global nonnegatable qualifier DEBUG placement=global negatable qualifier IDENTIFICATION placement=global negatable qualifier INPUT_LISTING placement=global negatable qualifier RNDM_INITIALISATION placement=global negatable default qualifier RECORDING placement=global negatable default qualifier PROGRESS_PRINT placement=global negatable default qualifier PROFILE placement=global negatable default qualifier SYNCHRONISE placement=global negatable qualifier TERMINAL placement=global value(list,type=TERMINAL_DEC) negatable default qualifier METAFILE placement=global value(list,type=METAFILE_DEC) negatable default qualifier HIGZ qualifier GKS qualifier GTS_GRAL qualifier DEC_GKS, default qualifier ATC_GKS disallow(TERM_TYPE and (TERM_GKSID or TERM_CONID)) disallow(META_TYPE and (META_GKSID or META_OFFSET)) define syntax GARFIELD_ATC qualifier OLD placement=global nonnegatable qualifier PRO placement=global nonnegatable qualifier NEW placement=global nonnegatable qualifier EXP placement=global nonnegatable qualifier DEBUG placement=global negatable qualifier IDENTIFICATION placement=global negatable qualifier INPUT_LISTING placement=global negatable qualifier RNDM_INITIALISATION placement=global negatable default qualifier RECORDING placement=global negatable default qualifier PROGRESS_PRINT placement=global negatable default qualifier PROFILE placement=global negatable default qualifier SYNCHRONISE placement=global negatable qualifier TERMINAL placement=global value(list,type=TERMINAL_ATC) negatable default qualifier METAFILE placement=global value(list,type=METAFILE_ATC) negatable default qualifier HIGZ qualifier GKS qualifier GTS_GRAL qualifier DEC_GKS qualifier ATC_GKS, default disallow(TERM_TYPE and (TERM_GKSID or TERM_CONID)) disallow(META_TYPE and (META_GKSID or META_OFFSET)) define syntax GARFIELD_HIGZ qualifier OLD placement=global nonnegatable qualifier PRO placement=global nonnegatable qualifier NEW placement=global nonnegatable qualifier EXP placement=global nonnegatable qualifier DEBUG placement=global negatable qualifier IDENTIFICATION placement=global negatable qualifier INPUT_LISTING placement=global negatable qualifier RNDM_INITIALISATION placement=global negatable default qualifier RECORDING placement=global negatable default qualifier PROGRESS_PRINT placement=global negatable default qualifier PROFILE placement=global negatable default qualifier SYNCHRONISE placement=global negatable qualifier TERMINAL placement=global value(list,type=TERMINAL_HIGZ) negatable default qualifier METAFILE placement=global value(list,type=METAFILE_HIGZ) negatable default qualifier HIGZ, default qualifier GKS qualifier GTS_GRAL qualifier DEC_GKS qualifier ATC_GKS disallow(TERM_TYPE and (TERM_GKSID or TERM_CONID)) disallow(META_TYPE and (META_GKSID or META_OFFSET)) +DECK,MANPAGE,IF=UNIX. DECK ID>, garfield.l .TH garfield 1 "97/02/05" "CERN Program Library" "Drift chamber simulation" .DS )H Cern Program Library .DS ]W garfield .SH NAME garfield \- Simulation of 2\-dimensional drift chambers .SH DESCRIPTION Garfield is a program for the detailed simulation of 2-dimensional wire chambers consisting of thin wires and equipotential planes. Its main use is in the area of field, drift\-line and signal calculations as well as the electrostatic optimisation of a chamber. .sp Garfield provides a convenient interface to the Magboltz program of Steve Biagi which computes electron transport properties for nearly arbitrary gas mixtures. Also the Heed program of Igor Smirnov, which simulates ionisation of gas molecules due to particles traversing the chamber, is interfaced with Garfield. .sp Garfield is of the 'slow' Monte\-Carlo type in the sense that it never uses, e.g. to save CPU time, a poor approximation if a better approximation is known to the author. That is not to say that no efforts have been made to make the program reasonably fast. Rather, it's not a program normally used to accumulate large statistics of drift-chamber responses. .sp The program can be used both in batch and in interactive mode on Unix systems. The program has a comprehensive built-in help facility. .SH FORMAT Garfield is started by typing: .sp .nf .nj $ garfield [-terminal {type T | GKS_id G connection_id C} ] [-noterminal] [-metafile {type T | GKS_id G offset O name F} ] [-nometafile] [-nodebug | -debug] [-noidentification | -identification] [-RNDM_initialisation | -noRNDMinitialisation] [-recording | -norecording ] [-progress_print | -noprogress_print ] [-profile | noprofile ] .ju .fi .sp Case is significant for all arguments. .SH ARGUMENTS .fo .sp -debug .in 15 Requests that debugging mode is initially on, that is, also during the initialisation phase. The information displayed is of hardly any use to the casual user. .sp By default debugging mode is initially off. .sp Debugging mode can be switched off and on at any time during program execution. .in 2 .sp -identification .in 15 Tracing information will be displayed from the start of program execution. The information displayed is of hardly any use to the casual user. .sp By default tracing is initially off. .sp Tracing can be switched off and on at any time during program execution. .in 2 .sp -RNDM_initialisation .in 15 This switch controls whether or not the random number generators are called a number of times (determined by the hour of the day) at the job initialisation phase. If switched off, instructions using Monte Carlo techniques will produce identical results in different runs. .sp By default the random number generators are initialised. .in 2 .sp -recording .in 15 Garfield usually records on a file the input entered from the terminal during an interactive run. Use -norecording to disable this feature. .in 2 .sp -progress_print .in 15 Some routines use considerable CPU time. This option enables you to follow their progress. .in 2 .sp -profile .in 15 By default, Garfield tries to read on startup a file called garfinit or .garfinit. Specify -noprofile if do not wish this to happen. .in 2 .sp -terminal .in 15 Specifies the kind of screen you're sitting behind. .sp When you run an executable linked with GKS or PHIGS, you can either specify the screen by the type, or by the GKS identifier and a suitable connection identifier of the workstation. The list of workstation types depends on the GKS with which Garfield has been linked. .sp When you run an executable linked with HIGZ, you have to specify the screen by the type. The list of workstations types can be found in the HIGZ manual. .sp Note that you have to type the type in the proper case. You may abbreviate the string down to its shortest unambiguous form. .in 2 .sp -noterminal .in 15 Requests that no graphics be displayed on the terminal. .in 2 .sp -metafile .in 15 Requests a metafile to be written and specifies the format (e.g. PostScript, Appendix_E). .sp When you run an executable linked with GKS or PHIGS, you can either specify this by the type, or by the GKS identifier, the offset between the connection identifier and the logical unit of the metafile and the file name of the metafile. The list of workstation types depends on the GKS with which Garfield has been linked. .sp When you run an executable linked with HIGZ, you have to specify the screen by the type. The list of workstation types can be found in the HIGZ manual. .sp Note that you have to type the type in the proper case. You may abbreviate the string down to its shortest unambiguous form. .in 2 .sp -nometafile .in 15 Suppresses metafile output. .in 2 .SH DOCUMENTATION An extensive printed manual exists which contains information about the program, instructions for compilation, input format, background of the model etc. It can be obtained from the CERN program library, from the author or from the person responsible locally for the program. The manual is frequently updated and you have to make sure yours is not more than, say, half a year old. The manual is also available via WWW: .B http://consult.cern.ch/writeup/garfield .sp Inside the program you can type HELP (or ?) at almost any time. The help facility gives detailed information about the instructions with examples. .SH CONDITIONS FOR USE Garfield is provided to you under the condition that it shall be used only for scientific purposes. The use of the program and its auxilliary files is free of charge. The program and associated files shall not be sold or otherwise made available to third parties without the consent of the author. The writeup and other parts of the documentation shall not be copied, reproduced other than for private use. .sp The author appreciates receiving a copy of any note, internal or published, for which Garfield has been used. +DECK,HELPCMS,IF=CMS. DECK ID>, GARFIELD.SHLPCMS .cm CAT: CMS .cm NAM: GARFIELD .cm EXP: Runs Garfield, a drift-chamber simulation program .cm DAT: 12/02/97 .cm A/R: Rob Veenhof (Rob.Veenhof@cern.ch) .cm KEY: GARFIELD DRIFT-CHAMBER DRIFT CHAMBER SIMULATION FIELD POTENTIAL .cm KEY: ELECTROSTATICS CONTOUR VECTOR GAS DRIFT-LINE SIGNAL MAXWELL .cm KEY: OPTIMISATION CHARGE WIRE MWPC ISOCHRONY ISOCHRONOUS ISOCHRONE .cm KEY: TWO-DIMENSIONAL EQUIPOTENTIAL X(T)-RELATION X(T) X-T ARRIVAL .cm KEY: TIME ARRIVAL-TIME 2D NQS W5050 ELECTRON ION MAGBOLTZ MIX .cm KEY: MIXING ARGON HELIUM XENON KRYPTON ETHANE METHANE METHYLAL .cm KEY: NITROGEN WATER CO2 NEON ISOBUTANE PROPANE NEOPENTANE CF4 .cm KEY: NO NO2 NITRIC NITROUS OXIDE CALIBRATION .cm KEY: FREON OXYGEN DME ETHENE ACETYLENE HEXAGON OCTAGON TRIANGLE .cm KEY: TUBE PRESSURE TEMPERATURE FORCE FORCES SAG DISPLACEMENT .cm KEY: HEED IONISATION ENERGY LOSS CLUSTER .cm ABS: This help file describes how to use Garfield on VM/CMS and .cm ABS: how to submit an NQS batch job from VM/CMS. Garfield is a .cm ABS: drift chamber simulation program, registered as item W5050 .cm ABS: in the CERN program library and described in a long writeup .cm ABS: available from the CERN program library office. .cm ABS: .cm ABS: (Valid for Garfield version 7.04.) .cm WEB: http://consult.cern.ch/writeup/garfield .cm END: .cm Copyright: Rob Veenhof, 2001. .tr % 40 GARFIELD .sp Note: the CMS version of this program has not been updated since October 1995. .sp Garfield tries to simulate drift-chambers made up of (thin) wires and infinite equipotential planes. The program can also handle sets of wires enclosed in round and polygonal tubes. The chambers may be periodic and magnetic fields can be taken into account. The electrostatics of the program are inherently two dimensional. .sp For input, the program needs a listing of the wires, planes and periodicities (either in Cartesian or in polar coordinates) and a detailed description of the gas: ion mobility, electron drift velocity, diffusion coefficient(s), Townsend coefficient and attachment coefficient (as a function of the field strength) and also1 parameters related to the interaction with fast particles. .sp Descriptions for some commonly used gasses and gas mixtures are built into the program, and the electron transport properties of other gas mixtures can be computed via an interface with the Magboltz program. .sp Examples of tasks the program can carry out are: .of 2 .sp *%Computing the field, the potential (and any function thereof) in the chamber and plotting it in a variety of ways: histogram, vector plot, contours, surface. Garfield can also output the field in the form of printed tables; .of 2 .sp *%Computing transport properties in nearly arbitrary gas mixtures via a transparent interface to Magboltz; .of 2 .sp *%Computing, plotting and tabulating of drift-lines of electrons and ions in the chamber; .of 2 .sp *%Calculating arrival time spectra and space-time relations; .of 2 .sp *%Simulation of the signal, effects which can be accounted for are: cluster formation, cluster size distribution, longitudinal and transversal diffusion, avalanche, current induced by moving ions. The program has also facilities to compute the arrival time distribution of the first, second etc. electron from a given track; .of 2 .sp *%Electrostatic optimisation under various constraints such as homogenous drift-field, equal gain on various wires. .of 2 .sp *%Computation of the force acting on a wire, and the displacement that results from it. .of .sp Garfield is a self-contained program and very little knowledge of VM/CMS is required to run it; no knowledge at all of programming languages is needed. The program has an extensive built-in help facility and is described in a writeup which is available from the program library office. .sp The program is available on several CERN central computers: VM/CMS, Vax and various Unix systems such as CSF. The program can be run on a remote Unix system via NQS from VM. Little use of machine specific features is made. .sp FORMAT: .sp The format for normal VM use and for job submission via NQS is: .sp .bx 1 79 GARFIELD [input file] [/ output file] [(options] options: TERMINAL(TYPE type GKS_ID gksid CONNECTION_ID conid) NOTERMINAL METAFILE(TYPE type GKS_ID gksid OFFSET offset NAME name) NOMETAFILE GKS | HIGZ DISPLAY_NODE display NODEBUG | DEBUG NOIDENTIFICATION | IDENTIFICATION RNDM_INITIALISATION | NORNDM_INITIALISATION RECORDING | NORECORDING PFKEYS | NOPFKEYS | USERPFKEYS VM/CMS | NQS PRO | EXP | NEW | OLD SCALAR | VECTOR LIST | SET PANEL | NOPANEL TIME_LIMIT min[:sec] NQS_ACCOUNT nqs_userid NQS_SYSTEM nqs_system NQS_QUEUE nqs_queue RECIPIENT recipient PASSWORD password .bx off .sp The job is submitted in batch if an input file is given. An explicit BATCH SUBMIT should only be used in exceptional cases. .sp .of 20 input%file%%%%%%%%%%The dataset from which Garfield is to read its input. The name should be specified in the usual VM/CMS format: fn%ft%fm. Equal signs (=) in the file name are replaced by the corresponding defaults. Initially, the file-type defaults to "INPUT", the file-mode to "*"; you are free to change these settings via DEFAULTS%SET%GARFIELD. .sp Garfield will be run in batch if you choose the first format and specify an input file. The file will be sent to the batch machine at submission time; hence you can freely change it after submission. Garfield will be run interactively if this argument is omitted. .sp If you choose the second format, the job reads the input file if you specify one, otherwise it will look for GARFIELD%INPUT%* (or another default you may have defined). .sp .of 20 output%file%%%%%%%%%The dataset to which Garfield writes its output. The name should be specified in the usual VM/CMS format: fn%ft, without file mode. .sp Equal signs (=) in the file name are replaced by the corresponding defaults, if these are also equal signs, the corresponding fields of the input file are used. .sp The initial default is "GARFIELD OUTPUT", this default can be changed with DEFAULTS%SET%GARFIELD. .sp .of 20 type%%%%%%%%%%%%%%%%The type of graphics terminal or metafile that you wish to use. Examples of terminals are MG600 (for a Pericom Monterey), 4014 (Tektronix) and PG7800 (Pericom). Known metafile types include APPENDIX_E, POSTSCRIPT and EPS. Please send a message to RJD@CERNVM if your favourite type is not recognised. .sp If you use the same type all the time, you may wish to make it the default. Use the DEFAULTS%SET%GARFIELD command for this purpose. The initial defaults are PG7800 (terminal) and POSTSCRIPT (metafile). .sp .of 20 gksid%%%%%%%%%%%%%%%Workstations that are not known to Garfield can be accessed by specifying the GKS identifier of the driver, an appropriate connection identifier and perhaps a file name. .sp .of 20 conid%%%%%%%%%%%%%%%This is the connection identifier of the workstation. This parameter depends on the kind of GKS you're using. .sp You need to specify this parameter only if you're using a workstation that is not known to Garfield. .sp .of 20 offset%%%%%%%%%%%%%%In the case of a file oriented workstation, Garfield chooses the logical unit on which the file is opened but you have to specify the difference between the logical unit number and the connection identifier. .sp You need to specify this parameter only if you're using a workstation that is not known to Garfield. .sp .of 20 name%%%%%%%%%%%%%%%%The name of the picture file. The file name should be specified in the format fn.ft.fm or fn.ft, the file type is compulsory. An equal sign may be used for the file name, to indicate that the name of the input file is to be used; an asterisk as file type will be replaced by 'METAFILE', 'PS' or 'EPS' as appropriate. .sp .of 20 DEBUG%%%%%%%%%%%%%%%Requests debugging during the initialisation phase. In addition to switching on the DEBUG option inside the program, this enables printing of underflow, overflow and divide-by-zero messages during the entire program execution time. .sp .of 20 GKS%%%%%%%%%%%%%%%%%Asks for a version of the program that has been linked with GKS. When using the GKS version, you may in addition specify the terminal and metafile type. This is currently the default. .sp .of 20 HIGZ%%%%%%%%%%%%%%%%Asks for a version of the program that has been linked with HIGZ. When the HIGZ version is used, X-windows output is assumed and a PostScript file is generated automatically. The location of the workstation for X-windows output can be specified with DISPLAY_NODE. Currently, the default is GKS. .sp .of 20 display%%%%%%%%%%%%%Tells HIGZ where it should send the X-windows output. This parameter can be given the value '*' in which case the currently set DISPLAY parameter will not be changed. .sp .of 20 IDENTIFICATION%%%%%%Requests tracing output during the initialisation phase. .sp .of 20 RNDM_INITIALISATION%To ensure the program produces different results in different runs using Monte-Carlo techniques (signal section), the random number generator is called a number of times (the number is derived from the time of the day) at the start of program execution. To suppress this initialisation, specify NORNDM_INITIALISATION. .sp .of 20 RECORDING%%%%%%%%%%%All terminal input is recorded in a file if this option is specified. This option is not meaningful and hence ignored in batch. .sp .of 20 PFKEYS%%%%%%%%%%%%%%Sets the PF keys to section names in Garfield. They are reset on normal program termination. If you specify this option while setting defaults (SET option), you will be shown a further panel in which you can edit the PF key settings. The initial setting is as follows: .sp .fo off +------------+------------+-------------------+-----------+ | & Cell | & Gas | Retrieve forward | Interrupt | +------------+------------+-------------------+-----------+ | & Field | & Optimise | Retrieve backward | Clear | +------------+------------+-------------------+-----------+ | Help | & Drift | & Quit | | +------------+------------+-------------------+ Undefined | | & Signal | Subset | | +-------------------------+-------------------+-----------+ .fo on .sp .of 20 USERPFKEYS%%%%%%%%%%Calls the USERPF EXEC to set the PF key definitions. When you choose this option, you can customise the PF key settings by making a private copy of the EXEC and applying the changes you wish. Choosing USERPF doesn't make you loose the PF key settings you may have entered as part of the Garfield defaults. The latter are simply not used when you select USERPF. The options PFKEYS and USERPFKEYS are mutually exclusive. .sp .of 20 VM/CMS%%%%%%%%%%%%%%Requests VM/CMS processing, either interactively or in batch depending on the command format. This is the initial default. .sp .of 20 NQS%%%%%%%%%%%%%%%%%Requests the job to be submitted via NQS to a remote host. When Garfield has finished, the output log file, the metafile and any file you have created during the job are returned to your reader. You have to specify the name of the remote system (see NQS_SYSTEM), a user-identifier on the remote system (see NQS_ACCOUNT), optionally also the queue on the remote system in which the job is to be run (see NQS_QUEUE) and optionally the VM user identifier to which the job output is to be sent back (see RECIPIENT). .sp .of 20 PRO%%%%%%%%%%%%%%%%%Selects the current 'official' version. These files are not changed during a CERN program library update cycle unless major bugs are found. The printed writeup and the on-line help refer to this program. This is the default version. .sp .of 20 EXP%%%%%%%%%%%%%%%%%Selects the experimental program version on the authors' disk. You are free to use if but keep in mind that your results may change from one run to another ! The disk is password protected - the password should be easy to guess for readers of the comics. .sp .of 20 NEW%%%%%%%%%%%%%%%%%Selects the program which will become the default at the next major program library update. This program may not always be available; this version changes occasionally but it should be fairly stable on the whole. .sp .of 20 OLD%%%%%%%%%%%%%%%%%Selects the previous PRO version of the program. It is provided for backwards compatibility purposes only. .sp .of 20 SCALAR%%%%%%%%%%%%%%Takes the regular copy of the module. .sp .of 20 VECTOR%%%%%%%%%%%%%%Computations on chambers with a very large number of wires (several thousands) require considerable storage and consume prohibitive amounts of CPU time. This options gives access to a module that runs (only) in VM/XA mode and makes effective use of the IBM 900 vector processors available at CERN. Running it, requires 99 Mbyte of storage and permission to use the vector facilities. The former is available in batch class V at CERN, the latter has to be obtained from the DD division. .sp The accuracy of computations with large numbers of wires has to be checked carefully, contact the author for more information. .sp .of 20 LIST%%%%%%%%%%%%%%%%Displays the default values for the terminal type, the various run-time options, the program version and the three fields of the input file name. Garfield is not run if you select this option; furthermore, no other options should be specified along with LIST. Specifying this option is equivalent to DEFAULTS%LIST%GARFIELD. .sp .of 20 SET%%%%%%%%%%%%%%%%%Allows you to change the default terminal type, the various run-time options, the program version and the three fields of the input file name. Garfield is not run if you select this option. Specifying this option is equivalent to DEFAULTS%SET%GARFIELD. .sp .of 20 PANEL%%%%%%%%%%%%%%%Requests that the defaults are entered via a panel. The IOS3270 facility must be available for this to work. .sp .of 20 NOPANEL%%%%%%%%%%%%%Reads the options you specify and stores them as new defaults without displaying a panel. The default file name can not be changed this way. .sp .of 20 min,%sec%%%%%%%%%%%%The maximum amount of time the job is allowed to run in the format min[:sec]. Example: TIME 10 means that the job can run for 10 minutes, type TIME 0:15 to have the job stopped after 15 seconds. Separate defaults for VM and NQS are remembered, both can be set via DEFAULTS%SET%GARFIELD. .sp .of 20 nqs_system%%%%%%%%%%The remote system on which the job is to be run. This is by default csf. .sp .of 20 nqs_userid%%%%%%%%%%The remote account to be used to run the job. .sp .of 20 nqs_queue%%%%%%%%%%%The queue on the remote system in which the jobs is to be run. The queue is by default set to "any", meaning that the system is free to choose a class depending on the CPU time you request. .sp .of 20 recipient%%%%%%%%%%%The user on VM who should receive the files left in the directory on the remote system when the job terminates. This is by default the account from which the job is submitted. .sp .of 20 password%%%%%%%%%%%%The read password for the RJD 192 disk. This password is needed only if you wish to use the EXP version of the module on VM/CMS at CERN. .sp .of EXAMPLE 1: GETTING STARTED ON VM .sp .in 11 Assume you have never used the program before and are sitting behind a VT100 Selenar terminal. The best thing to do then (apart from obtaining a copy of the printed manual) is to start the program interactively: .sp GARFIELD (TERM(TYPE VT100_SEL) .sp and to browse through the introductory part of the help file: .sp ? information .sp The getting started subtopic will give you some suggestions on what to do next. The help file is organised like on the Vax; to get out, hit the return key a couple of times until you see '(Main)' behind the prompt. To leave the program altogether, type: .sp &QUIT .sp You will probably quickly start to construct input files. They can easily be read-in when running interactively via the < command. You may also wish to have some paper output. Running in batch allows you to do that: one of the files you will find in your reader after the job has completed is called GARFIELD%METAFILE. After RECEIVEing this file on your disk, you can look at the metafile on a terminal with GKSTV or send it to a plotter using GRPLOT. .sp The command to send a job to VM batch is: .sp GARFIELD DC1 (VM .sp assuming the input is called DC1%INPUT, on any of the disks you are currently linked to. .sp .in EXAMPLE 2: SUBMITTING THE SAME JOB VIA NQS .sp .in 11 The same input file is submitted via NQS with the command: .sp GARFIELD DC1 (NQS (You may be asked to provide a password or an access code.) .sp When you run frequently jobs in batch, you may find it convenient to set defaults - both for NQS submission and for VM/CMS: .sp DEFAULTS SET GARFIELD .sp Be sure to check the spelling and case of your NQS user identifier. You may also find it convenient to modify the CPU time limits. .sp .in EXAMPLE 3: USING DATASETS .sp .in 11 You have made an input file called CHAMBER INPUT: .sp .bx 12 79 & Cell If vax Then $ cop cernvm::[rjd]cell.garflib cell.garflib get cell.garflib DC1 Elseif cms Then get cell.garflib DC1 Elseif cray Then $ fetch cell.garflib -t'fn=CELL,ft=GARFLIB' get "cell.garflib" DC1 Else Say "No idea where to get the input ... bye." & Stop Endif & Field > field.print print ex,ey,e,v > & Stop .bx off .sp This input file is designed to run on VM/CMS, NQS and Vax without modification - only the job submission command differs. .sp The input file first reads, if running on the Cray, the file CELL%GARFLIB from your VM/CMS 191 disk and stores it on the Cray as cell.garflib in your working directory. The job then goes on to read a member from this file and writes a field map to a dataset. When the job completes, the cell library (which is unchanged but which might have been modified) and the field map are sent back to you along with the metafile and the normal job output. .in .sp REMARKS .sp .of 11 Storage:%%%Garfield needs about 12 Mbyte of storage for the scalar module and 99 Mbyte for the vectorised module. A message will be printed if your machine is not big enough. .of .sp .of 11 CPU%usage:%The program eats as much CPU time as the most famous cat on earth eats lasagne. .of .sp .of 11 Batch%use:%When you submit Garfield for the first time, a file called GARFIELD%BATCHID is written on one of your RW disks, e.g. the A disk. Feel free to modify this file, but stick to the rules for such files: one line, 8 characters, at least the last 3 must be numeric. If Garfield encounters an invalid file, the file is removed and a file in default format is created instead. +DECK,GARFRUNM,IF=VAX. DECK ID>, GARFRUNMSG.MSG .title Garfield user interface program error messages .ident 'Version 7.04' .facility Garfield, 1234 /prefix=Garfield_ .severity INFORMATION ARGLIST <+++ Argument list: !AS.> /fao_count=1 LOGDEFINE <+++ Defining logical !AS as !AS.> /fao_count=2 MACHINE <+++ Running on !AS.> /fao_count=1 NOHELP /fao_count=1 NOLSE /fao_count=1 SYMDEFINE <+++ Defining symbol !AS as !AS.> /fao_count=2 VERSION <+++ Going to call the !AS version.> /fao_count=1 GRAPHICS <+++ Assuming !AS for graphics system.> /fao_count=1 .severity WARNING NOMACHINE /fao_count=0 NOGRAPHICS /fao_count=0 .severity ERROR ARGDECODE /fao_count=0 ARGFETCH /fao_count=0 CALLFAIL /fao_count=0 NOSYMBOL /fao_count=0 NOLOGICAL /fao_count=1 NOMODULE /fao_count=1 NOSUCHVERS /fao_count=1 .severity FATAL .end +QUIT.